From 0eaccc1b8520d605b1e00685e1c3f8acb5da534c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 27 Sep 2024 10:51:38 +0200 Subject: [PATCH 01/36] BUmp versions in opam files --- dot-merlin-reader.opam | 2 +- merlin.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam index 0867c078a..3f243280f 100644 --- a/dot-merlin-reader.opam +++ b/dot-merlin-reader.opam @@ -13,7 +13,7 @@ build: [ depends: [ "ocaml" {>= "5.2" } "dune" {>= "2.9.0"} - "merlin-lib" {>= "5.0"} + "merlin-lib" {>= "5.2"} "ocamlfind" {>= "1.6.0"} ] description: diff --git a/merlin.opam b/merlin.opam index 478ec627d..e5b9c4ba3 100644 --- a/merlin.opam +++ b/merlin.opam @@ -14,7 +14,7 @@ depends: [ "ocaml" {>= "5.2" & < "5.3"} "dune" {>= "3.0.0"} "merlin-lib" {= version} - "dot-merlin-reader" {>= "5.0"} + "dot-merlin-reader" {>= "5.2"} "ocaml-index" {>= "1.0" & post} "yojson" {>= "2.0.0"} "conf-jq" {with-test} From 74c871379253d4833f4460cd2b188a52df752a80 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 17 Sep 2024 01:20:06 +0200 Subject: [PATCH 02/36] Fetch OCaml upstream ocaml/ocaml upstream from 4d6ecfb5cf4a5da814784dee7363a15ea278f324 --- upstream/ocaml_503/base-rev.txt | 1 + upstream/ocaml_503/file_formats/cmi_format.ml | 119 + .../ocaml_503/file_formats/cmi_format.mli | 49 + upstream/ocaml_503/file_formats/cmt_format.ml | 483 ++ .../ocaml_503/file_formats/cmt_format.mli | 125 + upstream/ocaml_503/parsing/ast_helper.ml | 653 ++ upstream/ocaml_503/parsing/ast_helper.mli | 501 ++ upstream/ocaml_503/parsing/ast_invariants.ml | 213 + upstream/ocaml_503/parsing/ast_invariants.mli | 23 + upstream/ocaml_503/parsing/ast_iterator.ml | 747 ++ upstream/ocaml_503/parsing/ast_iterator.mli | 87 + upstream/ocaml_503/parsing/ast_mapper.ml | 1177 +++ upstream/ocaml_503/parsing/ast_mapper.mli | 211 + upstream/ocaml_503/parsing/asttypes.ml | 72 + upstream/ocaml_503/parsing/asttypes.mli | 69 + upstream/ocaml_503/parsing/attr_helper.ml | 59 + upstream/ocaml_503/parsing/attr_helper.mli | 39 + .../ocaml_503/parsing/builtin_attributes.ml | 412 + .../ocaml_503/parsing/builtin_attributes.mli | 187 + upstream/ocaml_503/parsing/depend.ml | 632 ++ upstream/ocaml_503/parsing/depend.mli | 46 + upstream/ocaml_503/parsing/docstrings.ml | 427 + upstream/ocaml_503/parsing/docstrings.mli | 223 + upstream/ocaml_503/parsing/lexer.mli | 70 + upstream/ocaml_503/parsing/lexer.mll | 975 +++ upstream/ocaml_503/parsing/location.ml | 1016 +++ upstream/ocaml_503/parsing/location.mli | 368 + upstream/ocaml_503/parsing/longident.ml | 50 + upstream/ocaml_503/parsing/longident.mli | 58 + upstream/ocaml_503/parsing/parse.ml | 178 + upstream/ocaml_503/parsing/parse.mli | 110 + upstream/ocaml_503/parsing/parser.mly | 4152 ++++++++++ upstream/ocaml_503/parsing/parsetree.mli | 1125 +++ upstream/ocaml_503/parsing/pprintast.ml | 1811 +++++ upstream/ocaml_503/parsing/pprintast.mli | 71 + upstream/ocaml_503/parsing/printast.ml | 1023 +++ upstream/ocaml_503/parsing/printast.mli | 32 + upstream/ocaml_503/parsing/syntaxerr.ml | 52 + upstream/ocaml_503/parsing/syntaxerr.mli | 45 + upstream/ocaml_503/parsing/unit_info.ml | 141 + upstream/ocaml_503/parsing/unit_info.mli | 173 + upstream/ocaml_503/typing/annot.mli | 23 + upstream/ocaml_503/typing/btype.ml | 789 ++ upstream/ocaml_503/typing/btype.mli | 311 + upstream/ocaml_503/typing/cmt2annot.ml | 192 + upstream/ocaml_503/typing/cmt2annot.mli | 26 + upstream/ocaml_503/typing/ctype.ml | 5661 +++++++++++++ upstream/ocaml_503/typing/ctype.mli | 475 ++ upstream/ocaml_503/typing/datarepr.ml | 239 + upstream/ocaml_503/typing/datarepr.mli | 45 + upstream/ocaml_503/typing/env.ml | 3729 +++++++++ upstream/ocaml_503/typing/env.mli | 528 ++ upstream/ocaml_503/typing/envaux.ml | 119 + upstream/ocaml_503/typing/envaux.mli | 35 + upstream/ocaml_503/typing/errortrace.ml | 202 + upstream/ocaml_503/typing/errortrace.mli | 175 + .../ocaml_503/typing/errortrace_report.ml | 590 ++ .../ocaml_503/typing/errortrace_report.mli | 56 + upstream/ocaml_503/typing/gprinttyp.ml | 912 +++ upstream/ocaml_503/typing/gprinttyp.mli | 325 + upstream/ocaml_503/typing/ident.ml | 392 + upstream/ocaml_503/typing/ident.mli | 115 + upstream/ocaml_503/typing/includeclass.ml | 114 + upstream/ocaml_503/typing/includeclass.mli | 34 + upstream/ocaml_503/typing/includecore.ml | 1074 +++ upstream/ocaml_503/typing/includecore.mli | 154 + upstream/ocaml_503/typing/includemod.ml | 1311 +++ upstream/ocaml_503/typing/includemod.mli | 265 + .../typing/includemod_errorprinter.ml | 1045 +++ .../typing/includemod_errorprinter.mli | 19 + upstream/ocaml_503/typing/mtype.ml | 569 ++ upstream/ocaml_503/typing/mtype.mli | 55 + upstream/ocaml_503/typing/oprint.ml | 858 ++ upstream/ocaml_503/typing/oprint.mli | 36 + upstream/ocaml_503/typing/out_type.ml | 1973 +++++ upstream/ocaml_503/typing/out_type.mli | 259 + upstream/ocaml_503/typing/outcometree.mli | 166 + upstream/ocaml_503/typing/parmatch.ml | 2363 ++++++ upstream/ocaml_503/typing/parmatch.mli | 135 + upstream/ocaml_503/typing/path.ml | 148 + upstream/ocaml_503/typing/path.mli | 80 + upstream/ocaml_503/typing/patterns.ml | 254 + upstream/ocaml_503/typing/patterns.mli | 109 + upstream/ocaml_503/typing/persistent_env.ml | 384 + upstream/ocaml_503/typing/persistent_env.mli | 106 + upstream/ocaml_503/typing/predef.ml | 290 + upstream/ocaml_503/typing/predef.mli | 91 + upstream/ocaml_503/typing/primitive.ml | 257 + upstream/ocaml_503/typing/primitive.mli | 79 + upstream/ocaml_503/typing/printpat.ml | 173 + upstream/ocaml_503/typing/printpat.mli | 28 + upstream/ocaml_503/typing/printtyp.ml | 174 + upstream/ocaml_503/typing/printtyp.mli | 103 + upstream/ocaml_503/typing/printtyped.ml | 1003 +++ upstream/ocaml_503/typing/printtyped.mli | 23 + upstream/ocaml_503/typing/rawprinttyp.ml | 147 + upstream/ocaml_503/typing/rawprinttyp.mli | 20 + upstream/ocaml_503/typing/shape.ml | 368 + upstream/ocaml_503/typing/shape.mli | 201 + upstream/ocaml_503/typing/shape_reduce.ml | 342 + upstream/ocaml_503/typing/shape_reduce.mli | 62 + upstream/ocaml_503/typing/signature_group.ml | 155 + upstream/ocaml_503/typing/signature_group.mli | 83 + upstream/ocaml_503/typing/stypes.ml | 197 + upstream/ocaml_503/typing/stypes.mli | 35 + upstream/ocaml_503/typing/subst.ml | 834 ++ upstream/ocaml_503/typing/subst.mli | 147 + upstream/ocaml_503/typing/tast_iterator.ml | 695 ++ upstream/ocaml_503/typing/tast_iterator.mli | 72 + upstream/ocaml_503/typing/tast_mapper.ml | 912 +++ upstream/ocaml_503/typing/tast_mapper.mli | 75 + upstream/ocaml_503/typing/type_immediacy.ml | 43 + upstream/ocaml_503/typing/type_immediacy.mli | 40 + upstream/ocaml_503/typing/typeclass.ml | 2197 +++++ upstream/ocaml_503/typing/typeclass.mli | 137 + upstream/ocaml_503/typing/typecore.ml | 7083 +++++++++++++++++ upstream/ocaml_503/typing/typecore.mli | 275 + upstream/ocaml_503/typing/typedecl.ml | 2270 ++++++ upstream/ocaml_503/typing/typedecl.mli | 113 + .../ocaml_503/typing/typedecl_immediacy.ml | 68 + .../ocaml_503/typing/typedecl_immediacy.mli | 27 + .../ocaml_503/typing/typedecl_properties.ml | 73 + .../ocaml_503/typing/typedecl_properties.mli | 55 + .../ocaml_503/typing/typedecl_separability.ml | 668 ++ .../typing/typedecl_separability.mli | 132 + upstream/ocaml_503/typing/typedecl_unboxed.ml | 43 + .../ocaml_503/typing/typedecl_unboxed.mli | 20 + .../ocaml_503/typing/typedecl_variance.ml | 437 + .../ocaml_503/typing/typedecl_variance.mli | 75 + upstream/ocaml_503/typing/typedtree.ml | 895 +++ upstream/ocaml_503/typing/typedtree.mli | 921 +++ upstream/ocaml_503/typing/typemod.ml | 3521 ++++++++ upstream/ocaml_503/typing/typemod.mli | 143 + upstream/ocaml_503/typing/typeopt.ml | 227 + upstream/ocaml_503/typing/typeopt.mli | 42 + upstream/ocaml_503/typing/types.ml | 961 +++ upstream/ocaml_503/typing/types.mli | 758 ++ upstream/ocaml_503/typing/typetexp.ml | 972 +++ upstream/ocaml_503/typing/typetexp.mli | 109 + upstream/ocaml_503/typing/untypeast.ml | 965 +++ upstream/ocaml_503/typing/untypeast.mli | 87 + upstream/ocaml_503/typing/value_rec_check.ml | 1421 ++++ upstream/ocaml_503/typing/value_rec_check.mli | 20 + upstream/ocaml_503/typing/value_rec_types.mli | 27 + upstream/ocaml_503/utils/arg_helper.ml | 127 + upstream/ocaml_503/utils/arg_helper.mli | 68 + upstream/ocaml_503/utils/binutils.ml | 684 ++ upstream/ocaml_503/utils/binutils.mli | 30 + .../ocaml_503/utils/build_path_prefix_map.ml | 118 + .../ocaml_503/utils/build_path_prefix_map.mli | 61 + upstream/ocaml_503/utils/ccomp.ml | 209 + upstream/ocaml_503/utils/ccomp.mli | 38 + upstream/ocaml_503/utils/clflags.ml | 774 ++ upstream/ocaml_503/utils/clflags.mli | 317 + upstream/ocaml_503/utils/compression.ml | 31 + upstream/ocaml_503/utils/compression.mli | 34 + upstream/ocaml_503/utils/config.common.ml.in | 163 + upstream/ocaml_503/utils/config.fixed.ml | 73 + .../ocaml_503/utils/config.generated.ml.in | 94 + upstream/ocaml_503/utils/config.mli | 266 + upstream/ocaml_503/utils/consistbl.ml | 95 + upstream/ocaml_503/utils/consistbl.mli | 77 + upstream/ocaml_503/utils/diffing.ml | 463 ++ upstream/ocaml_503/utils/diffing.mli | 147 + upstream/ocaml_503/utils/diffing_with_keys.ml | 208 + .../ocaml_503/utils/diffing_with_keys.mli | 77 + upstream/ocaml_503/utils/domainstate.ml.c | 38 + upstream/ocaml_503/utils/domainstate.mli.c | 24 + upstream/ocaml_503/utils/format_doc.ml | 481 ++ upstream/ocaml_503/utils/format_doc.mli | 297 + upstream/ocaml_503/utils/identifiable.ml | 249 + upstream/ocaml_503/utils/identifiable.mli | 113 + .../utils/int_replace_polymorphic_compare.ml | 8 + .../utils/int_replace_polymorphic_compare.mli | 8 + upstream/ocaml_503/utils/lazy_backtrack.ml | 87 + upstream/ocaml_503/utils/lazy_backtrack.mli | 34 + upstream/ocaml_503/utils/linkdeps.ml | 142 + upstream/ocaml_503/utils/linkdeps.mli | 64 + upstream/ocaml_503/utils/load_path.ml | 239 + upstream/ocaml_503/utils/load_path.mli | 120 + upstream/ocaml_503/utils/local_store.ml | 74 + upstream/ocaml_503/utils/local_store.mli | 67 + upstream/ocaml_503/utils/misc.ml | 1392 ++++ upstream/ocaml_503/utils/misc.mli | 832 ++ upstream/ocaml_503/utils/numbers.ml | 88 + upstream/ocaml_503/utils/numbers.mli | 51 + upstream/ocaml_503/utils/profile.ml | 335 + upstream/ocaml_503/utils/profile.mli | 49 + .../utils/strongly_connected_components.ml | 195 + .../utils/strongly_connected_components.mli | 43 + upstream/ocaml_503/utils/targetint.ml | 104 + upstream/ocaml_503/utils/targetint.mli | 208 + upstream/ocaml_503/utils/terminfo.ml | 45 + upstream/ocaml_503/utils/terminfo.mli | 32 + upstream/ocaml_503/utils/warnings.ml | 1259 +++ upstream/ocaml_503/utils/warnings.mli | 171 + 196 files changed, 86849 insertions(+) create mode 100644 upstream/ocaml_503/base-rev.txt create mode 100644 upstream/ocaml_503/file_formats/cmi_format.ml create mode 100644 upstream/ocaml_503/file_formats/cmi_format.mli create mode 100644 upstream/ocaml_503/file_formats/cmt_format.ml create mode 100644 upstream/ocaml_503/file_formats/cmt_format.mli create mode 100644 upstream/ocaml_503/parsing/ast_helper.ml create mode 100644 upstream/ocaml_503/parsing/ast_helper.mli create mode 100644 upstream/ocaml_503/parsing/ast_invariants.ml create mode 100644 upstream/ocaml_503/parsing/ast_invariants.mli create mode 100644 upstream/ocaml_503/parsing/ast_iterator.ml create mode 100644 upstream/ocaml_503/parsing/ast_iterator.mli create mode 100644 upstream/ocaml_503/parsing/ast_mapper.ml create mode 100644 upstream/ocaml_503/parsing/ast_mapper.mli create mode 100644 upstream/ocaml_503/parsing/asttypes.ml create mode 100644 upstream/ocaml_503/parsing/asttypes.mli create mode 100644 upstream/ocaml_503/parsing/attr_helper.ml create mode 100644 upstream/ocaml_503/parsing/attr_helper.mli create mode 100644 upstream/ocaml_503/parsing/builtin_attributes.ml create mode 100644 upstream/ocaml_503/parsing/builtin_attributes.mli create mode 100644 upstream/ocaml_503/parsing/depend.ml create mode 100644 upstream/ocaml_503/parsing/depend.mli create mode 100644 upstream/ocaml_503/parsing/docstrings.ml create mode 100644 upstream/ocaml_503/parsing/docstrings.mli create mode 100644 upstream/ocaml_503/parsing/lexer.mli create mode 100644 upstream/ocaml_503/parsing/lexer.mll create mode 100644 upstream/ocaml_503/parsing/location.ml create mode 100644 upstream/ocaml_503/parsing/location.mli create mode 100644 upstream/ocaml_503/parsing/longident.ml create mode 100644 upstream/ocaml_503/parsing/longident.mli create mode 100644 upstream/ocaml_503/parsing/parse.ml create mode 100644 upstream/ocaml_503/parsing/parse.mli create mode 100644 upstream/ocaml_503/parsing/parser.mly create mode 100644 upstream/ocaml_503/parsing/parsetree.mli create mode 100644 upstream/ocaml_503/parsing/pprintast.ml create mode 100644 upstream/ocaml_503/parsing/pprintast.mli create mode 100644 upstream/ocaml_503/parsing/printast.ml create mode 100644 upstream/ocaml_503/parsing/printast.mli create mode 100644 upstream/ocaml_503/parsing/syntaxerr.ml create mode 100644 upstream/ocaml_503/parsing/syntaxerr.mli create mode 100644 upstream/ocaml_503/parsing/unit_info.ml create mode 100644 upstream/ocaml_503/parsing/unit_info.mli create mode 100644 upstream/ocaml_503/typing/annot.mli create mode 100644 upstream/ocaml_503/typing/btype.ml create mode 100644 upstream/ocaml_503/typing/btype.mli create mode 100644 upstream/ocaml_503/typing/cmt2annot.ml create mode 100644 upstream/ocaml_503/typing/cmt2annot.mli create mode 100644 upstream/ocaml_503/typing/ctype.ml create mode 100644 upstream/ocaml_503/typing/ctype.mli create mode 100644 upstream/ocaml_503/typing/datarepr.ml create mode 100644 upstream/ocaml_503/typing/datarepr.mli create mode 100644 upstream/ocaml_503/typing/env.ml create mode 100644 upstream/ocaml_503/typing/env.mli create mode 100644 upstream/ocaml_503/typing/envaux.ml create mode 100644 upstream/ocaml_503/typing/envaux.mli create mode 100644 upstream/ocaml_503/typing/errortrace.ml create mode 100644 upstream/ocaml_503/typing/errortrace.mli create mode 100644 upstream/ocaml_503/typing/errortrace_report.ml create mode 100644 upstream/ocaml_503/typing/errortrace_report.mli create mode 100644 upstream/ocaml_503/typing/gprinttyp.ml create mode 100644 upstream/ocaml_503/typing/gprinttyp.mli create mode 100644 upstream/ocaml_503/typing/ident.ml create mode 100644 upstream/ocaml_503/typing/ident.mli create mode 100644 upstream/ocaml_503/typing/includeclass.ml create mode 100644 upstream/ocaml_503/typing/includeclass.mli create mode 100644 upstream/ocaml_503/typing/includecore.ml create mode 100644 upstream/ocaml_503/typing/includecore.mli create mode 100644 upstream/ocaml_503/typing/includemod.ml create mode 100644 upstream/ocaml_503/typing/includemod.mli create mode 100644 upstream/ocaml_503/typing/includemod_errorprinter.ml create mode 100644 upstream/ocaml_503/typing/includemod_errorprinter.mli create mode 100644 upstream/ocaml_503/typing/mtype.ml create mode 100644 upstream/ocaml_503/typing/mtype.mli create mode 100644 upstream/ocaml_503/typing/oprint.ml create mode 100644 upstream/ocaml_503/typing/oprint.mli create mode 100644 upstream/ocaml_503/typing/out_type.ml create mode 100644 upstream/ocaml_503/typing/out_type.mli create mode 100644 upstream/ocaml_503/typing/outcometree.mli create mode 100644 upstream/ocaml_503/typing/parmatch.ml create mode 100644 upstream/ocaml_503/typing/parmatch.mli create mode 100644 upstream/ocaml_503/typing/path.ml create mode 100644 upstream/ocaml_503/typing/path.mli create mode 100644 upstream/ocaml_503/typing/patterns.ml create mode 100644 upstream/ocaml_503/typing/patterns.mli create mode 100644 upstream/ocaml_503/typing/persistent_env.ml create mode 100644 upstream/ocaml_503/typing/persistent_env.mli create mode 100644 upstream/ocaml_503/typing/predef.ml create mode 100644 upstream/ocaml_503/typing/predef.mli create mode 100644 upstream/ocaml_503/typing/primitive.ml create mode 100644 upstream/ocaml_503/typing/primitive.mli create mode 100644 upstream/ocaml_503/typing/printpat.ml create mode 100644 upstream/ocaml_503/typing/printpat.mli create mode 100644 upstream/ocaml_503/typing/printtyp.ml create mode 100644 upstream/ocaml_503/typing/printtyp.mli create mode 100644 upstream/ocaml_503/typing/printtyped.ml create mode 100644 upstream/ocaml_503/typing/printtyped.mli create mode 100644 upstream/ocaml_503/typing/rawprinttyp.ml create mode 100644 upstream/ocaml_503/typing/rawprinttyp.mli create mode 100644 upstream/ocaml_503/typing/shape.ml create mode 100644 upstream/ocaml_503/typing/shape.mli create mode 100644 upstream/ocaml_503/typing/shape_reduce.ml create mode 100644 upstream/ocaml_503/typing/shape_reduce.mli create mode 100644 upstream/ocaml_503/typing/signature_group.ml create mode 100644 upstream/ocaml_503/typing/signature_group.mli create mode 100644 upstream/ocaml_503/typing/stypes.ml create mode 100644 upstream/ocaml_503/typing/stypes.mli create mode 100644 upstream/ocaml_503/typing/subst.ml create mode 100644 upstream/ocaml_503/typing/subst.mli create mode 100644 upstream/ocaml_503/typing/tast_iterator.ml create mode 100644 upstream/ocaml_503/typing/tast_iterator.mli create mode 100644 upstream/ocaml_503/typing/tast_mapper.ml create mode 100644 upstream/ocaml_503/typing/tast_mapper.mli create mode 100644 upstream/ocaml_503/typing/type_immediacy.ml create mode 100644 upstream/ocaml_503/typing/type_immediacy.mli create mode 100644 upstream/ocaml_503/typing/typeclass.ml create mode 100644 upstream/ocaml_503/typing/typeclass.mli create mode 100644 upstream/ocaml_503/typing/typecore.ml create mode 100644 upstream/ocaml_503/typing/typecore.mli create mode 100644 upstream/ocaml_503/typing/typedecl.ml create mode 100644 upstream/ocaml_503/typing/typedecl.mli create mode 100644 upstream/ocaml_503/typing/typedecl_immediacy.ml create mode 100644 upstream/ocaml_503/typing/typedecl_immediacy.mli create mode 100644 upstream/ocaml_503/typing/typedecl_properties.ml create mode 100644 upstream/ocaml_503/typing/typedecl_properties.mli create mode 100644 upstream/ocaml_503/typing/typedecl_separability.ml create mode 100644 upstream/ocaml_503/typing/typedecl_separability.mli create mode 100644 upstream/ocaml_503/typing/typedecl_unboxed.ml create mode 100644 upstream/ocaml_503/typing/typedecl_unboxed.mli create mode 100644 upstream/ocaml_503/typing/typedecl_variance.ml create mode 100644 upstream/ocaml_503/typing/typedecl_variance.mli create mode 100644 upstream/ocaml_503/typing/typedtree.ml create mode 100644 upstream/ocaml_503/typing/typedtree.mli create mode 100644 upstream/ocaml_503/typing/typemod.ml create mode 100644 upstream/ocaml_503/typing/typemod.mli create mode 100644 upstream/ocaml_503/typing/typeopt.ml create mode 100644 upstream/ocaml_503/typing/typeopt.mli create mode 100644 upstream/ocaml_503/typing/types.ml create mode 100644 upstream/ocaml_503/typing/types.mli create mode 100644 upstream/ocaml_503/typing/typetexp.ml create mode 100644 upstream/ocaml_503/typing/typetexp.mli create mode 100644 upstream/ocaml_503/typing/untypeast.ml create mode 100644 upstream/ocaml_503/typing/untypeast.mli create mode 100644 upstream/ocaml_503/typing/value_rec_check.ml create mode 100644 upstream/ocaml_503/typing/value_rec_check.mli create mode 100644 upstream/ocaml_503/typing/value_rec_types.mli create mode 100644 upstream/ocaml_503/utils/arg_helper.ml create mode 100644 upstream/ocaml_503/utils/arg_helper.mli create mode 100644 upstream/ocaml_503/utils/binutils.ml create mode 100644 upstream/ocaml_503/utils/binutils.mli create mode 100644 upstream/ocaml_503/utils/build_path_prefix_map.ml create mode 100644 upstream/ocaml_503/utils/build_path_prefix_map.mli create mode 100644 upstream/ocaml_503/utils/ccomp.ml create mode 100644 upstream/ocaml_503/utils/ccomp.mli create mode 100644 upstream/ocaml_503/utils/clflags.ml create mode 100644 upstream/ocaml_503/utils/clflags.mli create mode 100644 upstream/ocaml_503/utils/compression.ml create mode 100644 upstream/ocaml_503/utils/compression.mli create mode 100644 upstream/ocaml_503/utils/config.common.ml.in create mode 100644 upstream/ocaml_503/utils/config.fixed.ml create mode 100644 upstream/ocaml_503/utils/config.generated.ml.in create mode 100644 upstream/ocaml_503/utils/config.mli create mode 100644 upstream/ocaml_503/utils/consistbl.ml create mode 100644 upstream/ocaml_503/utils/consistbl.mli create mode 100644 upstream/ocaml_503/utils/diffing.ml create mode 100644 upstream/ocaml_503/utils/diffing.mli create mode 100644 upstream/ocaml_503/utils/diffing_with_keys.ml create mode 100644 upstream/ocaml_503/utils/diffing_with_keys.mli create mode 100644 upstream/ocaml_503/utils/domainstate.ml.c create mode 100644 upstream/ocaml_503/utils/domainstate.mli.c create mode 100644 upstream/ocaml_503/utils/format_doc.ml create mode 100644 upstream/ocaml_503/utils/format_doc.mli create mode 100644 upstream/ocaml_503/utils/identifiable.ml create mode 100644 upstream/ocaml_503/utils/identifiable.mli create mode 100644 upstream/ocaml_503/utils/int_replace_polymorphic_compare.ml create mode 100644 upstream/ocaml_503/utils/int_replace_polymorphic_compare.mli create mode 100644 upstream/ocaml_503/utils/lazy_backtrack.ml create mode 100644 upstream/ocaml_503/utils/lazy_backtrack.mli create mode 100644 upstream/ocaml_503/utils/linkdeps.ml create mode 100644 upstream/ocaml_503/utils/linkdeps.mli create mode 100644 upstream/ocaml_503/utils/load_path.ml create mode 100644 upstream/ocaml_503/utils/load_path.mli create mode 100644 upstream/ocaml_503/utils/local_store.ml create mode 100644 upstream/ocaml_503/utils/local_store.mli create mode 100644 upstream/ocaml_503/utils/misc.ml create mode 100644 upstream/ocaml_503/utils/misc.mli create mode 100644 upstream/ocaml_503/utils/numbers.ml create mode 100644 upstream/ocaml_503/utils/numbers.mli create mode 100644 upstream/ocaml_503/utils/profile.ml create mode 100644 upstream/ocaml_503/utils/profile.mli create mode 100644 upstream/ocaml_503/utils/strongly_connected_components.ml create mode 100644 upstream/ocaml_503/utils/strongly_connected_components.mli create mode 100644 upstream/ocaml_503/utils/targetint.ml create mode 100644 upstream/ocaml_503/utils/targetint.mli create mode 100644 upstream/ocaml_503/utils/terminfo.ml create mode 100644 upstream/ocaml_503/utils/terminfo.mli create mode 100644 upstream/ocaml_503/utils/warnings.ml create mode 100644 upstream/ocaml_503/utils/warnings.mli diff --git a/upstream/ocaml_503/base-rev.txt b/upstream/ocaml_503/base-rev.txt new file mode 100644 index 000000000..af55a8c25 --- /dev/null +++ b/upstream/ocaml_503/base-rev.txt @@ -0,0 +1 @@ +4d6ecfb5cf4a5da814784dee7363a15ea278f324 diff --git a/upstream/ocaml_503/file_formats/cmi_format.ml b/upstream/ocaml_503/file_formats/cmi_format.ml new file mode 100644 index 000000000..8e8c27edc --- /dev/null +++ b/upstream/ocaml_503/file_formats/cmi_format.ml @@ -0,0 +1,119 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +type pers_flags = + | Rectypes + | Alerts of alerts + | Opaque + +type error = + | Not_an_interface of filepath + | Wrong_version_interface of filepath * string + | Corrupted_interface of filepath + +exception Error of error + +(* these type abbreviations are not exported; + they are used to provide consistency across + input_value and output_value usage. *) +type signature = Types.signature_item list +type flags = pers_flags list +type header = modname * signature + +type cmi_infos = { + cmi_name : modname; + cmi_sign : signature; + cmi_crcs : crcs; + cmi_flags : flags; +} + +let input_cmi ic = + let (name, sign) = (Compression.input_value ic : header) in + let crcs = (input_value ic : crcs) in + let flags = (input_value ic : flags) in + { + cmi_name = name; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags; + } + +let read_cmi filename = + let ic = open_in_bin filename in + try + let buffer = + really_input_string ic (String.length Config.cmi_magic_number) + in + if buffer <> Config.cmi_magic_number then begin + close_in ic; + let pre_len = String.length Config.cmi_magic_number - 3 in + if String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len then + begin + let msg = + if buffer < Config.cmi_magic_number then "an older" else "a newer" in + raise (Error (Wrong_version_interface (filename, msg))) + end else begin + raise(Error(Not_an_interface filename)) + end + end; + let cmi = input_cmi ic in + close_in ic; + cmi + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_interface(filename))) + | Error e -> + close_in ic; + raise (Error e) + +let output_cmi filename oc cmi = +(* beware: the provided signature must have been substituted for saving *) + output_string oc Config.cmi_magic_number; + Compression.output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header); + flush oc; + let crc = Digest.file filename in + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + output_value oc (crcs : crcs); + output_value oc (cmi.cmi_flags : flags); + crc + +(* Error report *) + +open Format_doc + +let report_error_doc ppf = function + | Not_an_interface filename -> + fprintf ppf "%a@ is not a compiled interface" + Location.Doc.quoted_filename filename + | Wrong_version_interface (filename, older_newer) -> + fprintf ppf + "%a@ is not a compiled interface for this version of OCaml.@.\ + It seems to be for %s version of OCaml." + Location.Doc.quoted_filename filename older_newer + | Corrupted_interface filename -> + fprintf ppf "Corrupted compiled interface@ %a" + Location.Doc.quoted_filename filename + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error_doc err) + | _ -> None + ) + +let report_error = Format_doc.compat report_error_doc diff --git a/upstream/ocaml_503/file_formats/cmi_format.mli b/upstream/ocaml_503/file_formats/cmi_format.mli new file mode 100644 index 000000000..1a170106c --- /dev/null +++ b/upstream/ocaml_503/file_formats/cmi_format.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +type pers_flags = + | Rectypes + | Alerts of alerts + | Opaque + +type cmi_infos = { + cmi_name : modname; + cmi_sign : Types.signature_item list; + cmi_crcs : crcs; + cmi_flags : pers_flags list; +} + +(* write the magic + the cmi information *) +val output_cmi : string -> out_channel -> cmi_infos -> Digest.t + +(* read the cmi information (the magic is supposed to have already been read) *) +val input_cmi : in_channel -> cmi_infos + +(* read a cmi from a filename, checking the magic *) +val read_cmi : string -> cmi_infos + +(* Error report *) + +type error = + | Not_an_interface of filepath + | Wrong_version_interface of filepath * string + | Corrupted_interface of filepath + +exception Error of error + +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer diff --git a/upstream/ocaml_503/file_formats/cmt_format.ml b/upstream/ocaml_503/file_formats/cmt_format.ml new file mode 100644 index 000000000..853aeec8f --- /dev/null +++ b/upstream/ocaml_503/file_formats/cmt_format.ml @@ -0,0 +1,483 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Cmi_format +open Typedtree + +(* Note that in Typerex, there is an awful hack to save a cmt file + together with the interface file that was generated by ocaml (this + is because the installed version of ocaml might differ from the one + integrated in Typerex). +*) + + + +let read_magic_number ic = + let len_magic_number = String.length Config.cmt_magic_number in + really_input_string ic len_magic_number + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : string; + cmt_annots : binary_annots; + cmt_value_dependencies : + (Types.value_description * Types.value_description) list; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : Load_path.paths; + cmt_source_digest : Digest.t option; + cmt_initial_env : Env.t; + cmt_imports : (string * Digest.t option) list; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list +} + +type error = + Not_a_typedtree of string + +let iter_on_parts (it : Tast_iterator.iterator) = function + | Partial_structure s -> it.structure it s + | Partial_structure_item s -> it.structure_item it s + | Partial_expression e -> it.expr it e + | Partial_pattern (_category, p) -> it.pat it p + | Partial_class_expr ce -> it.class_expr it ce + | Partial_signature s -> it.signature it s + | Partial_signature_item s -> it.signature_item it s + | Partial_module_type s -> it.module_type it s + +let iter_on_annots (it : Tast_iterator.iterator) = function + | Implementation s -> it.structure it s + | Interface s -> it.signature it s + | Packed _ -> () + | Partial_implementation array -> Array.iter (iter_on_parts it) array + | Partial_interface array -> Array.iter (iter_on_parts it) array + +let iter_on_declaration f decl = + match decl with + | Value vd -> f vd.val_val.val_uid decl; + | Value_binding vb -> + let bound_idents = let_bound_idents_full [vb] in + List.iter (fun (_, _, _, uid) -> f uid decl) bound_idents + | Type td -> + if not (Btype.is_row_name (Ident.name td.typ_id)) then + f td.typ_type.type_uid (Type td) + | Constructor cd -> f cd.cd_uid decl + | Extension_constructor ec -> f ec.ext_type.ext_uid decl; + | Label ld -> f ld.ld_uid decl + | Module md -> f md.md_uid decl + | Module_type mtd -> f mtd.mtd_uid decl + | Module_substitution ms -> f ms.ms_uid decl + | Module_binding mb -> f mb.mb_uid decl + | Class cd -> f cd.ci_decl.cty_uid decl + | Class_type ct -> f ct.ci_decl.cty_uid decl + +let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) = { + Tast_iterator.default_iterator with + item_declaration = (fun _sub decl -> iter_on_declaration f decl); +} + +let need_to_clear_env = + try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false + with Not_found -> true + +let keep_only_summary = Env.keep_only_summary + +let cenv = + {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} + +let clear_part = function + | Partial_structure s -> Partial_structure (cenv.structure cenv s) + | Partial_structure_item s -> + Partial_structure_item (cenv.structure_item cenv s) + | Partial_expression e -> Partial_expression (cenv.expr cenv e) + | Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p) + | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce) + | Partial_signature s -> Partial_signature (cenv.signature cenv s) + | Partial_signature_item s -> + Partial_signature_item (cenv.signature_item cenv s) + | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) + +let clear_env binary_annots = + if need_to_clear_env then + match binary_annots with + | Implementation s -> Implementation (cenv.structure cenv s) + | Interface s -> Interface (cenv.signature cenv s) + | Packed _ -> binary_annots + | Partial_implementation array -> + Partial_implementation (Array.map clear_part array) + | Partial_interface array -> + Partial_interface (Array.map clear_part array) + + else binary_annots + +(* Every typedtree node with a located longident corresponding to user-facing + syntax should be indexed. *) +let iter_on_occurrences + ~(f : namespace:Shape.Sig_component_kind.t -> + Env.t -> Path.t -> Longident.t Location.loc -> + unit) = + let path_in_type typ name = + match Types.get_desc typ with + | Tconstr (type_path, _, _) -> + Some (Path.Pdot (type_path, name)) + | _ -> None + in + let add_constructor_description env lid = + function + | { Types.cstr_tag = Cstr_extension (path, _); _ } -> + f ~namespace:Extension_constructor env path lid + | { Types.cstr_uid = Predef name; _} -> + let id = List.assoc name Predef.builtin_idents in + f ~namespace:Constructor env (Pident id) lid + | { Types.cstr_res; cstr_name; _ } -> + let path = path_in_type cstr_res cstr_name in + Option.iter (fun path -> f ~namespace:Constructor env path lid) path + in + let add_label env lid { Types.lbl_name; lbl_res; _ } = + let path = path_in_type lbl_res lbl_name in + Option.iter (fun path -> f ~namespace:Label env path lid) path + in + let with_constraint ~env (_path, _lid, with_constraint) = + match with_constraint with + | Twith_module (path', lid') | Twith_modsubst (path', lid') -> + f ~namespace:Module env path' lid' + | _ -> () + in + Tast_iterator.{ default_iterator with + + expr = (fun sub ({ exp_desc; exp_env; _ } as e) -> + (match exp_desc with + | Texp_ident (path, lid, _) -> + f ~namespace:Value exp_env path lid + | Texp_construct (lid, constr_desc, _) -> + add_constructor_description exp_env lid constr_desc + | Texp_field (_, lid, label_desc) + | Texp_setfield (_, lid, label_desc, _) -> + add_label exp_env lid label_desc + | Texp_new (path, lid, _) -> + f ~namespace:Class exp_env path lid + | Texp_record { fields; _ } -> + Array.iter (fun (label_descr, record_label_definition) -> + match record_label_definition with + | Overridden ( + { Location.txt; loc}, + {exp_loc; _}) + when not exp_loc.loc_ghost + && loc.loc_start = exp_loc.loc_start + && loc.loc_end = exp_loc.loc_end -> + (* In the presence of punning we want to index the label + even if it is ghosted *) + let lid = { Location.txt; loc = {loc with loc_ghost = false} } in + add_label exp_env lid label_descr + | Overridden (lid, _) -> add_label exp_env lid label_descr + | Kept _ -> ()) fields + | Texp_instvar (_self_path, path, name) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | Texp_setinstvar (_self_path, path, name, _) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | Texp_override (_self_path, modifs) -> + List.iter (fun (id, (name : string Location.loc), _exp) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env (Path.Pident id) lid) + modifs + | Texp_extension_constructor (lid, path) -> + f ~namespace:Extension_constructor exp_env path lid + | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _ + | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_variant _ | Texp_array _ + | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _ + | Texp_send _ + | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _ + | Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable + | Texp_open _ -> ()); + default_iterator.expr sub e); + + (* Remark: some types get iterated over twice due to how constraints are + encoded in the typedtree. For example, in [let x : t = 42], [t] is + present in both a [Tpat_constraint] and a [Texp_constraint] node) *) + typ = + (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) -> + (match ctyp_desc with + | Ttyp_constr (path, lid, _ctyps) -> + f ~namespace:Type ctyp_env path lid + | Ttyp_package {pack_path; pack_txt} -> + f ~namespace:Module_type ctyp_env pack_path pack_txt + | Ttyp_class (path, lid, _typs) -> + (* Deprecated syntax to extend a polymorphic variant *) + f ~namespace:Type ctyp_env path lid + | Ttyp_open (path, lid, _ct) -> + f ~namespace:Module ctyp_env path lid + | Ttyp_any | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _ + | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ -> ()); + default_iterator.typ sub ct); + + pat = + (fun (type a) sub + ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) -> + (match pat_desc with + | Tpat_construct (lid, constr_desc, _, _) -> + add_constructor_description pat_env lid constr_desc + | Tpat_record (fields, _) -> + List.iter (fun (lid, label_descr, pat) -> + let lid = + let open Location in + (* In the presence of punning we want to index the label + even if it is ghosted *) + if (not pat.pat_loc.loc_ghost + && lid.loc.loc_start = pat.pat_loc.loc_start + && lid.loc.loc_end = pat.pat_loc.loc_end) + then {lid with loc = {lid.loc with loc_ghost = false}} + else lid + in + add_label pat_env lid label_descr) + fields + | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ + | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ + | Tpat_exception _ | Tpat_or _ -> ()); + List.iter (fun (pat_extra, _, _) -> + match pat_extra with + | Tpat_open (path, lid, _) -> + f ~namespace:Module pat_env path lid + | Tpat_type (path, lid) -> + f ~namespace:Type pat_env path lid + | Tpat_constraint _ | Tpat_unpack -> ()) + pat_extra; + default_iterator.pat sub pat); + + binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) -> + let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in + f ~namespace:Value bop_exp.exp_env bop_op_path lid; + default_iterator.binding_op sub bop); + + module_expr = + (fun sub ({ mod_desc; mod_env; _ } as me) -> + (match mod_desc with + | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid + | Tmod_structure _ | Tmod_functor _ | Tmod_apply _ | Tmod_apply_unit _ + | Tmod_constraint _ | Tmod_unpack _ -> ()); + default_iterator.module_expr sub me); + + open_description = + (fun sub ({ open_expr = (path, lid); open_env; _ } as od) -> + f ~namespace:Module open_env path lid; + default_iterator.open_description sub od); + + module_type = + (fun sub ({ mty_desc; mty_env; _ } as mty) -> + (match mty_desc with + | Tmty_ident (path, lid) -> + f ~namespace:Module_type mty_env path lid + | Tmty_with (_mty, l) -> + List.iter (with_constraint ~env:mty_env) l + | Tmty_alias (path, lid) -> + f ~namespace:Module mty_env path lid + | Tmty_signature _ | Tmty_functor _ | Tmty_typeof _ -> ()); + default_iterator.module_type sub mty); + + class_expr = + (fun sub ({ cl_desc; cl_env; _} as ce) -> + (match cl_desc with + | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid + | Tcl_structure _ | Tcl_fun _ | Tcl_apply _ | Tcl_let _ + | Tcl_constraint _ | Tcl_open _ -> ()); + default_iterator.class_expr sub ce); + + class_type = + (fun sub ({ cltyp_desc; cltyp_env; _} as ct) -> + (match cltyp_desc with + | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid + | Tcty_signature _ | Tcty_arrow _ | Tcty_open _ -> ()); + default_iterator.class_type sub ct); + + signature_item = + (fun sub ({ sig_desc; sig_env; _ } as sig_item) -> + (match sig_desc with + | Tsig_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor sig_env path lid + | Tsig_modsubst { ms_manifest; ms_txt } -> + f ~namespace:Module sig_env ms_manifest ms_txt + | Tsig_typext { tyext_path; tyext_txt } -> + f ~namespace:Type sig_env tyext_path tyext_txt + | Tsig_value _ | Tsig_type _ | Tsig_typesubst _ | Tsig_exception _ + | Tsig_module _ | Tsig_recmodule _ | Tsig_modtype _ | Tsig_modtypesubst _ + | Tsig_open _ | Tsig_include _ | Tsig_class _ | Tsig_class_type _ + | Tsig_attribute _ -> ()); + default_iterator.signature_item sub sig_item); + + structure_item = + (fun sub ({ str_desc; str_env; _ } as str_item) -> + (match str_desc with + | Tstr_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor str_env path lid + | Tstr_typext { tyext_path; tyext_txt } -> + f ~namespace:Type str_env tyext_path tyext_txt + | Tstr_eval _ | Tstr_value _ | Tstr_primitive _ | Tstr_type _ + | Tstr_exception _ | Tstr_module _ | Tstr_recmodule _ + | Tstr_modtype _ | Tstr_open _ | Tstr_class _ | Tstr_class_type _ + | Tstr_include _ | Tstr_attribute _ -> ()); + default_iterator.structure_item sub str_item) +} + +let index_declarations binary_annots = + let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in + let f uid fragment = Types.Uid.Tbl.add index uid fragment in + iter_on_annots (iter_on_declarations ~f) binary_annots; + index + +let index_occurrences binary_annots = + let index : (Longident.t Location.loc * Shape_reduce.result) list ref = + ref [] + in + let f ~namespace env path lid = + let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in + if not_ghost lid then + match Env.shape_of_path ~namespace env path with + | exception Not_found -> () + | { uid = Some (Predef _); _ } -> () + | path_shape -> + let result = Shape_reduce.local_reduce_for_uid env path_shape in + index := (lid, result) :: !index + in + iter_on_annots (iter_on_occurrences ~f) binary_annots; + !index + +exception Error of error + +let input_cmt ic = (Compression.input_value ic : cmt_infos) + +let output_cmt oc cmt = + output_string oc Config.cmt_magic_number; + Compression.output_value oc (cmt : cmt_infos) + +let read filename = +(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) + let ic = open_in_bin filename in + Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> + let magic_number = read_magic_number ic in + let cmi, cmt = + if magic_number = Config.cmt_magic_number then + None, Some (input_cmt ic) + else if magic_number = Config.cmi_magic_number then + let cmi = Cmi_format.input_cmi ic in + let cmt = try + let magic_number = read_magic_number ic in + if magic_number = Config.cmt_magic_number then + let cmt = input_cmt ic in + Some cmt + else None + with _ -> None + in + Some cmi, cmt + else + raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) + in + cmi, cmt + ) + +let read_cmt filename = + match read filename with + _, None -> raise (Error (Not_a_typedtree filename)) + | _, Some cmt -> cmt + +let read_cmi filename = + match read filename with + None, _ -> + raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) + | Some cmi, _ -> cmi + +let saved_types = ref [] +let value_deps = ref [] + +let clear () = + saved_types := []; + value_deps := [] + +let add_saved_type b = saved_types := b :: !saved_types +let get_saved_types () = !saved_types +let set_saved_types l = saved_types := l + +let record_value_dependency vd1 vd2 = + if vd1.Types.val_loc <> vd2.Types.val_loc then + value_deps := (vd1, vd2) :: !value_deps + +let save_cmt target binary_annots initial_env cmi shape = + if !Clflags.binary_annotations && not !Clflags.print_types then begin + Misc.output_to_file_via_temporary + ~mode:[Open_binary] (Unit_info.Artifact.filename target) + (fun temp_file_name oc -> + let this_crc = + match cmi with + | None -> None + | Some cmi -> Some (output_cmi temp_file_name oc cmi) + in + let sourcefile = Unit_info.Artifact.source_file target in + let cmt_ident_occurrences = + if !Clflags.store_occurrences then + index_occurrences binary_annots + else + [] + in + let cmt_annots = clear_env binary_annots in + let cmt_uid_to_decl = index_declarations cmt_annots in + let source_digest = Option.map Digest.file sourcefile in + let cmt = { + cmt_modname = Unit_info.Artifact.modname target; + cmt_annots; + cmt_value_dependencies = !value_deps; + cmt_comments = Lexer.comments (); + cmt_args = Sys.argv; + cmt_sourcefile = sourcefile; + cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); + cmt_loadpath = Load_path.get_paths (); + cmt_source_digest = source_digest; + cmt_initial_env = if need_to_clear_env then + keep_only_summary initial_env else initial_env; + cmt_imports = List.sort compare (Env.imports ()); + cmt_interface_digest = this_crc; + cmt_use_summaries = need_to_clear_env; + cmt_uid_to_decl; + cmt_impl_shape = shape; + cmt_ident_occurrences; + } in + output_cmt oc cmt) + end; + clear () diff --git a/upstream/ocaml_503/file_formats/cmt_format.mli b/upstream/ocaml_503/file_formats/cmt_format.mli new file mode 100644 index 000000000..d27f56bcc --- /dev/null +++ b/upstream/ocaml_503/file_formats/cmt_format.mli @@ -0,0 +1,125 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** cmt and cmti files format. *) + +open Misc + +(** The layout of a cmt file is as follows: + := \{\} \{cmt infos\} \{\} + where is the cmi file format: + := . + More precisely, the optional part must be present if and only if + the file is: + - a cmti, or + - a cmt, for a ml file which has no corresponding mli (hence no + corresponding cmti). + + Thus, we provide a common reading function for cmi and cmt(i) + files which returns an option for each of the three parts: cmi + info, cmt info, source info. *) + +open Typedtree + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : modname; + cmt_annots : binary_annots; + cmt_value_dependencies : + (Types.value_description * Types.value_description) list; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : Load_path.paths; + cmt_source_digest : string option; + cmt_initial_env : Env.t; + cmt_imports : crcs; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list +} + +type error = + Not_a_typedtree of string + +exception Error of error + +(** [read filename] opens filename, and extract both the cmi_infos, if + it exists, and the cmt_infos, if it exists. Thus, it can be used + with .cmi, .cmt and .cmti files. + + .cmti files always contain a cmi_infos at the beginning. .cmt files + only contain a cmi_infos at the beginning if there is no associated + .cmti file. +*) +val read : string -> Cmi_format.cmi_infos option * cmt_infos option + +val read_cmt : string -> cmt_infos +val read_cmi : string -> Cmi_format.cmi_infos + +(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] + writes a cmt(i) file. *) +val save_cmt : + Unit_info.Artifact.t -> + binary_annots -> + Env.t -> (* initial env *) + Cmi_format.cmi_infos option -> (* if a .cmi was generated *) + Shape.t option -> + unit + +(* Miscellaneous functions *) + +val read_magic_number : in_channel -> string + +val clear: unit -> unit + +val add_saved_type : binary_part -> unit +val get_saved_types : unit -> binary_part list +val set_saved_types : binary_part list -> unit + +val record_value_dependency: + Types.value_description -> Types.value_description -> unit + +(* + + val is_magic_number : string -> bool + val read : in_channel -> Env.cmi_infos option * t + val write_magic_number : out_channel -> unit + val write : out_channel -> t -> unit + + val find : string list -> string -> string + val read_signature : 'a -> string -> Types.signature * 'b list * 'c list + +*) diff --git a/upstream/ocaml_503/parsing/ast_helper.ml b/upstream/ocaml_503/parsing/ast_helper.ml new file mode 100644 index 000000000..daa73c420 --- /dev/null +++ b/upstream/ocaml_503/parsing/ast_helper.ml @@ -0,0 +1,653 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers to produce Parsetree fragments *) + +open Asttypes +open Parsetree +open Docstrings + +type 'a with_loc = 'a Location.loc +type loc = Location.t + +type lid = Longident.t with_loc +type str = string with_loc +type str_opt = string option with_loc +type attrs = attribute list + +let default_loc = ref Location.none + +let with_default_loc l f = + Misc.protect_refs [Misc.R (default_loc, l)] f + +module Const = struct + let mk ?(loc = !default_loc) d = + {pconst_desc = d; + pconst_loc = loc} + + let integer ?loc ?suffix i = mk ?loc (Pconst_integer (i, suffix)) + let int ?loc ?suffix i = integer ?loc ?suffix (Int.to_string i) + let int32 ?loc ?(suffix='l') i = integer ?loc ~suffix (Int32.to_string i) + let int64 ?loc ?(suffix='L') i = integer ?loc ~suffix (Int64.to_string i) + let nativeint ?loc ?(suffix='n') i = + integer ?loc ~suffix (Nativeint.to_string i) + let float ?loc ?suffix f = mk ?loc (Pconst_float (f, suffix)) + let char ?loc c = mk ?loc (Pconst_char c) + let string ?quotation_delimiter ?(loc= !default_loc) s = + mk ~loc (Pconst_string (s, loc, quotation_delimiter)) +end + +module Attr = struct + let mk ?(loc= !default_loc) name payload = + { attr_name = name; + attr_payload = payload; + attr_loc = loc } +end + +module Typ = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ptyp_desc = d; + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = attrs} + + let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) + let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) + let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) + let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) + let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) + let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) + let open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t)) + + let force_poly t = + match t.ptyp_desc with + | Ptyp_poly _ -> t + | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) + + let varify_constructors var_names t = + let check_variable vl loc v = + if List.mem v vl then + raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in + let var_names = List.map (fun v -> v.txt) var_names in + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> + check_variable var_names t.ptyp_loc x; + Ptyp_var x + | Ptyp_arrow (label,core_type,core_type') -> + Ptyp_arrow(label, loop core_type, loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr( { txt = Longident.Lident s }, []) + when List.mem s var_names -> + Ptyp_var s + | Ptyp_constr(longident, lst) -> + Ptyp_constr(longident, List.map loop lst) + | Ptyp_object (lst, o) -> + Ptyp_object (List.map loop_object_field lst, o) + | Ptyp_class (longident, lst) -> + Ptyp_class (longident, List.map loop lst) + | Ptyp_alias(core_type, alias) -> + check_variable var_names alias.loc alias.txt; + Ptyp_alias(loop core_type, alias) + | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> + Ptyp_variant(List.map loop_row_field row_field_list, + flag, lbl_lst_option) + | Ptyp_poly(string_lst, core_type) -> + List.iter (fun v -> + check_variable var_names t.ptyp_loc v.txt) string_lst; + Ptyp_poly(string_lst, loop core_type) + | Ptyp_package(longident,lst) -> + Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + | Ptyp_open (mod_ident, core_type) -> + Ptyp_open (mod_ident, loop core_type) + | Ptyp_extension (s, arg) -> + Ptyp_extension (s, arg) + in + {t with ptyp_desc = desc} + and loop_row_field field = + let prf_desc = match field.prf_desc with + | Rtag(label,flag,lst) -> + Rtag(label,flag,List.map loop lst) + | Rinherit t -> + Rinherit (loop t) + in + { field with prf_desc; } + and loop_object_field field = + let pof_desc = match field.pof_desc with + | Otag(label, t) -> + Otag(label, loop t) + | Oinherit t -> + Oinherit (loop t) + in + { field with pof_desc; } + in + loop t + +end + +module Pat = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ppat_desc = d; + ppat_loc = loc; + ppat_loc_stack = []; + ppat_attributes = attrs} + let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) + let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) + let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) + let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) + let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) + let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) + let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) + let effect_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_effect(a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) +end + +module Exp = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pexp_desc = d; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = attrs} + let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) + let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) + let function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c)) + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) + let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) + let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) + let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) + let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) + let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) + let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) + let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) + let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) + let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) + let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) + let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) + let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) + let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) + let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) + let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) + let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) + let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) + let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) + let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) + let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) + let letop ?loc ?attrs let_ ands body = + mk ?loc ?attrs (Pexp_letop {let_; ands; body}) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) + let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable + + let case lhs ?guard rhs = + { + pc_lhs = lhs; + pc_guard = guard; + pc_rhs = rhs; + } + + let binding_op op pat exp loc = + { + pbop_op = op; + pbop_pat = pat; + pbop_exp = exp; + pbop_loc = loc; + } +end + +module Mty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} + let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) + let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) + let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) + let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) + let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) + let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) +end + +module Mod = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} + let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} + + let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) + let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) + let functor_ ?loc ?attrs arg body = + mk ?loc ?attrs (Pmod_functor (arg, body)) + let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) + let apply_unit ?loc ?attrs m1 = mk ?loc ?attrs (Pmod_apply_unit m1) + let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) + let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) +end + +module Sig = struct + let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} + + let value ?loc a = mk ?loc (Psig_value a) + let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) + let type_subst ?loc a = mk ?loc (Psig_typesubst a) + let type_extension ?loc a = mk ?loc (Psig_typext a) + let exception_ ?loc a = mk ?loc (Psig_exception a) + let module_ ?loc a = mk ?loc (Psig_module a) + let mod_subst ?loc a = mk ?loc (Psig_modsubst a) + let rec_module ?loc a = mk ?loc (Psig_recmodule a) + let modtype ?loc a = mk ?loc (Psig_modtype a) + let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a) + let open_ ?loc a = mk ?loc (Psig_open a) + let include_ ?loc a = mk ?loc (Psig_include a) + let class_ ?loc a = mk ?loc (Psig_class a) + let class_type ?loc a = mk ?loc (Psig_class_type a) + let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Psig_attribute a) + let text txt = + let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + f_txt +end + +module Str = struct + let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} + + let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) + let value ?loc a b = mk ?loc (Pstr_value (a, b)) + let primitive ?loc a = mk ?loc (Pstr_primitive a) + let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) + let type_extension ?loc a = mk ?loc (Pstr_typext a) + let exception_ ?loc a = mk ?loc (Pstr_exception a) + let module_ ?loc a = mk ?loc (Pstr_module a) + let rec_module ?loc a = mk ?loc (Pstr_recmodule a) + let modtype ?loc a = mk ?loc (Pstr_modtype a) + let open_ ?loc a = mk ?loc (Pstr_open a) + let class_ ?loc a = mk ?loc (Pstr_class a) + let class_type ?loc a = mk ?loc (Pstr_class_type a) + let include_ ?loc a = mk ?loc (Pstr_include a) + let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Pstr_attribute a) + let text txt = + let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + f_txt +end + +module Cl = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { + pcl_desc = d; + pcl_loc = loc; + pcl_attributes = attrs; + } + let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} + + let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) + let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) + let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) +end + +module Cty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { + pcty_desc = d; + pcty_loc = loc; + pcty_attributes = attrs; + } + let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} + + let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) + let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) +end + +module Ctf = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) d = + { + pctf_desc = d; + pctf_loc = loc; + pctf_attributes = add_docs_attrs docs attrs; + } + + let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) + let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) + let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) + let attribute ?loc a = mk ?loc (Pctf_attribute a) + let text txt = + let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + f_txt + + let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} + +end + +module Cf = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) d = + { + pcf_desc = d; + pcf_loc = loc; + pcf_attributes = add_docs_attrs docs attrs; + } + + let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) + let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) + let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) + let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) + let attribute ?loc a = mk ?loc (Pcf_attribute a) + let text txt = + let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + f_txt + + let virtual_ ct = Cfk_virtual ct + let concrete o e = Cfk_concrete (o, e) + + let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} + +end + +module Val = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(prim = []) name typ = + { + pval_name = name; + pval_type = typ; + pval_attributes = add_docs_attrs docs attrs; + pval_loc = loc; + pval_prim = prim; + } +end + +module Md = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name typ = + { + pmd_name = name; + pmd_type = typ; + pmd_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pmd_loc = loc; + } +end + +module Ms = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name syn = + { + pms_name = name; + pms_manifest = syn; + pms_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pms_loc = loc; + } +end + +module Mtd = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) ?typ name = + { + pmtd_name = name; + pmtd_type = typ; + pmtd_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pmtd_loc = loc; + } +end + +module Mb = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name expr = + { + pmb_name = name; + pmb_expr = expr; + pmb_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pmb_loc = loc; + } +end + +module Opn = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(override = Fresh) expr = + { + popen_expr = expr; + popen_override = override; + popen_loc = loc; + popen_attributes = add_docs_attrs docs attrs; + } +end + +module Incl = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = + { + pincl_mod = mexpr; + pincl_loc = loc; + pincl_attributes = add_docs_attrs docs attrs; + } + +end + +module Vb = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(text = []) ?value_constraint pat expr = + { + pvb_pat = pat; + pvb_expr = expr; + pvb_constraint=value_constraint; + pvb_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pvb_loc = loc; + } +end + +module Ci = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) + ?(virt = Concrete) ?(params = []) name expr = + { + pci_virt = virt; + pci_params = params; + pci_name = name; + pci_expr = expr; + pci_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pci_loc = loc; + } +end + +module Type = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) + ?(params = []) + ?(cstrs = []) + ?(kind = Ptype_abstract) + ?(priv = Public) + ?manifest + name = + { + ptype_name = name; + ptype_params = params; + ptype_cstrs = cstrs; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = manifest; + ptype_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + ptype_loc = loc; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) + ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pcd_name = name; + pcd_vars = vars; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = add_info_attrs info attrs; + } + + let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) + ?(mut = Immutable) name typ = + { + pld_name = name; + pld_mutable = mut; + pld_type = typ; + pld_loc = loc; + pld_attributes = add_info_attrs info attrs; + } + +end + +(** Type extensions *) +module Te = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(params = []) ?(priv = Public) path constructors = + { + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_loc = loc; + ptyext_attributes = add_docs_attrs docs attrs; + } + + let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + constructor = + { + ptyexn_constructor = constructor; + ptyexn_loc = loc; + ptyexn_attributes = add_docs_attrs docs attrs; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) name kind = + { + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + } + + let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(info = empty_info) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pext_name = name; + pext_kind = Pext_decl(vars, args, res); + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + } + + let rebind ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) name lid = + { + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + } +end + +module Csig = struct + let mk self fields = + { + pcsig_self = self; + pcsig_fields = fields; + } +end + +module Cstr = struct + let mk self fields = + { + pcstr_self = self; + pcstr_fields = fields; + } +end + +(** Row fields *) +module Rf = struct + let mk ?(loc = !default_loc) ?(attrs = []) desc = { + prf_desc = desc; + prf_loc = loc; + prf_attributes = attrs; + } + let tag ?loc ?attrs label const tys = + mk ?loc ?attrs (Rtag (label, const, tys)) + let inherit_?loc ty = + mk ?loc (Rinherit ty) +end + +(** Object fields *) +module Of = struct + let mk ?(loc = !default_loc) ?(attrs=[]) desc = { + pof_desc = desc; + pof_loc = loc; + pof_attributes = attrs; + } + let tag ?loc ?attrs label ty = + mk ?loc ?attrs (Otag (label, ty)) + let inherit_ ?loc ty = + mk ?loc (Oinherit ty) +end diff --git a/upstream/ocaml_503/parsing/ast_helper.mli b/upstream/ocaml_503/parsing/ast_helper.mli new file mode 100644 index 000000000..6a8a0fa36 --- /dev/null +++ b/upstream/ocaml_503/parsing/ast_helper.mli @@ -0,0 +1,501 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers to produce Parsetree fragments + + {b Warning} This module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Asttypes +open Docstrings +open Parsetree + +type 'a with_loc = 'a Location.loc +type loc = Location.t + +type lid = Longident.t with_loc +type str = string with_loc +type str_opt = string option with_loc +type attrs = attribute list + +(** {1 Default locations} *) + +val default_loc: loc ref + (** Default value for all optional location arguments. *) + +val with_default_loc: loc -> (unit -> 'a) -> 'a + (** Set the [default_loc] within the scope of the execution + of the provided function. *) + +(** {1 Constants} *) + +module Const : sig + val mk : ?loc:loc -> constant_desc -> constant + val char : ?loc:loc -> char -> constant + val string : + ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant + val integer : ?loc:loc -> ?suffix:char -> string -> constant + val int : ?loc:loc -> ?suffix:char -> int -> constant + val int32 : ?loc:loc -> ?suffix:char -> int32 -> constant + val int64 : ?loc:loc -> ?suffix:char -> int64 -> constant + val nativeint : ?loc:loc -> ?suffix:char -> nativeint -> constant + val float : ?loc:loc -> ?suffix:char -> string -> constant +end + +(** {1 Attributes} *) +module Attr : sig + val mk: ?loc:loc -> str -> payload -> attribute +end + +(** {1 Core language} *) + +(** Type expressions *) +module Typ : + sig + val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type + val attr: core_type -> attribute -> core_type + + val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type + val var: ?loc:loc -> ?attrs:attrs -> string -> core_type + val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type + -> core_type + val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type + val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + val object_: ?loc:loc -> ?attrs:attrs -> object_field list + -> closed_flag -> core_type + val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string with_loc + -> core_type + val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag + -> label list option -> core_type + val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type + val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list + -> core_type + val open_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type -> core_type + val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type + + val force_poly: core_type -> core_type + + val varify_constructors: str list -> core_type -> core_type + (** [varify_constructors newtypes te] is type expression [te], of which + any of nullary type constructor [tc] is replaced by type variable of + the same name, if [tc]'s name appears in [newtypes]. + Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] + appears in [newtypes]. + @since 4.05 + *) + end + +(** Patterns *) +module Pat: + sig + val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern + val attr:pattern -> attribute -> pattern + + val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern + val var: ?loc:loc -> ?attrs:attrs -> str -> pattern + val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern + val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern + val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern + val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val construct: ?loc:loc -> ?attrs:attrs -> + lid -> (str list * pattern) option -> pattern + val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern + val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag + -> pattern + val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern + val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern + val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern + val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern + val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern + val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern + val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern + val effect_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern + val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern + end + +(** Expressions *) +module Exp: + sig + val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression + val attr: expression -> attribute -> expression + + val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression + val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression + val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list + -> expression -> expression + val function_ : ?loc:loc -> ?attrs:attrs -> function_param list + -> type_constraint option -> function_body + -> expression + val apply: ?loc:loc -> ?attrs:attrs -> expression + -> (arg_label * expression) list -> expression + val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list + -> expression + val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression + val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option + -> expression + val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option + -> expression + val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list + -> expression option -> expression + val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + -> expression + val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression + val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression option -> expression + val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression + val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression + val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression + -> direction_flag -> expression -> expression + val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option + -> core_type -> expression + val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type + -> expression + val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression + val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list + -> expression + val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr + -> expression -> expression + val letexception: + ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression + -> expression + val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression + val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression + val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option + -> expression + val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression + val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression + val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression + -> expression + val letop: ?loc:loc -> ?attrs:attrs -> binding_op + -> binding_op list -> expression -> expression + val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression + val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression + + val case: pattern -> ?guard:expression -> expression -> case + val binding_op: str -> pattern -> expression -> loc -> binding_op + end + +(** Value declarations *) +module Val: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + ?prim:string list -> str -> core_type -> value_description + end + +(** Type declarations *) +module Type: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?params:(core_type * (variance * injectivity)) list -> + ?cstrs:(core_type * core_type * loc) list -> + ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> + type_declaration + + val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> + ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> + str -> + constructor_declaration + val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> + ?mut:mutable_flag -> str -> core_type -> label_declaration + end + +(** Type extensions *) +module Te: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + ?params:(core_type * (variance * injectivity)) list -> + ?priv:private_flag -> lid -> extension_constructor list -> type_extension + + val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + extension_constructor -> type_exception + + val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + str -> extension_constructor_kind -> extension_constructor + + val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> + str -> + extension_constructor + val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + str -> lid -> extension_constructor + end + +(** {1 Module language} *) + +(** Module type expressions *) +module Mty: + sig + val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type + val attr: module_type -> attribute -> module_type + + val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type + val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type + val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type + val functor_: ?loc:loc -> ?attrs:attrs -> + functor_parameter -> module_type -> module_type + val with_: ?loc:loc -> ?attrs:attrs -> module_type -> + with_constraint list -> module_type + val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type + val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type + end + +(** Module expressions *) +module Mod: + sig + val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr + val attr: module_expr -> attribute -> module_expr + + val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr + val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr + val functor_: ?loc:loc -> ?attrs:attrs -> + functor_parameter -> module_expr -> module_expr + val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> + module_expr + val apply_unit: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr + val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> + module_expr + val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr + val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr + end + +(** Signature items *) +module Sig: + sig + val mk: ?loc:loc -> signature_item_desc -> signature_item + + val value: ?loc:loc -> value_description -> signature_item + val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item + val type_subst: ?loc:loc -> type_declaration list -> signature_item + val type_extension: ?loc:loc -> type_extension -> signature_item + val exception_: ?loc:loc -> type_exception -> signature_item + val module_: ?loc:loc -> module_declaration -> signature_item + val mod_subst: ?loc:loc -> module_substitution -> signature_item + val rec_module: ?loc:loc -> module_declaration list -> signature_item + val modtype: ?loc:loc -> module_type_declaration -> signature_item + val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item + val open_: ?loc:loc -> open_description -> signature_item + val include_: ?loc:loc -> include_description -> signature_item + val class_: ?loc:loc -> class_description list -> signature_item + val class_type: ?loc:loc -> class_type_declaration list -> signature_item + val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item + val attribute: ?loc:loc -> attribute -> signature_item + val text: text -> signature_item list + end + +(** Structure items *) +module Str: + sig + val mk: ?loc:loc -> structure_item_desc -> structure_item + + val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item + val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item + val primitive: ?loc:loc -> value_description -> structure_item + val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item + val type_extension: ?loc:loc -> type_extension -> structure_item + val exception_: ?loc:loc -> type_exception -> structure_item + val module_: ?loc:loc -> module_binding -> structure_item + val rec_module: ?loc:loc -> module_binding list -> structure_item + val modtype: ?loc:loc -> module_type_declaration -> structure_item + val open_: ?loc:loc -> open_declaration -> structure_item + val class_: ?loc:loc -> class_declaration list -> structure_item + val class_type: ?loc:loc -> class_type_declaration list -> structure_item + val include_: ?loc:loc -> include_declaration -> structure_item + val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item + val attribute: ?loc:loc -> attribute -> structure_item + val text: text -> structure_item list + end + +(** Module declarations *) +module Md: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str_opt -> module_type -> module_declaration + end + +(** Module substitutions *) +module Ms: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str -> lid -> module_substitution + end + +(** Module type declarations *) +module Mtd: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?typ:module_type -> str -> module_type_declaration + end + +(** Module bindings *) +module Mb: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str_opt -> module_expr -> module_binding + end + +(** Opens *) +module Opn: + sig + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> + ?override:override_flag -> 'a -> 'a open_infos + end + +(** Includes *) +module Incl: + sig + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos + end + +(** Value bindings *) +module Vb: + sig + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?value_constraint:value_constraint -> pattern -> expression -> + value_binding + end + + +(** {1 Class language} *) + +(** Class type expressions *) +module Cty: + sig + val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type + val attr: class_type -> attribute -> class_type + + val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type + val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type + val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> + class_type -> class_type + val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type + val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type + -> class_type + end + +(** Class type fields *) +module Ctf: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + class_type_field_desc -> class_type_field + val attr: class_type_field -> attribute -> class_type_field + + val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field + val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> + virtual_flag -> core_type -> class_type_field + val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> + virtual_flag -> core_type -> class_type_field + val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> + class_type_field + val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field + val attribute: ?loc:loc -> attribute -> class_type_field + val text: text -> class_type_field list + end + +(** Class expressions *) +module Cl: + sig + val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr + val attr: class_expr -> attribute -> class_expr + + val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr + val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr + val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> + pattern -> class_expr -> class_expr + val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> + (arg_label * expression) list -> class_expr + val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> + class_expr -> class_expr + val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> + class_expr + val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr + val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr + -> class_expr + end + +(** Class fields *) +module Cf: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> + class_field + val attr: class_field -> attribute -> class_field + + val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> + str option -> class_field + val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> + class_field_kind -> class_field + val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> + class_field_kind -> class_field + val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> + class_field + val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field + val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field + val attribute: ?loc:loc -> attribute -> class_field + val text: text -> class_field list + + val virtual_: core_type -> class_field_kind + val concrete: override_flag -> expression -> class_field_kind + + end + +(** Classes *) +module Ci: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?virt:virtual_flag -> + ?params:(core_type * (variance * injectivity)) list -> + str -> 'a -> 'a class_infos + end + +(** Class signatures *) +module Csig: + sig + val mk: core_type -> class_type_field list -> class_signature + end + +(** Class structures *) +module Cstr: + sig + val mk: pattern -> class_field list -> class_structure + end + +(** Row fields *) +module Rf: + sig + val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field + val tag: ?loc:loc -> ?attrs:attrs -> + label with_loc -> bool -> core_type list -> row_field + val inherit_: ?loc:loc -> core_type -> row_field + end + +(** Object fields *) +module Of: + sig + val mk: ?loc:loc -> ?attrs:attrs -> + object_field_desc -> object_field + val tag: ?loc:loc -> ?attrs:attrs -> + label with_loc -> core_type -> object_field + val inherit_: ?loc:loc -> core_type -> object_field + end diff --git a/upstream/ocaml_503/parsing/ast_invariants.ml b/upstream/ocaml_503/parsing/ast_invariants.ml new file mode 100644 index 000000000..53e8a1629 --- /dev/null +++ b/upstream/ocaml_503/parsing/ast_invariants.ml @@ -0,0 +1,213 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Parsetree +open Ast_iterator + +let err = Syntaxerr.ill_formed_ast + +let empty_record loc = err loc "Records cannot be empty." +let invalid_tuple loc = err loc "Tuples must have at least 2 components." +let no_args loc = err loc "Function application with no argument." +let empty_let loc = err loc "Let with no bindings." +let empty_type loc = err loc "Type declarations cannot be empty." +let empty_poly_binder loc = + err loc "Explicit universal type quantification cannot be empty." +let complex_id loc = err loc "Functor application not allowed here." +let module_type_substitution_missing_rhs loc = + err loc "Module type substitution with no right hand side" +let function_without_value_parameters loc = + err loc "Function without any value parameters" + +let simple_longident id = + let rec is_simple = function + | Longident.Lident _ -> true + | Longident.Ldot (id, _) -> is_simple id + | Longident.Lapply _ -> false + in + if not (is_simple id.txt) then complex_id id.loc + +let iterator = + let super = Ast_iterator.default_iterator in + let type_declaration self td = + super.type_declaration self td; + let loc = td.ptype_loc in + match td.ptype_kind with + | Ptype_record [] -> empty_record loc + | _ -> () + in + let typ self ty = + super.typ self ty; + let loc = ty.ptyp_loc in + match ty.ptyp_desc with + | Ptyp_tuple ([] | [_]) -> invalid_tuple loc + | Ptyp_package (_, cstrs) -> + List.iter (fun (id, _) -> simple_longident id) cstrs + | Ptyp_poly([],_) -> empty_poly_binder loc + | _ -> () + in + let pat self pat = + begin match pat.ppat_desc with + | Ppat_construct (_, Some (_, ({ppat_desc = Ppat_tuple _} as p))) + when Builtin_attributes.explicit_arity pat.ppat_attributes -> + super.pat self p (* allow unary tuple, see GPR#523. *) + | _ -> + super.pat self pat + end; + let loc = pat.ppat_loc in + match pat.ppat_desc with + | Ppat_tuple ([] | [_]) -> invalid_tuple loc + | Ppat_record ([], _) -> empty_record loc + | Ppat_construct (id, _) -> simple_longident id + | Ppat_record (fields, _) -> + List.iter (fun (id, _) -> simple_longident id) fields + | _ -> () + in + let expr self exp = + begin match exp.pexp_desc with + | Pexp_construct (_, Some ({pexp_desc = Pexp_tuple _} as e)) + when Builtin_attributes.explicit_arity exp.pexp_attributes -> + super.expr self e (* allow unary tuple, see GPR#523. *) + | _ -> + super.expr self exp + end; + let loc = exp.pexp_loc in + match exp.pexp_desc with + | Pexp_tuple ([] | [_]) -> invalid_tuple loc + | Pexp_record ([], _) -> empty_record loc + | Pexp_apply (_, []) -> no_args loc + | Pexp_let (_, [], _) -> empty_let loc + | Pexp_ident id + | Pexp_construct (id, _) + | Pexp_field (_, id) + | Pexp_setfield (_, id, _) + | Pexp_new id -> simple_longident id + | Pexp_record (fields, _) -> + List.iter (fun (id, _) -> simple_longident id) fields + | Pexp_function (params, _, Pfunction_body _) -> + if + List.for_all + (function + | { pparam_desc = Pparam_newtype _ } -> true + | { pparam_desc = Pparam_val _ } -> false) + params + then function_without_value_parameters loc + | _ -> () + in + let extension_constructor self ec = + super.extension_constructor self ec; + match ec.pext_kind with + | Pext_rebind id -> simple_longident id + | _ -> () + in + let class_expr self ce = + super.class_expr self ce; + let loc = ce.pcl_loc in + match ce.pcl_desc with + | Pcl_apply (_, []) -> no_args loc + | Pcl_constr (id, _) -> simple_longident id + | _ -> () + in + let module_type self mty = + super.module_type self mty; + match mty.pmty_desc with + | Pmty_alias id -> simple_longident id + | _ -> () + in + let open_description self opn = + super.open_description self opn + in + let with_constraint self wc = + super.with_constraint self wc; + match wc with + | Pwith_type (id, _) + | Pwith_module (id, _) -> simple_longident id + | _ -> () + in + let module_expr self me = + super.module_expr self me; + match me.pmod_desc with + | Pmod_ident id -> simple_longident id + | _ -> () + in + let structure_item self st = + super.structure_item self st; + let loc = st.pstr_loc in + match st.pstr_desc with + | Pstr_type (_, []) -> empty_type loc + | Pstr_value (_, []) -> empty_let loc + | _ -> () + in + let signature_item self sg = + super.signature_item self sg; + let loc = sg.psig_loc in + match sg.psig_desc with + | Psig_type (_, []) -> empty_type loc + | Psig_modtypesubst {pmtd_type=None; _ } -> + module_type_substitution_missing_rhs loc + | _ -> () + in + let row_field self field = + super.row_field self field; + let loc = field.prf_loc in + match field.prf_desc with + | Rtag _ -> () + | Rinherit _ -> + if field.prf_attributes = [] + then () + else err loc + "In variant types, attaching attributes to inherited \ + subtypes is not allowed." + in + let object_field self field = + super.object_field self field; + let loc = field.pof_loc in + match field.pof_desc with + | Otag _ -> () + | Oinherit _ -> + if field.pof_attributes = [] + then () + else err loc + "In object types, attaching attributes to inherited \ + subtypes is not allowed." + in + let attribute self attr = + (* The change to `self` here avoids registering attributes within attributes + for the purposes of warning 53, while keeping all the other invariant + checks for attribute payloads. See comment on [current_phase] in + [builtin_attributes.mli]. *) + super.attribute { self with attribute = super.attribute } attr; + Builtin_attributes.(register_attr Invariant_check attr.attr_name) + in + { super with + type_declaration + ; typ + ; pat + ; expr + ; extension_constructor + ; class_expr + ; module_expr + ; module_type + ; open_description + ; with_constraint + ; structure_item + ; signature_item + ; row_field + ; object_field + ; attribute + } + +let structure st = iterator.structure iterator st +let signature sg = iterator.signature iterator sg diff --git a/upstream/ocaml_503/parsing/ast_invariants.mli b/upstream/ocaml_503/parsing/ast_invariants.mli new file mode 100644 index 000000000..fdb56aa5e --- /dev/null +++ b/upstream/ocaml_503/parsing/ast_invariants.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Check AST invariants + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +val structure : Parsetree.structure -> unit +val signature : Parsetree.signature -> unit diff --git a/upstream/ocaml_503/parsing/ast_iterator.ml b/upstream/ocaml_503/parsing/ast_iterator.ml new file mode 100644 index 000000000..389a9a404 --- /dev/null +++ b/upstream/ocaml_503/parsing/ast_iterator.ml @@ -0,0 +1,747 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@ocaml.warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + + +open Parsetree +open Location + +type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attribute list -> unit; + binding_op: iterator -> binding_op -> unit; + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + constructor_declaration: iterator -> constructor_declaration -> unit; + directive_argument: iterator -> directive_argument -> unit; + expr: iterator -> expression -> unit; + extension: iterator -> extension -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + include_declaration: iterator -> include_declaration -> unit; + include_description: iterator -> include_description -> unit; + label_declaration: iterator -> label_declaration -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + pat: iterator -> pattern -> unit; + payload: iterator -> payload -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + toplevel_directive: iterator -> toplevel_directive -> unit; + toplevel_phrase: iterator -> toplevel_phrase -> unit; + typ: iterator -> core_type -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} +(** A [iterator] record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the iterator to be applied to children in the syntax + tree. *) + +let iter_fst f (x, _) = f x +let iter_snd f (_, y) = f y +let iter_tuple f1 f2 (x, y) = f1 x; f2 y +let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z +let iter_opt f = function None -> () | Some x -> f x + +let iter_loc sub {loc; txt = _} = sub.location sub loc + +module T = struct + (* Type expressions for the core language *) + + let row_field sub { + prf_desc; + prf_loc; + prf_attributes; + } = + sub.location sub prf_loc; + sub.attributes sub prf_attributes; + match prf_desc with + | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl + | Rinherit t -> sub.typ sub t + + let object_field sub { + pof_desc; + pof_loc; + pof_attributes; + } = + sub.location sub pof_loc; + sub.attributes sub pof_attributes; + match pof_desc with + | Otag (_, t) -> sub.typ sub t + | Oinherit t -> sub.typ sub t + + let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Ptyp_any + | Ptyp_var _ -> () + | Ptyp_arrow (_lab, t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl + | Ptyp_constr (lid, tl) -> + iter_loc sub lid; List.iter (sub.typ sub) tl + | Ptyp_object (ol, _o) -> + List.iter (object_field sub) ol + | Ptyp_class (lid, tl) -> + iter_loc sub lid; List.iter (sub.typ sub) tl + | Ptyp_alias (t, _) -> sub.typ sub t + | Ptyp_variant (rl, _b, _ll) -> + List.iter (row_field sub) rl + | Ptyp_poly (_, t) -> sub.typ sub t + | Ptyp_package (lid, l) -> + iter_loc sub lid; + List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l + | Ptyp_open (mod_ident, t) -> + iter_loc sub mod_ident; + sub.typ sub t + | Ptyp_extension x -> sub.extension sub x + + let iter_type_declaration sub + {ptype_name; ptype_params; ptype_cstrs; + ptype_kind; + ptype_private = _; + ptype_manifest; + ptype_attributes; + ptype_loc} = + iter_loc sub ptype_name; + List.iter (iter_fst (sub.typ sub)) ptype_params; + List.iter + (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs; + sub.type_kind sub ptype_kind; + iter_opt (sub.typ sub) ptype_manifest; + sub.location sub ptype_loc; + sub.attributes sub ptype_attributes + + let iter_type_kind sub = function + | Ptype_abstract -> () + | Ptype_variant l -> + List.iter (sub.constructor_declaration sub) l + | Ptype_record l -> List.iter (sub.label_declaration sub) l + | Ptype_open -> () + + let iter_constructor_arguments sub = function + | Pcstr_tuple l -> List.iter (sub.typ sub) l + | Pcstr_record l -> + List.iter (sub.label_declaration sub) l + + let iter_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private = _; + ptyext_loc; + ptyext_attributes} = + iter_loc sub ptyext_path; + List.iter (sub.extension_constructor sub) ptyext_constructors; + List.iter (iter_fst (sub.typ sub)) ptyext_params; + sub.location sub ptyext_loc; + sub.attributes sub ptyext_attributes + + let iter_type_exception sub + {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = + sub.extension_constructor sub ptyexn_constructor; + sub.location sub ptyexn_loc; + sub.attributes sub ptyexn_attributes + + let iter_extension_constructor_kind sub = function + Pext_decl(vars, ctl, cto) -> + List.iter (iter_loc sub) vars; + iter_constructor_arguments sub ctl; + iter_opt (sub.typ sub) cto + | Pext_rebind li -> + iter_loc sub li + + let iter_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + iter_loc sub pext_name; + iter_extension_constructor_kind sub pext_kind; + sub.location sub pext_loc; + sub.attributes sub pext_attributes + +end + +module CT = struct + (* Type expressions for the class language *) + + let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcty_constr (lid, tys) -> + iter_loc sub lid; List.iter (sub.typ sub) tys + | Pcty_signature x -> sub.class_signature sub x + | Pcty_arrow (_lab, t, ct) -> + sub.typ sub t; sub.class_type sub ct + | Pcty_extension x -> sub.extension sub x + | Pcty_open (o, e) -> + sub.open_description sub o; sub.class_type sub e + + let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} + = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pctf_inherit ct -> sub.class_type sub ct + | Pctf_val (_s, _m, _v, t) -> sub.typ sub t + | Pctf_method (_s, _p, _v, t) -> sub.typ sub t + | Pctf_constraint (t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Pctf_attribute x -> sub.attribute sub x + | Pctf_extension x -> sub.extension sub x + + let iter_signature sub {pcsig_self; pcsig_fields} = + sub.typ sub pcsig_self; + List.iter (sub.class_type_field sub) pcsig_fields +end + +let iter_functor_param sub = function + | Unit -> () + | Named (name, mty) -> + iter_loc sub name; + sub.module_type sub mty + +module MT = struct + (* Type expressions for the module language *) + + let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pmty_ident s -> iter_loc sub s + | Pmty_alias s -> iter_loc sub s + | Pmty_signature sg -> sub.signature sub sg + | Pmty_functor (param, mt2) -> + iter_functor_param sub param; + sub.module_type sub mt2 + | Pmty_with (mt, l) -> + sub.module_type sub mt; + List.iter (sub.with_constraint sub) l + | Pmty_typeof me -> sub.module_expr sub me + | Pmty_extension x -> sub.extension sub x + + let iter_with_constraint sub = function + | Pwith_type (lid, d) -> + iter_loc sub lid; sub.type_declaration sub d + | Pwith_module (lid, lid2) -> + iter_loc sub lid; iter_loc sub lid2 + | Pwith_modtype (lid, mty) -> + iter_loc sub lid; sub.module_type sub mty + | Pwith_typesubst (lid, d) -> + iter_loc sub lid; sub.type_declaration sub d + | Pwith_modsubst (s, lid) -> + iter_loc sub s; iter_loc sub lid + | Pwith_modtypesubst (lid, mty) -> + iter_loc sub lid; sub.module_type sub mty + + let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = + sub.location sub loc; + match desc with + | Psig_value vd -> sub.value_description sub vd + | Psig_type (_, l) + | Psig_typesubst l -> + List.iter (sub.type_declaration sub) l + | Psig_typext te -> sub.type_extension sub te + | Psig_exception ed -> sub.type_exception sub ed + | Psig_module x -> sub.module_declaration sub x + | Psig_modsubst x -> sub.module_substitution sub x + | Psig_recmodule l -> + List.iter (sub.module_declaration sub) l + | Psig_modtype x | Psig_modtypesubst x -> sub.module_type_declaration sub x + | Psig_open x -> sub.open_description sub x + | Psig_include x -> sub.include_description sub x + | Psig_class l -> List.iter (sub.class_description sub) l + | Psig_class_type l -> + List.iter (sub.class_type_declaration sub) l + | Psig_extension (x, attrs) -> + sub.attributes sub attrs; + sub.extension sub x + | Psig_attribute x -> sub.attribute sub x +end + + +module M = struct + (* Value expressions for the module language *) + + let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pmod_ident x -> iter_loc sub x + | Pmod_structure str -> sub.structure sub str + | Pmod_functor (param, body) -> + iter_functor_param sub param; + sub.module_expr sub body + | Pmod_apply (m1, m2) -> + sub.module_expr sub m1; + sub.module_expr sub m2 + | Pmod_apply_unit m1 -> + sub.module_expr sub m1 + | Pmod_constraint (m, mty) -> + sub.module_expr sub m; sub.module_type sub mty + | Pmod_unpack e -> sub.expr sub e + | Pmod_extension x -> sub.extension sub x + + let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + sub.location sub loc; + match desc with + | Pstr_eval (x, attrs) -> + sub.attributes sub attrs; sub.expr sub x + | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs + | Pstr_primitive vd -> sub.value_description sub vd + | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l + | Pstr_typext te -> sub.type_extension sub te + | Pstr_exception ed -> sub.type_exception sub ed + | Pstr_module x -> sub.module_binding sub x + | Pstr_recmodule l -> List.iter (sub.module_binding sub) l + | Pstr_modtype x -> sub.module_type_declaration sub x + | Pstr_open x -> sub.open_declaration sub x + | Pstr_class l -> List.iter (sub.class_declaration sub) l + | Pstr_class_type l -> + List.iter (sub.class_type_declaration sub) l + | Pstr_include x -> sub.include_declaration sub x + | Pstr_extension (x, attrs) -> + sub.attributes sub attrs; sub.extension sub x + | Pstr_attribute x -> sub.attribute sub x +end + +module E = struct + (* Value expressions for the core language *) + + let iter_function_param sub { pparam_loc = loc; pparam_desc = desc } = + sub.location sub loc; + match desc with + | Pparam_val (_lab, def, p) -> + iter_opt (sub.expr sub) def; + sub.pat sub p + | Pparam_newtype ty -> + iter_loc sub ty + + let iter_body sub body = + match body with + | Pfunction_body e -> + sub.expr sub e + | Pfunction_cases (cases, loc, attrs) -> + sub.cases sub cases; + sub.location sub loc; + sub.attributes sub attrs + + let iter_constraint sub constraint_ = + match constraint_ with + | Pconstraint ty -> + sub.typ sub ty + | Pcoerce (ty1, ty2) -> + iter_opt (sub.typ sub) ty1; + sub.typ sub ty2 + + let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pexp_ident x -> iter_loc sub x + | Pexp_constant _ -> () + | Pexp_let (_r, vbs, e) -> + List.iter (sub.value_binding sub) vbs; + sub.expr sub e + | Pexp_function (params, constraint_, body) -> + List.iter (iter_function_param sub) params; + iter_opt (iter_constraint sub) constraint_; + iter_body sub body + | Pexp_apply (e, l) -> + sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l + | Pexp_match (e, pel) -> + sub.expr sub e; sub.cases sub pel + | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel + | Pexp_tuple el -> List.iter (sub.expr sub) el + | Pexp_construct (lid, arg) -> + iter_loc sub lid; iter_opt (sub.expr sub) arg + | Pexp_variant (_lab, eo) -> + iter_opt (sub.expr sub) eo + | Pexp_record (l, eo) -> + List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; + iter_opt (sub.expr sub) eo + | Pexp_field (e, lid) -> + sub.expr sub e; iter_loc sub lid + | Pexp_setfield (e1, lid, e2) -> + sub.expr sub e1; iter_loc sub lid; + sub.expr sub e2 + | Pexp_array el -> List.iter (sub.expr sub) el + | Pexp_ifthenelse (e1, e2, e3) -> + sub.expr sub e1; sub.expr sub e2; + iter_opt (sub.expr sub) e3 + | Pexp_sequence (e1, e2) -> + sub.expr sub e1; sub.expr sub e2 + | Pexp_while (e1, e2) -> + sub.expr sub e1; sub.expr sub e2 + | Pexp_for (p, e1, e2, _d, e3) -> + sub.pat sub p; sub.expr sub e1; sub.expr sub e2; + sub.expr sub e3 + | Pexp_coerce (e, t1, t2) -> + sub.expr sub e; iter_opt (sub.typ sub) t1; + sub.typ sub t2 + | Pexp_constraint (e, t) -> + sub.expr sub e; sub.typ sub t + | Pexp_send (e, _s) -> sub.expr sub e + | Pexp_new lid -> iter_loc sub lid + | Pexp_setinstvar (s, e) -> + iter_loc sub s; sub.expr sub e + | Pexp_override sel -> + List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel + | Pexp_letmodule (s, me, e) -> + iter_loc sub s; sub.module_expr sub me; + sub.expr sub e + | Pexp_letexception (cd, e) -> + sub.extension_constructor sub cd; + sub.expr sub e + | Pexp_assert e -> sub.expr sub e + | Pexp_lazy e -> sub.expr sub e + | Pexp_poly (e, t) -> + sub.expr sub e; iter_opt (sub.typ sub) t + | Pexp_object cls -> sub.class_structure sub cls + | Pexp_newtype (_s, e) -> sub.expr sub e + | Pexp_pack me -> sub.module_expr sub me + | Pexp_open (o, e) -> + sub.open_declaration sub o; sub.expr sub e + | Pexp_letop {let_; ands; body} -> + sub.binding_op sub let_; + List.iter (sub.binding_op sub) ands; + sub.expr sub body + | Pexp_extension x -> sub.extension sub x + | Pexp_unreachable -> () + + let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = + iter_loc sub pbop_op; + sub.pat sub pbop_pat; + sub.expr sub pbop_exp; + sub.location sub pbop_loc + +end + +module P = struct + (* Patterns *) + + let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Ppat_any -> () + | Ppat_var s -> iter_loc sub s + | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s + | Ppat_constant _ -> () + | Ppat_interval _ -> () + | Ppat_tuple pl -> List.iter (sub.pat sub) pl + | Ppat_construct (l, p) -> + iter_loc sub l; + iter_opt + (fun (vl,p) -> + List.iter (iter_loc sub) vl; + sub.pat sub p) + p + | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p + | Ppat_record (lpl, _cf) -> + List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl + | Ppat_array pl -> List.iter (sub.pat sub) pl + | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 + | Ppat_constraint (p, t) -> + sub.pat sub p; sub.typ sub t + | Ppat_type s -> iter_loc sub s + | Ppat_lazy p -> sub.pat sub p + | Ppat_unpack s -> iter_loc sub s + | Ppat_effect (p1,p2) -> sub.pat sub p1; sub.pat sub p2 + | Ppat_exception p -> sub.pat sub p + | Ppat_extension x -> sub.extension sub x + | Ppat_open (lid, p) -> + iter_loc sub lid; sub.pat sub p + +end + +module CE = struct + (* Value expressions for the class language *) + + let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcl_constr (lid, tys) -> + iter_loc sub lid; List.iter (sub.typ sub) tys + | Pcl_structure s -> + sub.class_structure sub s + | Pcl_fun (_lab, e, p, ce) -> + iter_opt (sub.expr sub) e; + sub.pat sub p; + sub.class_expr sub ce + | Pcl_apply (ce, l) -> + sub.class_expr sub ce; + List.iter (iter_snd (sub.expr sub)) l + | Pcl_let (_r, vbs, ce) -> + List.iter (sub.value_binding sub) vbs; + sub.class_expr sub ce + | Pcl_constraint (ce, ct) -> + sub.class_expr sub ce; sub.class_type sub ct + | Pcl_extension x -> sub.extension sub x + | Pcl_open (o, e) -> + sub.open_description sub o; sub.class_expr sub e + + let iter_kind sub = function + | Cfk_concrete (_o, e) -> sub.expr sub e + | Cfk_virtual t -> sub.typ sub t + + let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce + | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k + | Pcf_method (s, _p, k) -> + iter_loc sub s; iter_kind sub k + | Pcf_constraint (t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Pcf_initializer e -> sub.expr sub e + | Pcf_attribute x -> sub.attribute sub x + | Pcf_extension x -> sub.extension sub x + + let iter_structure sub {pcstr_self; pcstr_fields} = + sub.pat sub pcstr_self; + List.iter (sub.class_field sub) pcstr_fields + + let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr; + pci_loc; pci_attributes} = + List.iter (iter_fst (sub.typ sub)) pl; + iter_loc sub pci_name; + f pci_expr; + sub.location sub pci_loc; + sub.attributes sub pci_attributes +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_iterator = + { + structure = (fun this l -> List.iter (this.structure_item this) l); + structure_item = M.iter_structure_item; + module_expr = M.iter; + signature = (fun this l -> List.iter (this.signature_item this) l); + signature_item = MT.iter_signature_item; + module_type = MT.iter; + with_constraint = MT.iter_with_constraint; + class_declaration = + (fun this -> CE.class_infos this (this.class_expr this)); + class_expr = CE.iter; + class_field = CE.iter_field; + class_structure = CE.iter_structure; + class_type = CT.iter; + class_type_field = CT.iter_field; + class_signature = CT.iter_signature; + class_type_declaration = + (fun this -> CE.class_infos this (this.class_type this)); + class_description = + (fun this -> CE.class_infos this (this.class_type this)); + type_declaration = T.iter_type_declaration; + type_kind = T.iter_type_kind; + typ = T.iter; + row_field = T.row_field; + object_field = T.object_field; + type_extension = T.iter_type_extension; + type_exception = T.iter_type_exception; + extension_constructor = T.iter_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim = _; pval_loc; + pval_attributes} -> + iter_loc this pval_name; + this.typ this pval_type; + this.location this pval_loc; + this.attributes this pval_attributes; + ); + + pat = P.iter; + expr = E.iter; + binding_op = E.iter_binding_op; + + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + iter_loc this pmd_name; + this.module_type this pmd_type; + this.location this pmd_loc; + this.attributes this pmd_attributes; + ); + + module_substitution = + (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> + iter_loc this pms_name; + iter_loc this pms_manifest; + this.location this pms_loc; + this.attributes this pms_attributes; + ); + + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + iter_loc this pmtd_name; + iter_opt (this.module_type this) pmtd_type; + this.location this pmtd_loc; + this.attributes this pmtd_attributes; + ); + + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + iter_loc this pmb_name; this.module_expr this pmb_expr; + this.location this pmb_loc; + this.attributes this pmb_attributes; + ); + + open_declaration = + (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> + this.module_expr this popen_expr; + this.location this popen_loc; + this.attributes this popen_attributes + ); + + open_description = + (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> + iter_loc this popen_expr; + this.location this popen_loc; + this.attributes this popen_attributes + ); + + + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + this.module_type this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes + ); + + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + this.module_expr this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes + ); + + + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc; pvb_constraint} -> + this.pat this pvb_pat; + this.expr this pvb_expr; + Option.iter (function + | Parsetree.Pvc_constraint {locally_abstract_univars=vars; typ} -> + List.iter (iter_loc this) vars; + this.typ this typ + | Pvc_coercion { ground; coercion } -> + Option.iter (this.typ this) ground; + this.typ this coercion; + ) pvb_constraint; + this.location this pvb_loc; + this.attributes this pvb_attributes + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + iter_loc this pcd_name; + List.iter (iter_loc this) pcd_vars; + T.iter_constructor_arguments this pcd_args; + iter_opt (this.typ this) pcd_res; + this.location this pcd_loc; + this.attributes this pcd_attributes + ); + + label_declaration = + (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}-> + iter_loc this pld_name; + this.typ this pld_type; + this.location this pld_loc; + this.attributes this pld_attributes + ); + + cases = (fun this l -> List.iter (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + this.pat this pc_lhs; + iter_opt (this.expr this) pc_guard; + this.expr this pc_rhs + ); + + location = (fun _this _l -> ()); + + extension = (fun this (s, e) -> iter_loc this s; this.payload this e); + attribute = (fun this a -> + iter_loc this a.attr_name; + this.payload this a.attr_payload; + this.location this a.attr_loc + ); + attributes = (fun this l -> List.iter (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> this.structure this x + | PSig x -> this.signature this x + | PTyp x -> this.typ this x + | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g + ); + + directive_argument = + (fun this a -> + this.location this a.pdira_loc + ); + + toplevel_directive = + (fun this d -> + iter_loc this d.pdir_name; + iter_opt (this.directive_argument this) d.pdir_arg; + this.location this d.pdir_loc + ); + + toplevel_phrase = + (fun this -> function + | Ptop_def s -> this.structure this s + | Ptop_dir d -> this.toplevel_directive this d + ); + } diff --git a/upstream/ocaml_503/parsing/ast_iterator.mli b/upstream/ocaml_503/parsing/ast_iterator.mli new file mode 100644 index 000000000..6b0288916 --- /dev/null +++ b/upstream/ocaml_503/parsing/ast_iterator.mli @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** {!Ast_iterator.iterator} enables AST inspection using open recursion. A + typical mapper would be based on {!Ast_iterator.default_iterator}, a + trivial iterator, and will fall back on it for handling the syntax it does + not modify. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Parsetree + +(** {1 A generic Parsetree iterator} *) + +type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attribute list -> unit; + binding_op: iterator -> binding_op -> unit; + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + constructor_declaration: iterator -> constructor_declaration -> unit; + directive_argument: iterator -> directive_argument -> unit; + expr: iterator -> expression -> unit; + extension: iterator -> extension -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + include_declaration: iterator -> include_declaration -> unit; + include_description: iterator -> include_description -> unit; + label_declaration: iterator -> label_declaration -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + pat: iterator -> pattern -> unit; + payload: iterator -> payload -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + toplevel_directive: iterator -> toplevel_directive -> unit; + toplevel_phrase: iterator -> toplevel_phrase -> unit; + typ: iterator -> core_type -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} +(** A [iterator] record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the iterator to be applied to children in the syntax + tree. *) + +val default_iterator: iterator +(** A default iterator, which implements a "do not do anything" mapping. *) diff --git a/upstream/ocaml_503/parsing/ast_mapper.ml b/upstream/ocaml_503/parsing/ast_mapper.ml new file mode 100644 index 000000000..25512e59c --- /dev/null +++ b/upstream/ocaml_503/parsing/ast_mapper.ml @@ -0,0 +1,1177 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@ocaml.warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + +open Parsetree +open Ast_helper +open Location + +module String = Misc.Stdlib.String + +type mapper = { + attribute: mapper -> attribute -> attribute; + attributes: mapper -> attribute list -> attribute list; + binding_op: mapper -> binding_op -> binding_op; + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + class_signature: mapper -> class_signature -> class_signature; + class_structure: mapper -> class_structure -> class_structure; + class_type: mapper -> class_type -> class_type; + class_type_declaration: mapper -> class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + constant: mapper -> constant -> constant; + constructor_declaration: mapper -> constructor_declaration + -> constructor_declaration; + directive_argument: mapper -> directive_argument -> directive_argument; + expr: mapper -> expression -> expression; + extension: mapper -> extension -> extension; + extension_constructor: mapper -> extension_constructor + -> extension_constructor; + include_declaration: mapper -> include_declaration -> include_declaration; + include_description: mapper -> include_description -> include_description; + label_declaration: mapper -> label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_declaration: mapper -> module_declaration -> module_declaration; + module_substitution: mapper -> module_substitution -> module_substitution; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: mapper -> module_type_declaration + -> module_type_declaration; + open_declaration: mapper -> open_declaration -> open_declaration; + open_description: mapper -> open_description -> open_description; + pat: mapper -> pattern -> pattern; + payload: mapper -> payload -> payload; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; + toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} + +let map_fst f (x, y) = (f x, y) +let map_snd f (x, y) = (x, f y) +let map_tuple f1 f2 (x, y) = (f1 x, f2 y) +let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_opt f = function None -> None | Some x -> Some (f x) + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +module C = struct + (* Constants *) + + let map sub { pconst_desc; pconst_loc } = + let loc = sub.location sub pconst_loc in + let desc = + match pconst_desc with + | Pconst_integer _ + | Pconst_char _ + | Pconst_float _ -> + pconst_desc + | Pconst_string (s, loc, quotation_delimiter) -> + Pconst_string (s, sub.location sub loc, quotation_delimiter) + in + Const.mk ~loc desc +end + +module T = struct + (* Type expressions for the core language *) + + let row_field sub { + prf_desc; + prf_loc; + prf_attributes; + } = + let loc = sub.location sub prf_loc in + let attrs = sub.attributes sub prf_attributes in + let desc = match prf_desc with + | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) + | Rinherit t -> Rinherit (sub.typ sub t) + in + Rf.mk ~loc ~attrs desc + + let object_field sub { + pof_desc; + pof_loc; + pof_attributes; + } = + let loc = sub.location sub pof_loc in + let attrs = sub.attributes sub pof_attributes in + let desc = match pof_desc with + | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) + | Oinherit t -> Oinherit (sub.typ sub t) + in + Of.mk ~loc ~attrs desc + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + let open Typ in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ptyp_any -> any ~loc ~attrs () + | Ptyp_var s -> var ~loc ~attrs s + | Ptyp_arrow (lab, t1, t2) -> + arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) + | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_constr (lid, tl) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_object (l, o) -> + object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_class (lid, tl) -> + class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_alias (t, s) -> + let s = map_loc sub s in + alias ~loc ~attrs (sub.typ sub t) s + | Ptyp_variant (rl, b, ll) -> + variant ~loc ~attrs (List.map (row_field sub) rl) b ll + | Ptyp_poly (sl, t) -> poly ~loc ~attrs + (List.map (map_loc sub) sl) (sub.typ sub t) + | Ptyp_package (lid, l) -> + package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_open (mod_ident, t) -> + open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t) + | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_type_declaration sub + {ptype_name; ptype_params; ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc} = + let loc = sub.location sub ptype_loc in + let attrs = sub.attributes sub ptype_attributes in + Type.mk ~loc ~attrs (map_loc sub ptype_name) + ~params:(List.map (map_fst (sub.typ sub)) ptype_params) + ~priv:ptype_private + ~cstrs:(List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs) + ~kind:(sub.type_kind sub ptype_kind) + ?manifest:(map_opt (sub.typ sub) ptype_manifest) + + let map_type_kind sub = function + | Ptype_abstract -> Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub.constructor_declaration sub) l) + | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_open -> Ptype_open + + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> + Pcstr_record (List.map (sub.label_declaration sub) l) + + let map_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes} = + let loc = sub.location sub ptyext_loc in + let attrs = sub.attributes sub ptyext_attributes in + Te.mk ~loc ~attrs + (map_loc sub ptyext_path) + (List.map (sub.extension_constructor sub) ptyext_constructors) + ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) + ~priv:ptyext_private + + let map_type_exception sub + {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = + let loc = sub.location sub ptyexn_loc in + let attrs = sub.attributes sub ptyexn_attributes in + Te.mk_exception ~loc ~attrs + (sub.extension_constructor sub ptyexn_constructor) + + let map_extension_constructor_kind sub = function + Pext_decl(vars, ctl, cto) -> + Pext_decl(List.map (map_loc sub) vars, + map_constructor_arguments sub ctl, + map_opt (sub.typ sub) cto) + | Pext_rebind li -> + Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + let loc = sub.location sub pext_loc in + let attrs = sub.attributes sub pext_attributes in + Te.constructor ~loc ~attrs + (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + +end + +module CT = struct + (* Type expressions for the class language *) + + let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = + let open Cty in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pcty_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) + | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) + | Pcty_arrow (lab, t, ct) -> + arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) + | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pcty_open (o, ct) -> + open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) + + let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} + = + let open Ctf in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) + | Pctf_val (s, m, v, t) -> + val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) + | Pctf_method (s, p, v, t) -> + method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) + | Pctf_constraint (t1, t2) -> + constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) + | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) + | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_signature sub {pcsig_self; pcsig_fields} = + Csig.mk + (sub.typ sub pcsig_self) + (List.map (sub.class_type_field sub) pcsig_fields) +end + +let map_functor_param sub = function + | Unit -> Unit + | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) + +module MT = struct + (* Type expressions for the module language *) + + let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + let open Mty in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) + | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) + | Pmty_functor (param, mt) -> + functor_ ~loc ~attrs + (map_functor_param sub param) + (sub.module_type sub mt) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) + | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pwith_type (map_loc sub lid, sub.type_declaration sub d) + | Pwith_module (lid, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_modtype (lid, mty) -> + Pwith_modtype (map_loc sub lid, sub.module_type sub mty) + | Pwith_typesubst (lid, d) -> + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) + | Pwith_modsubst (s, lid) -> + Pwith_modsubst (map_loc sub s, map_loc sub lid) + | Pwith_modtypesubst (lid, mty) -> + Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub.location sub loc in + match desc with + | Psig_value vd -> value ~loc (sub.value_description sub vd) + | Psig_type (rf, l) -> + type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Psig_typesubst l -> + type_subst ~loc (List.map (sub.type_declaration sub) l) + | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) + | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) + | Psig_module x -> module_ ~loc (sub.module_declaration sub x) + | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub.module_declaration sub) l) + | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Psig_modtypesubst x -> + modtype_subst ~loc (sub.module_type_declaration sub x) + | Psig_open x -> open_ ~loc (sub.open_description sub x) + | Psig_include x -> include_ ~loc (sub.include_description sub x) + | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) + | Psig_class_type l -> + class_type ~loc (List.map (sub.class_type_declaration sub) l) + | Psig_extension (x, attrs) -> + let attrs = sub.attributes sub attrs in + extension ~loc ~attrs (sub.extension sub x) + | Psig_attribute x -> attribute ~loc (sub.attribute sub x) +end + + +module M = struct + (* Value expressions for the module language *) + + let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + let open Mod in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) + | Pmod_functor (param, body) -> + functor_ ~loc ~attrs + (map_functor_param sub param) + (sub.module_expr sub body) + | Pmod_apply (m1, m2) -> + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + | Pmod_apply_unit m1 -> + apply_unit ~loc ~attrs (sub.module_expr sub m1) + | Pmod_constraint (m, mty) -> + constraint_ ~loc ~attrs (sub.module_expr sub m) + (sub.module_type sub mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) + | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub.location sub loc in + match desc with + | Pstr_eval (x, attrs) -> + let attrs = sub.attributes sub attrs in + eval ~loc ~attrs (sub.expr sub x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) + | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) + | Pstr_module x -> module_ ~loc (sub.module_binding sub x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) + | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) + | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) + | Pstr_class_type l -> + class_type ~loc (List.map (sub.class_type_declaration sub) l) + | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) + | Pstr_extension (x, attrs) -> + let attrs = sub.attributes sub attrs in + extension ~loc ~attrs (sub.extension sub x) + | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module E = struct + (* Value expressions for the core language *) + + let map_function_param sub { pparam_loc = loc; pparam_desc = desc } = + let loc = sub.location sub loc in + let desc = + match desc with + | Pparam_val (lab, def, p) -> + Pparam_val + (lab, + map_opt (sub.expr sub) def, + sub.pat sub p) + | Pparam_newtype ty -> + Pparam_newtype (map_loc sub ty) + in + { pparam_loc = loc; pparam_desc = desc } + + let map_function_body sub body = + match body with + | Pfunction_body e -> + Pfunction_body (sub.expr sub e) + | Pfunction_cases (cases, loc, attributes) -> + let cases = sub.cases sub cases in + let loc = sub.location sub loc in + let attributes = sub.attributes sub attributes in + Pfunction_cases (cases, loc, attributes) + + let map_constraint sub c = + match c with + | Pconstraint ty -> Pconstraint (sub.typ sub ty) + | Pcoerce (ty1, ty2) -> Pcoerce (map_opt (sub.typ sub) ty1, sub.typ sub ty2) + + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) + | Pexp_let (r, vbs, e) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) + (sub.expr sub e) + | Pexp_function (ps, c, b) -> + function_ ~loc ~attrs + (List.map (map_function_param sub) ps) + (map_opt (map_constraint sub) c) + (map_function_body sub b) + | Pexp_apply (e, l) -> + apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) + | Pexp_match (e, pel) -> + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + | Pexp_variant (lab, eo) -> + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_record (l, eo) -> + record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (map_opt (sub.expr sub) eo) + | Pexp_field (e, lid) -> + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_setfield (e1, lid, e2) -> + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) + (sub.expr sub e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_ifthenelse (e1, e2, e3) -> + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) + | Pexp_sequence (e1, e2) -> + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_for (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) + | Pexp_coerce (e, t1, t2) -> + coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) + (sub.typ sub t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> + send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) + | Pexp_setinstvar (s, e) -> + setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_override sel -> + override ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) + | Pexp_letmodule (s, me, e) -> + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) + | Pexp_letexception (cd, e) -> + letexception ~loc ~attrs + (sub.extension_constructor sub cd) + (sub.expr sub e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) + | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) + | Pexp_poly (e, t) -> + poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) + | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) + | Pexp_newtype (s, e) -> + newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_open (o, e) -> + open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) + | Pexp_letop {let_; ands; body} -> + letop ~loc ~attrs (sub.binding_op sub let_) + (List.map (sub.binding_op sub) ands) (sub.expr sub body) + | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pexp_unreachable -> unreachable ~loc ~attrs () + + let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = + let open Exp in + let op = map_loc sub pbop_op in + let pat = sub.pat sub pbop_pat in + let exp = sub.expr sub pbop_exp in + let loc = sub.location sub pbop_loc in + binding_op op pat exp loc + +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + let open Pat in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ppat_any -> any ~loc ~attrs () + | Ppat_var s -> var ~loc ~attrs (map_loc sub s) + | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) + | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) + | Ppat_interval (c1, c2) -> + interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) + (map_opt + (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) + p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_record (lpl, cf) -> + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf + | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_constraint (p, t) -> + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) + | Ppat_effect(p1, p2) -> + effect_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) +end + +module CE = struct + (* Value expressions for the class language *) + + let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = + let open Cl in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pcl_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) + | Pcl_structure s -> + structure ~loc ~attrs (sub.class_structure sub s) + | Pcl_fun (lab, e, p, ce) -> + fun_ ~loc ~attrs lab + (map_opt (sub.expr sub) e) + (sub.pat sub p) + (sub.class_expr sub ce) + | Pcl_apply (ce, l) -> + apply ~loc ~attrs (sub.class_expr sub ce) + (List.map (map_snd (sub.expr sub)) l) + | Pcl_let (r, vbs, ce) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) + (sub.class_expr sub ce) + | Pcl_constraint (ce, ct) -> + constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) + | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pcl_open (o, ce) -> + open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) + + let map_kind sub = function + | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) + | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) + + let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = + let open Cf in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pcf_inherit (o, ce, s) -> + inherit_ ~loc ~attrs o (sub.class_expr sub ce) + (map_opt (map_loc sub) s) + | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) + | Pcf_method (s, p, k) -> + method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) + | Pcf_constraint (t1, t2) -> + constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) + | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) + | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) + | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure sub {pcstr_self; pcstr_fields} = + { + pcstr_self = sub.pat sub pcstr_self; + pcstr_fields = List.map (sub.class_field sub) pcstr_fields; + } + + let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; + pci_loc; pci_attributes} = + let loc = sub.location sub pci_loc in + let attrs = sub.attributes sub pci_attributes in + Ci.mk ~loc ~attrs + ~virt:pci_virt + ~params:(List.map (map_fst (sub.typ sub)) pl) + (map_loc sub pci_name) + (f pci_expr) +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_mapper = + { + constant = C.map; + structure = (fun this l -> List.map (this.structure_item this) l); + structure_item = M.map_structure_item; + module_expr = M.map; + signature = (fun this l -> List.map (this.signature_item this) l); + signature_item = MT.map_signature_item; + module_type = MT.map; + with_constraint = MT.map_with_constraint; + class_declaration = + (fun this -> CE.class_infos this (this.class_expr this)); + class_expr = CE.map; + class_field = CE.map_field; + class_structure = CE.map_structure; + class_type = CT.map; + class_type_field = CT.map_field; + class_signature = CT.map_signature; + class_type_declaration = + (fun this -> CE.class_infos this (this.class_type this)); + class_description = + (fun this -> CE.class_infos this (this.class_type this)); + type_declaration = T.map_type_declaration; + type_kind = T.map_type_kind; + typ = T.map; + type_extension = T.map_type_extension; + type_exception = T.map_type_exception; + extension_constructor = T.map_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim; pval_loc; + pval_attributes} -> + Val.mk + (map_loc this pval_name) + (this.typ this pval_type) + ~attrs:(this.attributes this pval_attributes) + ~loc:(this.location this pval_loc) + ~prim:pval_prim + ); + + pat = P.map; + expr = E.map; + binding_op = E.map_binding_op; + + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + Md.mk + (map_loc this pmd_name) + (this.module_type this pmd_type) + ~attrs:(this.attributes this pmd_attributes) + ~loc:(this.location this pmd_loc) + ); + + module_substitution = + (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> + Ms.mk + (map_loc this pms_name) + (map_loc this pms_manifest) + ~attrs:(this.attributes this pms_attributes) + ~loc:(this.location this pms_loc) + ); + + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + Mtd.mk + (map_loc this pmtd_name) + ?typ:(map_opt (this.module_type this) pmtd_type) + ~attrs:(this.attributes this pmtd_attributes) + ~loc:(this.location this pmtd_loc) + ); + + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) + ~attrs:(this.attributes this pmb_attributes) + ~loc:(this.location this pmb_loc) + ); + + + open_declaration = + (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> + Opn.mk (this.module_expr this popen_expr) + ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes) + ); + + open_description = + (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> + Opn.mk (map_loc this popen_expr) + ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes) + ); + + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes) + ); + + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes) + ); + + + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc} -> + let map_ct (ct:Parsetree.value_constraint) = match ct with + | Pvc_constraint {locally_abstract_univars=vars; typ} -> + Pvc_constraint + { locally_abstract_univars = List.map (map_loc this) vars; + typ = this.typ this typ + } + | Pvc_coercion { ground; coercion } -> + Pvc_coercion { + ground = Option.map (this.typ this) ground; + coercion = this.typ this coercion + } + in + Vb.mk + (this.pat this pvb_pat) + (this.expr this pvb_expr) + ?value_constraint:(Option.map map_ct pvb_constraint) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes) + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor + (map_loc this pcd_name) + ~vars:(List.map (map_loc this) pcd_vars) + ~args:(T.map_constructor_arguments this pcd_args) + ?res:(map_opt (this.typ this) pcd_res) + ~loc:(this.location this pcd_loc) + ~attrs:(this.attributes this pcd_attributes) + ); + + label_declaration = + (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> + Type.field + (map_loc this pld_name) + (this.typ this pld_type) + ~mut:pld_mutable + ~loc:(this.location this pld_loc) + ~attrs:(this.attributes this pld_attributes) + ); + + cases = (fun this l -> List.map (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + { + pc_lhs = this.pat this pc_lhs; + pc_guard = map_opt (this.expr this) pc_guard; + pc_rhs = this.expr this pc_rhs; + } + ); + + + + location = (fun _this l -> l); + + extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attribute = (fun this a -> + { + attr_name = map_loc this a.attr_name; + attr_payload = this.payload this a.attr_payload; + attr_loc = this.location this a.attr_loc + } + ); + attributes = (fun this l -> List.map (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> PStr (this.structure this x) + | PSig x -> PSig (this.signature this x) + | PTyp x -> PTyp (this.typ this x) + | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) + ); + + directive_argument = + (fun this a -> + { pdira_desc= a.pdira_desc + ; pdira_loc= this.location this a.pdira_loc} ); + + toplevel_directive = + (fun this d -> + { pdir_name= map_loc this d.pdir_name + ; pdir_arg= map_opt (this.directive_argument this) d.pdir_arg + ; pdir_loc= this.location this d.pdir_loc } ); + + toplevel_phrase = + (fun this -> function + | Ptop_def s -> Ptop_def (this.structure this s) + | Ptop_dir d -> Ptop_dir (this.toplevel_directive this d) ); + } + +let extension_of_error {kind; main; sub} = + if kind <> Location.Report_error then + raise (Invalid_argument "extension_of_error: expected kind Report_error"); + let str_of_msg msg = Format.asprintf "%a" Format_doc.Doc.format msg in + let extension_of_sub sub = + { loc = sub.loc; txt = "ocaml.error" }, + PStr ([Str.eval (Exp.constant + (Const.string ~loc:sub.loc (str_of_msg sub.txt)))]) + in + { loc = main.loc; txt = "ocaml.error" }, + PStr (Str.eval (Exp.constant + (Const.string ~loc:main.loc (str_of_msg main.txt))) :: + List.map (fun msg -> Str.extension (extension_of_sub msg)) sub) + +let attribute_of_warning loc s = + Attr.mk + {loc; txt = "ocaml.ppwarning" } + (PStr ([Str.eval ~loc (Exp.constant (Const.string ~loc s))])) + +let cookies = ref String.Map.empty + +let get_cookie k = + try Some (String.Map.find k !cookies) + with Not_found -> None + +let set_cookie k v = + cookies := String.Map.add k v !cookies + +let tool_name_ref = ref "_none_" + +let tool_name () = !tool_name_ref + + +module PpxContext = struct + open Longident + open Asttypes + open Ast_helper + + let lid name = { txt = Lident name; loc = Location.none } + + let make_string s = Exp.constant (Const.string s) + + let make_bool x = + if x + then Exp.construct (lid "true") None + else Exp.construct (lid "false") None + + let rec make_list f lst = + match lst with + | x :: rest -> + Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) + | [] -> + Exp.construct (lid "[]") None + + let make_pair f1 f2 (x1, x2) = + Exp.tuple [f1 x1; f2 x2] + + let make_option f opt = + match opt with + | Some x -> Exp.construct (lid "Some") (Some (f x)) + | None -> Exp.construct (lid "None") None + + let get_cookies () = + lid "cookies", + make_list (make_pair make_string (fun x -> x)) + (String.Map.bindings !cookies) + + let mk fields = + { + attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; + attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; + attr_loc = Location.none + } + + let make ~tool_name () = + let Load_path.{ visible; hidden } = Load_path.get_paths () in + let fields = + [ + lid "tool_name", make_string tool_name; + lid "include_dirs", make_list make_string (!Clflags.include_dirs); + lid "hidden_include_dirs", + make_list make_string (!Clflags.hidden_include_dirs); + lid "load_path", + make_pair (make_list make_string) (make_list make_string) + (visible, hidden); + lid "open_modules", make_list make_string !Clflags.open_modules; + lid "for_package", make_option make_string !Clflags.for_package; + lid "debug", make_bool !Clflags.debug; + lid "use_threads", make_bool !Clflags.use_threads; + lid "use_vmthreads", make_bool false; + lid "recursive_types", make_bool !Clflags.recursive_types; + lid "principal", make_bool !Clflags.principal; + lid "transparent_modules", make_bool !Clflags.transparent_modules; + lid "unboxed_types", make_bool !Clflags.unboxed_types; + lid "unsafe_string", make_bool false; (* kept for compatibility *) + get_cookies () + ] + in + mk fields + + let get_fields = function + | PStr [{pstr_desc = Pstr_eval + ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> + fields + | _ -> + raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" + + let restore fields = + let field name payload = + let rec get_string = function + | {pexp_desc = Pexp_constant + {pconst_desc = Pconst_string (str, _, None); _}} -> str + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] string syntax" name + and get_bool pexp = + match pexp with + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, + None)} -> + true + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, + None)} -> + false + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] bool syntax" name + and get_list elem = function + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> + elem exp :: get_list elem rest + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> + [] + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] list syntax" name + and get_pair f1 f2 = function + | {pexp_desc = Pexp_tuple [e1; e2]} -> + (f1 e1, f2 e2) + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] pair syntax" name + and get_option elem = function + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> + Some (elem exp) + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> + None + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] option syntax" name + in + match name with + | "tool_name" -> + tool_name_ref := get_string payload + | "include_dirs" -> + Clflags.include_dirs := get_list get_string payload + | "hidden_include_dirs" -> + Clflags.hidden_include_dirs := get_list get_string payload + | "load_path" -> + (* Duplicates Compmisc.auto_include, since we can't reference Compmisc + from this module. *) + let auto_include find_in_dir fn = + if !Clflags.no_std_include then + raise Not_found + else + let alert = Location.auto_include_alert in + Load_path.auto_include_otherlibs alert find_in_dir fn + in + let visible, hidden = + get_pair (get_list get_string) (get_list get_string) payload + in + Load_path.init ~auto_include ~visible ~hidden + | "open_modules" -> + Clflags.open_modules := get_list get_string payload + | "for_package" -> + Clflags.for_package := get_option get_string payload + | "debug" -> + Clflags.debug := get_bool payload + | "use_threads" -> + Clflags.use_threads := get_bool payload + | "use_vmthreads" -> + if get_bool payload then + raise_errorf "Internal error: vmthreads not supported after 4.09.0" + | "recursive_types" -> + Clflags.recursive_types := get_bool payload + | "principal" -> + Clflags.principal := get_bool payload + | "transparent_modules" -> + Clflags.transparent_modules := get_bool payload + | "unboxed_types" -> + Clflags.unboxed_types := get_bool payload + | "cookies" -> + let l = get_list (get_pair get_string (fun x -> x)) payload in + cookies := + List.fold_left + (fun s (k, v) -> String.Map.add k v s) String.Map.empty + l + | _ -> + () + in + List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields + + let update_cookies fields = + let fields = + List.filter + (function ({txt=Lident "cookies"}, _) -> false | _ -> true) + fields + in + fields @ [get_cookies ()] +end + +let ppx_context = PpxContext.make + +let extension_of_exn exn = + match error_of_exn exn with + | Some (`Ok error) -> extension_of_error error + | Some `Already_displayed -> + { loc = Location.none; txt = "ocaml.error" }, PStr [] + | None -> raise exn + + +let apply_lazy ~source ~target mapper = + let implem ast = + let fields, ast = + match ast with + | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; + attr_payload = x})} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let ast = + try + let mapper = mapper () in + mapper.structure mapper ast + with exn -> + [{pstr_desc = Pstr_extension (extension_of_exn exn, []); + pstr_loc = Location.none}] + in + let fields = PpxContext.update_cookies fields in + Str.attribute (PpxContext.mk fields) :: ast + in + let iface ast = + let fields, ast = + match ast with + | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; + attr_payload = x; + attr_loc = _})} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let ast = + try + let mapper = mapper () in + mapper.signature mapper ast + with exn -> + [{psig_desc = Psig_extension (extension_of_exn exn, []); + psig_loc = Location.none}] + in + let fields = PpxContext.update_cookies fields in + Sig.attribute (PpxContext.mk fields) :: ast + in + + let ic = open_in_bin source in + let magic = + really_input_string ic (String.length Config.ast_impl_magic_number) + in + + let rewrite transform = + Location.input_name := input_value ic; + let ast = input_value ic in + close_in ic; + let ast = transform ast in + let oc = open_out_bin target in + output_string oc magic; + output_value oc !Location.input_name; + output_value oc ast; + close_out oc + and fail () = + close_in ic; + failwith "Ast_mapper: OCaml version mismatch or malformed input"; + in + + if magic = Config.ast_impl_magic_number then + rewrite (implem : structure -> structure) + else if magic = Config.ast_intf_magic_number then + rewrite (iface : signature -> signature) + else fail () + +let drop_ppx_context_str ~restore = function + | {pstr_desc = Pstr_attribute + {attr_name = {Location.txt = "ocaml.ppx.context"}; + attr_payload = a; + attr_loc = _}} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let drop_ppx_context_sig ~restore = function + | {psig_desc = Psig_attribute + {attr_name = {Location.txt = "ocaml.ppx.context"}; + attr_payload = a; + attr_loc = _}} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let add_ppx_context_str ~tool_name ast = + Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast + +let add_ppx_context_sig ~tool_name ast = + Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast + + +let apply ~source ~target mapper = + apply_lazy ~source ~target (fun () -> mapper) + +let run_main mapper = + try + let a = Sys.argv in + let n = Array.length a in + if n > 2 then + let mapper () = + try mapper (Array.to_list (Array.sub a 1 (n - 3))) + with exn -> + (* PR#6463 *) + let f _ _ = raise exn in + {default_mapper with structure = f; signature = f} + in + apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper + else begin + Printf.eprintf "Usage: %s [extra_args] \n%!" + Sys.executable_name; + exit 2 + end + with exn -> + prerr_endline (Printexc.to_string exn); + exit 2 + +let register_function = ref (fun _name f -> run_main f) +let register name f = !register_function name f diff --git a/upstream/ocaml_503/parsing/ast_mapper.mli b/upstream/ocaml_503/parsing/ast_mapper.mli new file mode 100644 index 000000000..541c1f7da --- /dev/null +++ b/upstream/ocaml_503/parsing/ast_mapper.mli @@ -0,0 +1,211 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** The interface of a -ppx rewriter + + A -ppx rewriter is a program that accepts a serialized abstract syntax + tree and outputs another, possibly modified, abstract syntax tree. + This module encapsulates the interface between the compiler and + the -ppx rewriters, handling such details as the serialization format, + forwarding of command-line flags, and storing state. + + {!mapper} enables AST rewriting using open recursion. + A typical mapper would be based on {!default_mapper}, a deep + identity mapper, and will fall back on it for handling the syntax it + does not modify. For example: + + {[ +open Asttypes +open Parsetree +open Ast_mapper + +let test_mapper argv = + { default_mapper with + expr = fun mapper expr -> + match expr with + | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> + Ast_helper.Exp.constant (Pconst_integer ("42", None)) + | other -> default_mapper.expr mapper other; } + +let () = + register "ppx_test" test_mapper]} + + This -ppx rewriter, which replaces [[%test]] in expressions with + the constant [42], can be compiled using + [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + + *) + +open Parsetree + +(** {1 A generic Parsetree mapper} *) + +type mapper = { + attribute: mapper -> attribute -> attribute; + attributes: mapper -> attribute list -> attribute list; + binding_op: mapper -> binding_op -> binding_op; + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + class_signature: mapper -> class_signature -> class_signature; + class_structure: mapper -> class_structure -> class_structure; + class_type: mapper -> class_type -> class_type; + class_type_declaration: mapper -> class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + constant: mapper -> constant -> constant; + constructor_declaration: mapper -> constructor_declaration + -> constructor_declaration; + directive_argument: mapper -> directive_argument -> directive_argument; + expr: mapper -> expression -> expression; + extension: mapper -> extension -> extension; + extension_constructor: mapper -> extension_constructor + -> extension_constructor; + include_declaration: mapper -> include_declaration -> include_declaration; + include_description: mapper -> include_description -> include_description; + label_declaration: mapper -> label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_declaration: mapper -> module_declaration -> module_declaration; + module_substitution: mapper -> module_substitution -> module_substitution; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: mapper -> module_type_declaration + -> module_type_declaration; + open_declaration: mapper -> open_declaration -> open_declaration; + open_description: mapper -> open_description -> open_description; + pat: mapper -> pattern -> pattern; + payload: mapper -> payload -> payload; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; + toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} +(** A mapper record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the mapper to be applied to children in the syntax + tree. *) + +val default_mapper: mapper +(** A default mapper, which implements a "deep identity" mapping. *) + +(** {1 Apply mappers to compilation units} *) + +val tool_name: unit -> string +(** Can be used within a ppx preprocessor to know which tool is + calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], + ["ocaml"], ... Some global variables that reflect command-line + options are automatically synchronized between the calling tool + and the ppx preprocessor: {!Clflags.include_dirs}, + {!Clflags.hidden_include_dirs}, {!Load_path}, {!Clflags.open_modules}, + {!Clflags.for_package}, {!Clflags.debug}. *) + + +val apply: source:string -> target:string -> mapper -> unit +(** Apply a mapper (parametrized by the unit name) to a dumped + parsetree found in the [source] file and put the result in the + [target] file. The [structure] or [signature] field of the mapper + is applied to the implementation or interface. *) + +val run_main: (string list -> mapper) -> unit +(** Entry point to call to implement a standalone -ppx rewriter from a + mapper, parametrized by the command line arguments. The current + unit name can be obtained from {!Location.input_name}. This + function implements proper error reporting for uncaught + exceptions. *) + +(** {1 Registration API} *) + +val register_function: (string -> (string list -> mapper) -> unit) ref + +val register: string -> (string list -> mapper) -> unit +(** Apply the [register_function]. The default behavior is to run the + mapper immediately, taking arguments from the process command + line. This is to support a scenario where a mapper is linked as a + stand-alone executable. + + It is possible to overwrite the [register_function] to define + "-ppx drivers", which combine several mappers in a single process. + Typically, a driver starts by defining [register_function] to a + custom implementation, then lets ppx rewriters (linked statically + or dynamically) register themselves, and then run all or some of + them. It is also possible to have -ppx drivers apply rewriters to + only specific parts of an AST. + + The first argument to [register] is a symbolic name to be used by + the ppx driver. *) + + +(** {1 Convenience functions to write mappers} *) + +val map_opt: ('a -> 'b) -> 'a option -> 'b option + +val extension_of_error: Location.error -> extension +(** Encode an error into an 'ocaml.error' extension node which can be + inserted in a generated Parsetree. The compiler will be + responsible for reporting the error. *) + +val attribute_of_warning: Location.t -> string -> attribute +(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be + inserted in a generated Parsetree. The compiler will be + responsible for reporting the warning. *) + +(** {1 Helper functions to call external mappers} *) + +val add_ppx_context_str: + tool_name:string -> Parsetree.structure -> Parsetree.structure +(** Extract information from the current environment and encode it + into an attribute which is prepended to the list of structure + items in order to pass the information to an external + processor. *) + +val add_ppx_context_sig: + tool_name:string -> Parsetree.signature -> Parsetree.signature +(** Same as [add_ppx_context_str], but for signatures. *) + +val drop_ppx_context_str: + restore:bool -> Parsetree.structure -> Parsetree.structure +(** Drop the ocaml.ppx.context attribute from a structure. If + [restore] is true, also restore the associated data in the current + process. *) + +val drop_ppx_context_sig: + restore:bool -> Parsetree.signature -> Parsetree.signature +(** Same as [drop_ppx_context_str], but for signatures. *) + +(** {1 Cookies} *) + +(** Cookies are used to pass information from a ppx processor to + a further invocation of itself, when called from the OCaml + toplevel (or other tools that support cookies). *) + +val set_cookie: string -> Parsetree.expression -> unit +val get_cookie: string -> Parsetree.expression option diff --git a/upstream/ocaml_503/parsing/asttypes.ml b/upstream/ocaml_503/parsing/asttypes.ml new file mode 100644 index 000000000..0a5e73a4d --- /dev/null +++ b/upstream/ocaml_503/parsing/asttypes.ml @@ -0,0 +1,72 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Auxiliary AST types used by parsetree and typedtree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type constant = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + +type rec_flag = Nonrecursive | Recursive + +type direction_flag = Upto | Downto + +(* Order matters, used in polymorphic comparison *) +type private_flag = Private | Public + +type mutable_flag = Immutable | Mutable + +type virtual_flag = Virtual | Concrete + +type override_flag = Override | Fresh + +type closed_flag = Closed | Open + +type label = string + +type arg_label = + Nolabel + | Labelled of string (** [label:T -> ...] *) + | Optional of string (** [?label:T -> ...] *) + +type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; +} + + +type variance = + | Covariant + | Contravariant + | NoVariance + +type injectivity = + | Injective + | NoInjectivity + +let string_of_label = function + Nolabel -> "" + | Labelled s -> s + | Optional s -> "?"^s diff --git a/upstream/ocaml_503/parsing/asttypes.mli b/upstream/ocaml_503/parsing/asttypes.mli new file mode 100644 index 000000000..e3cf5ae4e --- /dev/null +++ b/upstream/ocaml_503/parsing/asttypes.mli @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Auxiliary AST types used by parsetree and typedtree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type constant = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + +type rec_flag = Nonrecursive | Recursive + +type direction_flag = Upto | Downto + +(* Order matters, used in polymorphic comparison *) +type private_flag = Private | Public + +type mutable_flag = Immutable | Mutable + +type virtual_flag = Virtual | Concrete + +type override_flag = Override | Fresh + +type closed_flag = Closed | Open + +type label = string + +type arg_label = + Nolabel + | Labelled of string (** [label:T -> ...] *) + | Optional of string (** [?label:T -> ...] *) + +type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; +} + + +type variance = + | Covariant + | Contravariant + | NoVariance + +type injectivity = + | Injective + | NoInjectivity + +val string_of_label: arg_label -> string diff --git a/upstream/ocaml_503/parsing/attr_helper.ml b/upstream/ocaml_503/parsing/attr_helper.ml new file mode 100644 index 000000000..f531cf95b --- /dev/null +++ b/upstream/ocaml_503/parsing/attr_helper.ml @@ -0,0 +1,59 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Parsetree + +module Style = Misc.Style + +type error = + | Multiple_attributes of string + | No_payload_expected of string + +exception Error of Location.t * error + +let get_no_payload_attribute nm attrs = + let actions = [(nm, Builtin_attributes.Return)] in + match Builtin_attributes.select_attributes actions attrs with + | [] -> None + | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name + | [ {attr_name = name; _} ] -> + raise (Error (name.loc, No_payload_expected name.txt)) + | _ :: {attr_name = name; _} :: _ -> + raise (Error (name.loc, Multiple_attributes name.txt)) + +let has_no_payload_attribute alt_names attrs = + match get_no_payload_attribute alt_names attrs with + | None -> false + | Some _ -> true + +open Format_doc + +let report_error_doc ppf = function + | Multiple_attributes name -> + fprintf ppf "Too many %a attributes" Style.inline_code name + | No_payload_expected name -> + fprintf ppf "Attribute %a does not accept a payload" Style.inline_code name + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error_doc err) + | _ -> + None + ) + +let report_error = Format_doc.compat report_error_doc diff --git a/upstream/ocaml_503/parsing/attr_helper.mli b/upstream/ocaml_503/parsing/attr_helper.mli new file mode 100644 index 000000000..2782cba80 --- /dev/null +++ b/upstream/ocaml_503/parsing/attr_helper.mli @@ -0,0 +1,39 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers for attributes + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Asttypes +open Parsetree + +type error = + | Multiple_attributes of string + | No_payload_expected of string + +(** The [string] argument of the following functions is the name of the + attribute we are looking for. If the argument is ["foo"], these functions + will find attributes with the name ["foo"] or ["ocaml.foo"] *) +val get_no_payload_attribute : string -> attributes -> string loc option +val has_no_payload_attribute : string -> attributes -> bool + +exception Error of Location.t * error + +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer diff --git a/upstream/ocaml_503/parsing/builtin_attributes.ml b/upstream/ocaml_503/parsing/builtin_attributes.ml new file mode 100644 index 000000000..4d730d302 --- /dev/null +++ b/upstream/ocaml_503/parsing/builtin_attributes.ml @@ -0,0 +1,412 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Parsetree +open Ast_helper + + +module Attribute_table = Hashtbl.Make (struct + type t = string with_loc + + let hash : t -> int = Hashtbl.hash + let equal : t -> t -> bool = (=) +end) +let unused_attrs = Attribute_table.create 128 +let mark_used t = Attribute_table.remove unused_attrs t + +(* [attr_order] is used to issue unused attribute warnings in the order the + attributes occur in the file rather than the random order of the hash table +*) +let attr_order a1 a2 = + match String.compare a1.loc.loc_start.pos_fname a2.loc.loc_start.pos_fname + with + | 0 -> Int.compare a1.loc.loc_start.pos_cnum a2.loc.loc_start.pos_cnum + | n -> n + +let compiler_stops_before_attributes_consumed () = + let stops_before_lambda = + match !Clflags.stop_after with + | None -> false + | Some pass -> Clflags.Compiler_pass.(compare pass Lambda) < 0 + in + stops_before_lambda || !Clflags.print_types + +let warn_unused () = + let keys = List.of_seq (Attribute_table.to_seq_keys unused_attrs) in + Attribute_table.clear unused_attrs; + if not (compiler_stops_before_attributes_consumed ()) then + let keys = List.sort attr_order keys in + List.iter (fun sloc -> + Location.prerr_warning sloc.loc (Warnings.Misplaced_attribute sloc.txt)) + keys + +(* These are the attributes that are tracked in the builtin_attrs table for + misplaced attribute warnings. *) +let builtin_attrs = + [ "alert" + ; "boxed" + ; "deprecated" + ; "deprecated_mutable" + ; "explicit_arity" + ; "immediate" + ; "immediate64" + ; "inline" + ; "inlined" + ; "noalloc" + ; "poll" + ; "ppwarning" + ; "specialise" + ; "specialised" + ; "tailcall" + ; "tail_mod_cons" + ; "unboxed" + ; "untagged" + ; "unrolled" + ; "warnerror" + ; "warning" + ; "warn_on_literal_pattern" + ] + +let builtin_attrs = + let tbl = Hashtbl.create 128 in + List.iter (fun attr -> Hashtbl.add tbl attr ()) builtin_attrs; + tbl + +let drop_ocaml_attr_prefix s = + let len = String.length s in + if String.starts_with ~prefix:"ocaml." s && len > 6 then + String.sub s 6 (len - 6) + else + s + +let is_builtin_attr s = Hashtbl.mem builtin_attrs (drop_ocaml_attr_prefix s) + +type current_phase = Parser | Invariant_check + +let register_attr current_phase name = + match current_phase with + | Parser when !Clflags.all_ppx <> [] -> () + | Parser | Invariant_check -> + if is_builtin_attr name.txt then + Attribute_table.replace unused_attrs name () + +let string_of_cst const = + match const.pconst_desc with + | Pconst_string(s, _, _) -> Some s + | _ -> None + +let string_of_payload = function + | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] -> + string_of_cst c + | _ -> None + +let string_of_opt_payload p = + match string_of_payload p with + | Some s -> s + | None -> "" + +module Style = Misc.Style +let error_of_extension ext = + let submessage_from main_loc main_txt = function + | {pstr_desc=Pstr_extension + (({txt = ("ocaml.error"|"error"); loc}, p), _)} -> + begin match p with + | PStr([{pstr_desc=Pstr_eval + ({pexp_desc=Pexp_constant + {pconst_desc=Pconst_string(msg, _, _); _}}, _)} + ]) -> + Location.msg ~loc "%a" Format_doc.pp_print_text msg + | _ -> + Location.msg ~loc "Invalid syntax for sub-message of extension %a." + Style.inline_code main_txt + end + | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} -> + Location.msg ~loc "Uninterpreted extension '%a'." + Style.inline_code txt + | _ -> + Location.msg ~loc:main_loc + "Invalid syntax for sub-message of extension %a." + Style.inline_code main_txt + in + match ext with + | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> + begin match p with + | PStr [] -> raise Location.Already_displayed_error + | PStr({pstr_desc=Pstr_eval + ({pexp_desc=Pexp_constant + {pconst_desc=Pconst_string(msg, _, _)}}, _)}:: + inner) -> + let sub = List.map (submessage_from loc txt) inner in + Location.error_of_printer ~loc ~sub Format_doc.pp_print_text msg + | _ -> + Location.errorf ~loc "Invalid syntax for extension '%s'." txt + end + | ({txt; loc}, _) -> + Location.errorf ~loc "Uninterpreted extension '%s'." txt + +let attr_equals_builtin {attr_name = {txt; _}; _} s = + (* Check for attribute s or ocaml.s. Avoid allocating a fresh string. *) + txt = s || + ( String.length txt = 6 + String.length s + && String.starts_with ~prefix:"ocaml." txt + && String.ends_with ~suffix:s txt) + +let mark_alert_used a = + if attr_equals_builtin a "deprecated" || attr_equals_builtin a "alert" + then mark_used a.attr_name + +let mark_alerts_used l = List.iter mark_alert_used l + +let mark_warn_on_literal_pattern_used l = + List.iter (fun a -> + if attr_equals_builtin a "warn_on_literal_pattern" + then mark_used a.attr_name) + l + +let mark_deprecated_mutable_used l = + List.iter (fun a -> + if attr_equals_builtin a "deprecated_mutable" + then mark_used a.attr_name) + l + +let mark_payload_attrs_used payload = + let iter = + { Ast_iterator.default_iterator + with attribute = fun self a -> + mark_used a.attr_name; + Ast_iterator.default_iterator.attribute self a + } + in + iter.payload iter payload + +let kind_and_message = function + | PStr[ + {pstr_desc= + Pstr_eval + ({pexp_desc=Pexp_apply + ({pexp_desc=Pexp_ident{txt=Longident.Lident id}}, + [Nolabel,{pexp_desc=Pexp_constant + {pconst_desc=Pconst_string(s,_,_); _}}]) + },_)}] -> + Some (id, s) + | PStr[ + {pstr_desc= + Pstr_eval + ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},_)}] -> + Some (id, "") + | _ -> None + +let cat s1 s2 = + if s2 = "" then s1 else s1 ^ "\n" ^ s2 + +let alert_attr x = + if attr_equals_builtin x "deprecated" then + Some (x, "deprecated", string_of_opt_payload x.attr_payload) + else if attr_equals_builtin x "alert" then + begin match kind_and_message x.attr_payload with + | Some (kind, message) -> Some (x, kind, message) + | None -> None (* note: bad payloads detected by warning_attribute *) + end + else None + +let alert_attrs l = + List.filter_map alert_attr l + +let alerts_of_attrs l = + List.fold_left + (fun acc (_, kind, message) -> + let upd = function + | None | Some "" -> Some message + | Some s -> Some (cat s message) + in + Misc.Stdlib.String.Map.update kind upd acc + ) + Misc.Stdlib.String.Map.empty + (alert_attrs l) + +let check_alerts loc attrs s = + Misc.Stdlib.String.Map.iter + (fun kind message -> Location.alert loc ~kind (cat s message)) + (alerts_of_attrs attrs) + +let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s = + let m2 = alerts_of_attrs attrs2 in + Misc.Stdlib.String.Map.iter + (fun kind msg -> + if not (Misc.Stdlib.String.Map.mem kind m2) then + Location.alert ~def ~use ~kind loc (cat s msg) + ) + (alerts_of_attrs attrs1) + +let rec deprecated_mutable_of_attrs = function + | [] -> None + | attr :: _ when attr_equals_builtin attr "deprecated_mutable" -> + Some (string_of_opt_payload attr.attr_payload) + | _ :: tl -> deprecated_mutable_of_attrs tl + +let check_deprecated_mutable loc attrs s = + match deprecated_mutable_of_attrs attrs with + | None -> () + | Some txt -> + Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt)) + +let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s = + match deprecated_mutable_of_attrs attrs1, + deprecated_mutable_of_attrs attrs2 + with + | None, _ | Some _, Some _ -> () + | Some txt, None -> + Location.deprecated ~def ~use loc + (Printf.sprintf "mutating field %s" (cat s txt)) + +let rec attrs_of_sig = function + | {psig_desc = Psig_attribute a} :: tl -> + a :: attrs_of_sig tl + | _ -> + [] + +let alerts_of_sig ~mark sg = + let a = attrs_of_sig sg in + if mark then mark_alerts_used a; + alerts_of_attrs a + +let rec attrs_of_str = function + | {pstr_desc = Pstr_attribute a} :: tl -> + a :: attrs_of_str tl + | _ -> + [] + +let alerts_of_str ~mark str = + let a = attrs_of_str str in + if mark then mark_alerts_used a; + alerts_of_attrs a + +let warn_payload loc txt msg = + Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)) + +let warning_attribute ?(ppwarning = true) = + let process loc name errflag payload = + mark_used name; + match string_of_payload payload with + | Some s -> + begin try + Option.iter (Location.prerr_alert loc) + (Warnings.parse_options errflag s) + with Arg.Bad msg -> warn_payload loc name.txt msg + end + | None -> + warn_payload loc name.txt "A single string literal is expected" + in + let process_alert loc name = function + | PStr[{pstr_desc= + Pstr_eval( + {pexp_desc=Pexp_constant {pconst_desc=Pconst_string(s,_,_); _}}, + _) + }] -> + begin + mark_used name; + try Warnings.parse_alert_option s + with Arg.Bad msg -> warn_payload loc name.txt msg + end + | k -> + match kind_and_message k with + | Some ("all", _) -> + warn_payload loc name.txt "The alert name 'all' is reserved" + | Some _ -> + (* Do [mark_used] in the [Some] case only if Warning 53 is + disabled. Later, they will be marked used (provided they are in a + valid place) in [compile_common], when they are extracted to be + persisted inside the [.cmi] file. *) + if not (Warnings.is_active (Misplaced_attribute "")) + then mark_used name + | None -> begin + (* Do [mark_used] in the [None] case, which is just malformed and + covered by the "Invalid payload" warning. *) + mark_used name; + warn_payload loc name.txt "Invalid payload" + end + in + fun ({attr_name; attr_loc; attr_payload} as attr) -> + if attr_equals_builtin attr "warning" then + process attr_loc attr_name false attr_payload + else if attr_equals_builtin attr "warnerror" then + process attr_loc attr_name true attr_payload + else if attr_equals_builtin attr "alert" then + process_alert attr_loc attr_name attr_payload + else if ppwarning && attr_equals_builtin attr "ppwarning" then + begin match attr_payload with + | PStr [{ pstr_desc= + Pstr_eval({pexp_desc=Pexp_constant + {pconst_desc=Pconst_string (s, _, _); _}},_); + pstr_loc }] -> + (mark_used attr_name; + Location.prerr_warning pstr_loc (Warnings.Preprocessor s)) + | _ -> + (mark_used attr_name; + warn_payload attr_loc attr_name.txt + "A single string literal is expected") + end + +let warning_scope ?ppwarning attrs f = + let prev = Warnings.backup () in + try + List.iter (warning_attribute ?ppwarning) (List.rev attrs); + let ret = f () in + Warnings.restore prev; + ret + with exn -> + Warnings.restore prev; + raise exn + +let has_attribute nm attrs = + List.exists + (fun a -> + if attr_equals_builtin a nm + then (mark_used a.attr_name; true) + else false) + attrs + +type attr_action = Mark_used_only | Return +let select_attributes actions attrs = + List.filter (fun a -> + List.exists (fun (nm, action) -> + attr_equals_builtin a nm && + begin + mark_used a.attr_name; + action = Return + end) + actions + ) attrs + +let warn_on_literal_pattern attrs = + has_attribute "warn_on_literal_pattern" attrs + +let explicit_arity attrs = has_attribute "explicit_arity" attrs + +let immediate attrs = has_attribute "immediate" attrs + +let immediate64 attrs = has_attribute "immediate64" attrs + +(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" + attributes cannot be input by the user, they are added by the + compiler when applying the default setting. This is done to record + in the .cmi the default used by the compiler when compiling the + source file because the default can change between compiler + invocations. *) + +let has_unboxed attrs = has_attribute "unboxed" attrs + +let has_boxed attrs = has_attribute "boxed" attrs diff --git a/upstream/ocaml_503/parsing/builtin_attributes.mli b/upstream/ocaml_503/parsing/builtin_attributes.mli new file mode 100644 index 000000000..4176bcb93 --- /dev/null +++ b/upstream/ocaml_503/parsing/builtin_attributes.mli @@ -0,0 +1,187 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Support for the builtin attributes: + + - ocaml.alert + - ocaml.boxed + - ocaml.deprecated + - ocaml.deprecated_mutable + - ocaml.explicit_arity + - ocaml.immediate + - ocaml.immediate64 + - ocaml.inline + - ocaml.inlined + - ocaml.noalloc + - ocaml.poll + - ocaml.ppwarning + - ocaml.specialise + - ocaml.specialised + - ocaml.tailcall + - ocaml.tail_mod_cons + - ocaml.unboxed + - ocaml.untagged + - ocaml.unrolled + - ocaml.warnerror + - ocaml.warning + - ocaml.warn_on_literal_pattern + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +(** {2 Attribute tracking for warning 53} *) + +(** [register_attr] must be called on the locations of all attributes that + should be tracked for the purpose of misplaced attribute warnings. In + particular, it should be called on all attributes that are present in the + source program except those that are contained in the payload of another + attribute (because these may be left behind by a ppx and intentionally + ignored by the compiler). + + The [current_phase] argument indicates when this function is being called + - either when an attribute is created in the parser or when we see an + attribute while running the check in the [Ast_invariants] module. This is + used to ensure that we track only attributes from the final version of the + parse tree: we skip adding attributes seen at parse time if we can see that + a ppx will be run later, because the [Ast_invariants] check is always run on + the result of a ppx. + + Note that the [Ast_invariants] check is also run on parse trees created from + marshalled ast files if no ppx is being used, ensuring we don't miss + attributes in that case. +*) +type current_phase = Parser | Invariant_check +val register_attr : current_phase -> string Location.loc -> unit + +(** Marks the attributes hiding in the payload of another attribute used, for + the purposes of misplaced attribute warnings (see comment on + [current_phase] above). In the parser, it's simplest to add these to + the table and remove them later, rather than threading through state + tracking whether we're in an attribute payload. *) +val mark_payload_attrs_used : Parsetree.payload -> unit + +(** Issue misplaced attribute warnings for all attributes created with + [mk_internal] but not yet marked used. Does nothing if compilation + is stopped before lambda due to command-line flags. *) +val warn_unused : unit -> unit + +(** {3 Warning 53 helpers for environment attributes} + + Some attributes, like deprecation markers, do not affect the compilation of + the definition on which they appear, but rather result in warnings on future + uses of that definition. This is implemented by moving the raw attributes + into the environment, where they will be noticed on future accesses. + + To make misplaced attribute warnings work appropriately for these + attributes, we mark them "used" when they are moved into the environment. + This is done with the helper functions in this section. +*) + +(** Marks the attribute used for the purposes of misplaced attribute warnings if + it is an alert. Call this when moving things allowed to have alert + attributes into the environment. *) +val mark_alert_used : Parsetree.attribute -> unit + +(** The same as [List.iter mark_alert_used]. *) +val mark_alerts_used : Parsetree.attributes -> unit + +(** Marks "warn_on_literal_pattern" attributes used for the purposes of + misplaced attribute warnings. Call this when moving constructors into the + environment. *) +val mark_warn_on_literal_pattern_used : Parsetree.attributes -> unit + +(** Marks "deprecated_mutable" attributes used for the purposes of misplaced + attribute warnings. Call this when moving labels of mutable fields into the + environment. *) +val mark_deprecated_mutable_used : Parsetree.attributes -> unit + +(** {2 Helpers for alert and warning attributes} *) + +val check_alerts: Location.t -> Parsetree.attributes -> string -> unit +val check_alerts_inclusion: + def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> + Parsetree.attributes -> string -> unit +val alerts_of_attrs: Parsetree.attributes -> Misc.alerts +val alerts_of_sig: mark:bool -> Parsetree.signature -> Misc.alerts +val alerts_of_str: mark:bool -> Parsetree.structure -> Misc.alerts + +val check_deprecated_mutable: + Location.t -> Parsetree.attributes -> string -> unit +val check_deprecated_mutable_inclusion: + def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> + Parsetree.attributes -> string -> unit + +val error_of_extension: Parsetree.extension -> Location.error + +val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit + (** Apply warning settings from the specified attribute. + "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix) are + processed and marked used for warning 53. Other attributes are ignored. + + Also implement ocaml.ppwarning (unless ~ppwarning:false is + passed). + *) + +val warning_scope: + ?ppwarning:bool -> + Parsetree.attributes -> (unit -> 'a) -> 'a + (** Execute a function in a new scope for warning settings. This + means that the effect of any call to [warning_attribute] during + the execution of this function will be discarded after + execution. + + The function also takes a list of attributes which are processed + with [warning_attribute] in the fresh scope before the function + is executed. + *) + +(** {2 Helpers for searching for particular attributes} *) + +(** [has_attribute name attrs] is true if an attribute with name [name] or + ["ocaml." ^ name] is present in [attrs]. It marks that attribute used for + the purposes of misplaced attribute warnings. *) +val has_attribute : string -> Parsetree.attributes -> bool + +(** [select_attributes actions attrs] finds the elements of [attrs] that appear + in [actions] and either returns them or just marks them used, according to + the corresponding [attr_action]. + + Each element [(nm, action)] of the [actions] list is an attribute along with + an [attr_action] specifying what to do with that attribute. The action is + used to accommodate different compiler configurations. If an attribute is + used only in some compiler configurations, it's important that we still look + for it and mark it used when compiling with other configurations. + Otherwise, we would issue spurious misplaced attribute warnings. *) +type attr_action = Mark_used_only | Return +val select_attributes : + (string * attr_action) list -> Parsetree.attributes -> Parsetree.attributes + +(** [attr_equals_builtin attr s] is true if the name of the attribute is [s] or + ["ocaml." ^ s]. This is useful for manually inspecting attribute names, but + note that doing so will not result in marking the attribute used for the + purpose of warning 53, so it is usually preferable to use [has_attribute] + or [select_attributes]. *) +val attr_equals_builtin : Parsetree.attribute -> string -> bool + +val warn_on_literal_pattern: Parsetree.attributes -> bool +val explicit_arity: Parsetree.attributes -> bool + +val immediate: Parsetree.attributes -> bool +val immediate64: Parsetree.attributes -> bool + +val has_unboxed: Parsetree.attributes -> bool +val has_boxed: Parsetree.attributes -> bool diff --git a/upstream/ocaml_503/parsing/depend.ml b/upstream/ocaml_503/parsing/depend.ml new file mode 100644 index 000000000..bed4fd707 --- /dev/null +++ b/upstream/ocaml_503/parsing/depend.ml @@ -0,0 +1,632 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Location +open Longident +open Parsetree +module String = Misc.Stdlib.String + +let pp_deps = ref [] + +(* Module resolution map *) +(* Node (set of imports for this path, map for submodules) *) +type map_tree = Node of String.Set.t * bound_map +and bound_map = map_tree String.Map.t +let bound = Node (String.Set.empty, String.Map.empty) + +(*let get_free (Node (s, _m)) = s*) +let get_map (Node (_s, m)) = m +let make_leaf s = Node (String.Set.singleton s, String.Map.empty) +let make_node m = Node (String.Set.empty, m) +let rec weaken_map s (Node(s0,m0)) = + Node (String.Set.union s s0, String.Map.map (weaken_map s) m0) +let rec collect_free (Node (s, m)) = + String.Map.fold (fun _ n -> String.Set.union (collect_free n)) m s + +(* Returns the imports required to access the structure at path p *) +(* Only raises Not_found if the head of p is not in the toplevel map *) +let rec lookup_free p m = + match p with + [] -> raise Not_found + | s::p -> + let Node (f, m') = String.Map.find s m in + try lookup_free p m' with Not_found -> f + +(* Returns the node corresponding to the structure at path p *) +let rec lookup_map lid m = + match lid with + Lident s -> String.Map.find s m + | Ldot (l, s) -> String.Map.find s (get_map (lookup_map l m)) + | Lapply _ -> raise Not_found + +let free_structure_names = ref String.Set.empty + +let add_names s = + free_structure_names := String.Set.union s !free_structure_names + +let rec add_path bv ?(p=[]) = function + | Lident s -> + let free = + try lookup_free (s::p) bv with Not_found -> String.Set.singleton s + in + (*String.Set.iter (fun s -> Printf.eprintf "%s " s) free; + prerr_endline "";*) + add_names free + | Ldot(l, s) -> add_path bv ~p:(s::p) l + | Lapply(l1, l2) -> add_path bv l1; add_path bv l2 + +let open_module bv lid = + match lookup_map lid bv with + | Node (s, m) -> + add_names s; + String.Map.fold String.Map.add m bv + | exception Not_found -> + add_path bv lid; bv + +let add_parent bv lid = + match lid.txt with + Ldot(l, _s) -> add_path bv l + | _ -> () + +let add = add_parent + +let add_module_path bv lid = add_path bv lid.txt + +let handle_extension ext = + match (fst ext).txt with + | "error" | "ocaml.error" -> + raise (Location.Error + (Builtin_attributes.error_of_extension ext)) + | _ -> + () + +let rec add_type bv ty = + match ty.ptyp_desc with + Ptyp_any -> () + | Ptyp_var _ -> () + | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2 + | Ptyp_tuple tl -> List.iter (add_type bv) tl + | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl + | Ptyp_object (fl, _) -> + List.iter + (fun {pof_desc; _} -> match pof_desc with + | Otag (_, t) -> add_type bv t + | Oinherit t -> add_type bv t) fl + | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl + | Ptyp_alias(t, _) -> add_type bv t + | Ptyp_variant(fl, _, _) -> + List.iter + (fun {prf_desc; _} -> match prf_desc with + | Rtag(_, _, stl) -> List.iter (add_type bv) stl + | Rinherit sty -> add_type bv sty) + fl + | Ptyp_poly(_, t) -> add_type bv t + | Ptyp_package pt -> add_package_type bv pt + | Ptyp_open (mod_ident, t) -> + let bv = open_module bv mod_ident.txt in + add_type bv t + | Ptyp_extension e -> handle_extension e + +and add_package_type bv (lid, l) = + add bv lid; + List.iter (add_type bv) (List.map (fun (_, e) -> e) l) + +let add_opt add_fn bv = function + None -> () + | Some x -> add_fn bv x + +let add_constructor_arguments bv = function + | Pcstr_tuple l -> List.iter (add_type bv) l + | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l + +let add_constructor_decl bv pcd = + add_constructor_arguments bv pcd.pcd_args; + Option.iter (add_type bv) pcd.pcd_res + +let add_type_declaration bv td = + List.iter + (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2) + td.ptype_cstrs; + add_opt add_type bv td.ptype_manifest; + let add_tkind = function + Ptype_abstract -> () + | Ptype_variant cstrs -> + List.iter (add_constructor_decl bv) cstrs + | Ptype_record lbls -> + List.iter (fun pld -> add_type bv pld.pld_type) lbls + | Ptype_open -> () in + add_tkind td.ptype_kind + +let add_extension_constructor bv ext = + match ext.pext_kind with + Pext_decl(_, args, rty) -> + add_constructor_arguments bv args; + Option.iter (add_type bv) rty + | Pext_rebind lid -> add bv lid + +let add_type_extension bv te = + add bv te.ptyext_path; + List.iter (add_extension_constructor bv) te.ptyext_constructors + +let add_type_exception bv te = + add_extension_constructor bv te.ptyexn_constructor + +let pattern_bv = ref String.Map.empty + +let rec add_pattern bv pat = + match pat.ppat_desc with + Ppat_any -> () + | Ppat_var _ -> () + | Ppat_alias(p, _) -> add_pattern bv p + | Ppat_interval _ + | Ppat_constant _ -> () + | Ppat_tuple pl -> List.iter (add_pattern bv) pl + | Ppat_construct(c, opt) -> + add bv c; + add_opt + (fun bv (_,p) -> add_pattern bv p) + bv opt + | Ppat_record(pl, _) -> + List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl + | Ppat_array pl -> List.iter (add_pattern bv) pl + | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 + | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty + | Ppat_variant(_, op) -> add_opt add_pattern bv op + | Ppat_type li -> add bv li + | Ppat_lazy p -> add_pattern bv p + | Ppat_unpack id -> + Option.iter + (fun name -> pattern_bv := String.Map.add name bound !pattern_bv) id.txt + | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p + | Ppat_effect(p1, p2) -> add_pattern bv p1; add_pattern bv p2 + | Ppat_exception p -> add_pattern bv p + | Ppat_extension e -> handle_extension e + +let add_pattern bv pat = + pattern_bv := bv; + add_pattern bv pat; + !pattern_bv + +let rec add_expr bv exp = + match exp.pexp_desc with + Pexp_ident l -> add bv l + | Pexp_constant _ -> () + | Pexp_let(rf, pel, e) -> + let bv = add_bindings rf bv pel in add_expr bv e + | Pexp_function (params, constraint_, body) -> + let bv = List.fold_left add_function_param bv params in + add_opt add_constraint bv constraint_; + add_function_body bv body + | Pexp_apply(e, el) -> + add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el + | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel + | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel + | Pexp_tuple el -> List.iter (add_expr bv) el + | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte + | Pexp_variant(_, opte) -> add_opt add_expr bv opte + | Pexp_record(lblel, opte) -> + List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel; + add_opt add_expr bv opte + | Pexp_field(e, fld) -> add_expr bv e; add bv fld + | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2 + | Pexp_array el -> List.iter (add_expr bv) el + | Pexp_ifthenelse(e1, e2, opte3) -> + add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3 + | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2 + | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2 + | Pexp_for( _, e1, e2, _, e3) -> + add_expr bv e1; add_expr bv e2; add_expr bv e3 + | Pexp_coerce(e1, oty2, ty3) -> + add_expr bv e1; + add_opt add_type bv oty2; + add_type bv ty3 + | Pexp_constraint(e1, ty2) -> + add_expr bv e1; + add_type bv ty2 + | Pexp_send(e, _m) -> add_expr bv e + | Pexp_new li -> add bv li + | Pexp_setinstvar(_v, e) -> add_expr bv e + | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel + | Pexp_letmodule(id, m, e) -> + let b = add_module_binding bv m in + let bv = + match id.txt with + | None -> bv + | Some id -> String.Map.add id b bv + in + add_expr bv e + | Pexp_letexception(_, e) -> add_expr bv e + | Pexp_assert (e) -> add_expr bv e + | Pexp_lazy (e) -> add_expr bv e + | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t + | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } -> + let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl + | Pexp_newtype (_, e) -> add_expr bv e + | Pexp_pack m -> add_module_expr bv m + | Pexp_open (o, e) -> + let bv = open_declaration bv o in + add_expr bv e + | Pexp_letop {let_; ands; body} -> + let bv' = add_binding_op bv bv let_ in + let bv' = List.fold_left (add_binding_op bv) bv' ands in + add_expr bv' body + | Pexp_extension (({ txt = ("ocaml.extension_constructor"| + "extension_constructor"); _ }, + PStr [item]) as e) -> + begin match item.pstr_desc with + | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c + | _ -> handle_extension e + end + | Pexp_extension e -> handle_extension e + | Pexp_unreachable -> () + +and add_function_param bv param = + match param.pparam_desc with + | Pparam_val (_, opte, pat) -> + add_opt add_expr bv opte; + add_pattern bv pat + | Pparam_newtype _ -> bv + +and add_function_body bv body = + match body with + | Pfunction_body e -> + add_expr bv e + | Pfunction_cases (cases, _, _) -> + add_cases bv cases + +and add_constraint bv constraint_ = + match constraint_ with + | Pconstraint ty -> + add_type bv ty + | Pcoerce (ty1, ty2) -> + add_opt add_type bv ty1; + add_type bv ty2 + +and add_cases bv cases = + List.iter (add_case bv) cases + +and add_case bv {pc_lhs; pc_guard; pc_rhs} = + let bv = add_pattern bv pc_lhs in + add_opt add_expr bv pc_guard; + add_expr bv pc_rhs + +and add_bindings recf bv pel = + let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in + let bv = if recf = Recursive then bv' else bv in + let add_constraint = function + | Pvc_constraint {locally_abstract_univars=_; typ} -> + add_type bv typ + | Pvc_coercion { ground; coercion } -> + Option.iter (add_type bv) ground; + add_type bv coercion + in + let add_one_binding { pvb_pat= _ ; pvb_loc= _ ; pvb_constraint; pvb_expr } = + add_expr bv pvb_expr; + Option.iter add_constraint pvb_constraint + in + List.iter add_one_binding pel; + bv' + +and add_binding_op bv bv' pbop = + add_expr bv pbop.pbop_exp; + add_pattern bv' pbop.pbop_pat + +and add_modtype bv mty = + match mty.pmty_desc with + Pmty_ident l -> add bv l + | Pmty_alias l -> add_module_path bv l + | Pmty_signature s -> add_signature bv s + | Pmty_functor(param, mty2) -> + let bv = + match param with + | Unit -> bv + | Named (id, mty1) -> + add_modtype bv mty1; + match id.txt with + | None -> bv + | Some name -> String.Map.add name bound bv + in + add_modtype bv mty2 + | Pmty_with(mty, cstrl) -> + add_modtype bv mty; + List.iter + (function + | Pwith_type (_, td) -> add_type_declaration bv td + | Pwith_module (_, lid) -> add_module_path bv lid + | Pwith_modtype (_, mty) -> add_modtype bv mty + | Pwith_typesubst (_, td) -> add_type_declaration bv td + | Pwith_modsubst (_, lid) -> add_module_path bv lid + | Pwith_modtypesubst (_, mty) -> add_modtype bv mty + ) + cstrl + | Pmty_typeof m -> add_module_expr bv m + | Pmty_extension e -> handle_extension e + +and add_module_alias bv l = + (* If we are in delayed dependencies mode, we delay the dependencies + induced by "Lident s" *) + (if !Clflags.transparent_modules then add_parent else add_module_path) bv l; + try + lookup_map l.txt bv + with Not_found -> + match l.txt with + Lident s -> make_leaf s + | _ -> add_module_path bv l; bound (* cannot delay *) + +and add_modtype_binding bv mty = + match mty.pmty_desc with + Pmty_alias l -> + add_module_alias bv l + | Pmty_signature s -> + make_node (add_signature_binding bv s) + | Pmty_typeof modl -> + add_module_binding bv modl + | _ -> + add_modtype bv mty; bound + +and add_signature bv sg = + ignore (add_signature_binding bv sg) + +and add_signature_binding bv sg = + snd (List.fold_left add_sig_item (bv, String.Map.empty) sg) + +and add_sig_item (bv, m) item = + match item.psig_desc with + Psig_value vd -> + add_type bv vd.pval_type; (bv, m) + | Psig_type (_, dcls) + | Psig_typesubst dcls-> + List.iter (add_type_declaration bv) dcls; (bv, m) + | Psig_typext te -> + add_type_extension bv te; (bv, m) + | Psig_exception te -> + add_type_exception bv te; (bv, m) + | Psig_module pmd -> + let m' = add_modtype_binding bv pmd.pmd_type in + let add map = + match pmd.pmd_name.txt with + | None -> map + | Some name -> String.Map.add name m' map + in + (add bv, add m) + | Psig_modsubst pms -> + let m' = add_module_alias bv pms.pms_manifest in + let add = String.Map.add pms.pms_name.txt m' in + (add bv, add m) + | Psig_recmodule decls -> + let add = + List.fold_right (fun pmd map -> + match pmd.pmd_name.txt with + | None -> map + | Some name -> String.Map.add name bound map + ) decls + in + let bv' = add bv and m' = add m in + List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; + (bv', m') + | Psig_modtype x | Psig_modtypesubst x-> + begin match x.pmtd_type with + None -> () + | Some mty -> add_modtype bv mty + end; + (bv, m) + | Psig_open od -> + (open_description bv od, m) + | Psig_include incl -> + let Node (s, m') = add_modtype_binding bv incl.pincl_mod in + add_names s; + let add = String.Map.fold String.Map.add m' in + (add bv, add m) + | Psig_class cdl -> + List.iter (add_class_description bv) cdl; (bv, m) + | Psig_class_type cdtl -> + List.iter (add_class_type_declaration bv) cdtl; (bv, m) + | Psig_attribute _ -> (bv, m) + | Psig_extension (e, _) -> + handle_extension e; + (bv, m) + +and open_description bv od = + let Node(s, m) = add_module_alias bv od.popen_expr in + add_names s; + String.Map.fold String.Map.add m bv + +and open_declaration bv od = + let Node (s, m) = add_module_binding bv od.popen_expr in + add_names s; + String.Map.fold String.Map.add m bv + +and add_module_binding bv modl = + match modl.pmod_desc with + Pmod_ident l -> add_module_alias bv l + | Pmod_structure s -> + make_node (snd @@ add_structure_binding bv s) + | _ -> add_module_expr bv modl; bound + +and add_module_expr bv modl = + match modl.pmod_desc with + Pmod_ident l -> add_module_path bv l + | Pmod_structure s -> ignore (add_structure bv s) + | Pmod_functor(param, modl) -> + let bv = + match param with + | Unit -> bv + | Named (id, mty) -> + add_modtype bv mty; + match id.txt with + | None -> bv + | Some name -> String.Map.add name bound bv + in + add_module_expr bv modl + | Pmod_apply (mod1, mod2) -> + add_module_expr bv mod1; + add_module_expr bv mod2 + | Pmod_apply_unit mod1 -> + add_module_expr bv mod1 + | Pmod_constraint(modl, mty) -> + add_module_expr bv modl; add_modtype bv mty + | Pmod_unpack(e) -> + add_expr bv e + | Pmod_extension e -> + handle_extension e + +and add_class_type bv cty = + match cty.pcty_desc with + Pcty_constr(l, tyl) -> + add bv l; List.iter (add_type bv) tyl + | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> + add_type bv ty; + List.iter (add_class_type_field bv) fieldl + | Pcty_arrow(_, ty1, cty2) -> + add_type bv ty1; add_class_type bv cty2 + | Pcty_extension e -> handle_extension e + | Pcty_open (o, e) -> + let bv = open_description bv o in + add_class_type bv e + +and add_class_type_field bv pctf = + match pctf.pctf_desc with + Pctf_inherit cty -> add_class_type bv cty + | Pctf_val(_, _, _, ty) -> add_type bv ty + | Pctf_method(_, _, _, ty) -> add_type bv ty + | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pctf_attribute _ -> () + | Pctf_extension e -> handle_extension e + +and add_class_description bv infos = + add_class_type bv infos.pci_expr + +and add_class_type_declaration bv infos = add_class_description bv infos + +and add_structure bv item_list = + let (bv, m) = add_structure_binding bv item_list in + add_names (collect_free (make_node m)); + bv + +and add_structure_binding bv item_list = + List.fold_left add_struct_item (bv, String.Map.empty) item_list + +and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t = + match item.pstr_desc with + Pstr_eval (e, _attrs) -> + add_expr bv e; (bv, m) + | Pstr_value(rf, pel) -> + let bv = add_bindings rf bv pel in (bv, m) + | Pstr_primitive vd -> + add_type bv vd.pval_type; (bv, m) + | Pstr_type (_, dcls) -> + List.iter (add_type_declaration bv) dcls; (bv, m) + | Pstr_typext te -> + add_type_extension bv te; + (bv, m) + | Pstr_exception te -> + add_type_exception bv te; + (bv, m) + | Pstr_module x -> + let b = add_module_binding bv x.pmb_expr in + let add map = + match x.pmb_name.txt with + | None -> map + | Some name -> String.Map.add name b map + in + (add bv, add m) + | Pstr_recmodule bindings -> + let add = + List.fold_right (fun x map -> + match x.pmb_name.txt with + | None -> map + | Some name -> String.Map.add name bound map + ) bindings + in + let bv' = add bv and m = add m in + List.iter + (fun x -> add_module_expr bv' x.pmb_expr) + bindings; + (bv', m) + | Pstr_modtype x -> + begin match x.pmtd_type with + None -> () + | Some mty -> add_modtype bv mty + end; + (bv, m) + | Pstr_open od -> + (open_declaration bv od, m) + | Pstr_class cdl -> + List.iter (add_class_declaration bv) cdl; (bv, m) + | Pstr_class_type cdtl -> + List.iter (add_class_type_declaration bv) cdtl; (bv, m) + | Pstr_include incl -> + let Node (s, m') as n = add_module_binding bv incl.pincl_mod in + if !Clflags.transparent_modules then + add_names s + else + (* If we are not in the delayed dependency mode, we need to + collect all delayed dependencies imported by the include statement *) + add_names (collect_free n); + let add = String.Map.fold String.Map.add m' in + (add bv, add m) + | Pstr_attribute _ -> (bv, m) + | Pstr_extension (e, _) -> + handle_extension e; + (bv, m) + +and add_use_file bv top_phrs = + ignore (List.fold_left add_top_phrase bv top_phrs) + +and add_implementation bv l = + ignore (add_structure_binding bv l) + +and add_implementation_binding bv l = + snd (add_structure_binding bv l) + +and add_top_phrase bv = function + | Ptop_def str -> add_structure bv str + | Ptop_dir _ -> bv + +and add_class_expr bv ce = + match ce.pcl_desc with + Pcl_constr(l, tyl) -> + add bv l; List.iter (add_type bv) tyl + | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } -> + let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl + | Pcl_fun(_, opte, pat, ce) -> + add_opt add_expr bv opte; + let bv = add_pattern bv pat in add_class_expr bv ce + | Pcl_apply(ce, exprl) -> + add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl + | Pcl_let(rf, pel, ce) -> + let bv = add_bindings rf bv pel in add_class_expr bv ce + | Pcl_constraint(ce, ct) -> + add_class_expr bv ce; add_class_type bv ct + | Pcl_extension e -> handle_extension e + | Pcl_open (o, e) -> + let bv = open_description bv o in + add_class_expr bv e + +and add_class_field bv pcf = + match pcf.pcf_desc with + Pcf_inherit(_, ce, _) -> add_class_expr bv ce + | Pcf_val(_, _, Cfk_concrete (_, e)) + | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e + | Pcf_val(_, _, Cfk_virtual ty) + | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty + | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pcf_initializer e -> add_expr bv e + | Pcf_attribute _ -> () + | Pcf_extension e -> handle_extension e + +and add_class_declaration bv decl = + add_class_expr bv decl.pci_expr diff --git a/upstream/ocaml_503/parsing/depend.mli b/upstream/ocaml_503/parsing/depend.mli new file mode 100644 index 000000000..745cc722c --- /dev/null +++ b/upstream/ocaml_503/parsing/depend.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Module dependencies. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +module String = Misc.Stdlib.String + +type map_tree = Node of String.Set.t * bound_map +and bound_map = map_tree String.Map.t +val make_leaf : string -> map_tree +val make_node : bound_map -> map_tree +val weaken_map : String.Set.t -> map_tree -> map_tree + +(** Collect free module identifiers in the a.s.t. *) +val free_structure_names : String.Set.t ref + +(** Dependencies found by preprocessing tools. *) +val pp_deps : string list ref + +val open_module : bound_map -> Longident.t -> bound_map + +val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit + +val add_signature : bound_map -> Parsetree.signature -> unit + +val add_implementation : bound_map -> Parsetree.structure -> unit + +val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map +val add_signature_binding : bound_map -> Parsetree.signature -> bound_map diff --git a/upstream/ocaml_503/parsing/docstrings.ml b/upstream/ocaml_503/parsing/docstrings.ml new file mode 100644 index 000000000..32b8e8c46 --- /dev/null +++ b/upstream/ocaml_503/parsing/docstrings.ml @@ -0,0 +1,427 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Leo White *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Location + +(* Docstrings *) + +(* A docstring is "attached" if it has been inserted in the AST. This + is used for generating unexpected docstring warnings. *) +type ds_attached = + | Unattached (* Not yet attached anything.*) + | Info (* Attached to a field or constructor. *) + | Docs (* Attached to an item or as floating text. *) + +(* A docstring is "associated" with an item if there are no blank lines between + them. This is used for generating docstring ambiguity warnings. *) +type ds_associated = + | Zero (* Not associated with an item *) + | One (* Associated with one item *) + | Many (* Associated with multiple items (ambiguity) *) + +type docstring = + { ds_body: string; + ds_loc: Location.t; + mutable ds_attached: ds_attached; + mutable ds_associated: ds_associated; } + +(* List of docstrings *) + +let docstrings : docstring list ref = ref [] + +(* Warn for unused and ambiguous docstrings *) + +let warn_bad_docstrings () = + if Warnings.is_active (Warnings.Unexpected_docstring true) then begin + List.iter + (fun ds -> + match ds.ds_attached with + | Info -> () + | Unattached -> + prerr_warning ds.ds_loc (Warnings.Unexpected_docstring true) + | Docs -> + match ds.ds_associated with + | Zero | One -> () + | Many -> + prerr_warning ds.ds_loc (Warnings.Unexpected_docstring false)) + (List.rev !docstrings) +end + +(* Docstring constructors and destructors *) + +let docstring body loc = + let ds = + { ds_body = body; + ds_loc = loc; + ds_attached = Unattached; + ds_associated = Zero; } + in + ds + +let register ds = + docstrings := ds :: !docstrings + +let docstring_body ds = ds.ds_body + +let docstring_loc ds = ds.ds_loc + +(* Docstrings attached to items *) + +type docs = + { docs_pre: docstring option; + docs_post: docstring option; } + +let empty_docs = { docs_pre = None; docs_post = None } + +let doc_loc = {txt = "ocaml.doc"; loc = Location.none} + +let docs_attr ds = + let open Parsetree in + let body = ds.ds_body in + let loc = ds.ds_loc in + let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in + let exp = + { pexp_desc = Pexp_constant const; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; } + in + let item = + { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } + in + { attr_name = doc_loc; + attr_payload = PStr [item]; + attr_loc = loc } + +let add_docs_attrs docs attrs = + let attrs = + match docs.docs_pre with + | None | Some { ds_body=""; _ } -> attrs + | Some ds -> docs_attr ds :: attrs + in + let attrs = + match docs.docs_post with + | None | Some { ds_body=""; _ } -> attrs + | Some ds -> attrs @ [docs_attr ds] + in + attrs + +(* Docstrings attached to constructors or fields *) + +type info = docstring option + +let empty_info = None + +let info_attr = docs_attr + +let add_info_attrs info attrs = + match info with + | None | Some {ds_body=""; _} -> attrs + | Some ds -> attrs @ [info_attr ds] + +(* Docstrings not attached to a specific item *) + +type text = docstring list + +let empty_text = [] +let empty_text_lazy = lazy [] + +let text_loc = {txt = "ocaml.text"; loc = Location.none} + +let text_attr ds = + let open Parsetree in + let body = ds.ds_body in + let loc = ds.ds_loc in + let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in + let exp = + { pexp_desc = Pexp_constant const; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; } + in + let item = + { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } + in + { attr_name = text_loc; + attr_payload = PStr [item]; + attr_loc = loc } + +let add_text_attrs dsl attrs = + let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in + (List.map text_attr fdsl) @ attrs + +(* Find the first non-info docstring in a list, attach it and return it *) +let get_docstring ~info dsl = + let rec loop = function + | [] -> None + | {ds_attached = Info; _} :: rest -> loop rest + | ds :: _ -> + ds.ds_attached <- if info then Info else Docs; + Some ds + in + loop dsl + +(* Find all the non-info docstrings in a list, attach them and return them *) +let get_docstrings dsl = + let rec loop acc = function + | [] -> List.rev acc + | {ds_attached = Info; _} :: rest -> loop acc rest + | ds :: rest -> + ds.ds_attached <- Docs; + loop (ds :: acc) rest + in + loop [] dsl + +(* "Associate" all the docstrings in a list *) +let associate_docstrings dsl = + List.iter + (fun ds -> + match ds.ds_associated with + | Zero -> ds.ds_associated <- One + | (One | Many) -> ds.ds_associated <- Many) + dsl + +(* Map from positions to pre docstrings *) + +let pre_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_pre_docstrings pos dsl = + if dsl <> [] then Hashtbl.add pre_table pos dsl + +let get_pre_docs pos = + try + let dsl = Hashtbl.find pre_table pos in + associate_docstrings dsl; + get_docstring ~info:false dsl + with Not_found -> None + +let mark_pre_docs pos = + try + let dsl = Hashtbl.find pre_table pos in + associate_docstrings dsl + with Not_found -> () + +(* Map from positions to post docstrings *) + +let post_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_post_docstrings pos dsl = + if dsl <> [] then Hashtbl.add post_table pos dsl + +let get_post_docs pos = + try + let dsl = Hashtbl.find post_table pos in + associate_docstrings dsl; + get_docstring ~info:false dsl + with Not_found -> None + +let mark_post_docs pos = + try + let dsl = Hashtbl.find post_table pos in + associate_docstrings dsl + with Not_found -> () + +let get_info pos = + try + let dsl = Hashtbl.find post_table pos in + get_docstring ~info:true dsl + with Not_found -> None + +(* Map from positions to floating docstrings *) + +let floating_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_floating_docstrings pos dsl = + if dsl <> [] then Hashtbl.add floating_table pos dsl + +let get_text pos = + try + let dsl = Hashtbl.find floating_table pos in + get_docstrings dsl + with Not_found -> [] + +let get_post_text pos = + try + let dsl = Hashtbl.find post_table pos in + get_docstrings dsl + with Not_found -> [] + +(* Maps from positions to extra docstrings *) + +let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_pre_extra_docstrings pos dsl = + if dsl <> [] then Hashtbl.add pre_extra_table pos dsl + +let get_pre_extra_text pos = + try + let dsl = Hashtbl.find pre_extra_table pos in + get_docstrings dsl + with Not_found -> [] + +let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_post_extra_docstrings pos dsl = + if dsl <> [] then Hashtbl.add post_extra_table pos dsl + +let get_post_extra_text pos = + try + let dsl = Hashtbl.find post_extra_table pos in + get_docstrings dsl + with Not_found -> [] + +(* Docstrings from parser actions *) +module WithParsing = struct +let symbol_docs () = + { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); + docs_post = get_post_docs (Parsing.symbol_end_pos ()); } + +let symbol_docs_lazy () = + let p1 = Parsing.symbol_start_pos () in + let p2 = Parsing.symbol_end_pos () in + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let rhs_docs pos1 pos2 = + { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); + docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } + +let rhs_docs_lazy pos1 pos2 = + let p1 = Parsing.rhs_start_pos pos1 in + let p2 = Parsing.rhs_end_pos pos2 in + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let mark_symbol_docs () = + mark_pre_docs (Parsing.symbol_start_pos ()); + mark_post_docs (Parsing.symbol_end_pos ()) + +let mark_rhs_docs pos1 pos2 = + mark_pre_docs (Parsing.rhs_start_pos pos1); + mark_post_docs (Parsing.rhs_end_pos pos2) + +let symbol_info () = + get_info (Parsing.symbol_end_pos ()) + +let rhs_info pos = + get_info (Parsing.rhs_end_pos pos) + +let symbol_text () = + get_text (Parsing.symbol_start_pos ()) + +let symbol_text_lazy () = + let pos = Parsing.symbol_start_pos () in + lazy (get_text pos) + +let rhs_text pos = + get_text (Parsing.rhs_start_pos pos) + +let rhs_post_text pos = + get_post_text (Parsing.rhs_end_pos pos) + +let rhs_text_lazy pos = + let pos = Parsing.rhs_start_pos pos in + lazy (get_text pos) + +let symbol_pre_extra_text () = + get_pre_extra_text (Parsing.symbol_start_pos ()) + +let symbol_post_extra_text () = + get_post_extra_text (Parsing.symbol_end_pos ()) + +let rhs_pre_extra_text pos = + get_pre_extra_text (Parsing.rhs_start_pos pos) + +let rhs_post_extra_text pos = + get_post_extra_text (Parsing.rhs_end_pos pos) +end + +include WithParsing + +module WithMenhir = struct +let symbol_docs (startpos, endpos) = + { docs_pre = get_pre_docs startpos; + docs_post = get_post_docs endpos; } + +let symbol_docs_lazy (p1, p2) = + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let rhs_docs pos1 pos2 = + { docs_pre = get_pre_docs pos1; + docs_post = get_post_docs pos2; } + +let rhs_docs_lazy p1 p2 = + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let mark_symbol_docs (startpos, endpos) = + mark_pre_docs startpos; + mark_post_docs endpos; + () + +let mark_rhs_docs pos1 pos2 = + mark_pre_docs pos1; + mark_post_docs pos2; + () + +let symbol_info endpos = + get_info endpos + +let rhs_info endpos = + get_info endpos + +let symbol_text startpos = + get_text startpos + +let symbol_text_lazy startpos = + lazy (get_text startpos) + +let rhs_text pos = + get_text pos + +let rhs_post_text pos = + get_post_text pos + +let rhs_text_lazy pos = + lazy (get_text pos) + +let symbol_pre_extra_text startpos = + get_pre_extra_text startpos + +let symbol_post_extra_text endpos = + get_post_extra_text endpos + +let rhs_pre_extra_text pos = + get_pre_extra_text pos + +let rhs_post_extra_text pos = + get_post_extra_text pos +end + +(* (Re)Initialise all comment state *) + +let init () = + docstrings := []; + Hashtbl.reset pre_table; + Hashtbl.reset post_table; + Hashtbl.reset floating_table; + Hashtbl.reset pre_extra_table; + Hashtbl.reset post_extra_table diff --git a/upstream/ocaml_503/parsing/docstrings.mli b/upstream/ocaml_503/parsing/docstrings.mli new file mode 100644 index 000000000..bf2508fdc --- /dev/null +++ b/upstream/ocaml_503/parsing/docstrings.mli @@ -0,0 +1,223 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Leo White *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Documentation comments + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +(** (Re)Initialise all docstring state *) +val init : unit -> unit + +(** Emit warnings for unattached and ambiguous docstrings *) +val warn_bad_docstrings : unit -> unit + +(** {2 Docstrings} *) + +(** Documentation comments *) +type docstring + +(** Create a docstring *) +val docstring : string -> Location.t -> docstring + +(** Register a docstring *) +val register : docstring -> unit + +(** Get the text of a docstring *) +val docstring_body : docstring -> string + +(** Get the location of a docstring *) +val docstring_loc : docstring -> Location.t + +(** {2 Set functions} + + These functions are used by the lexer to associate docstrings to + the locations of tokens. *) + +(** Docstrings immediately preceding a token *) +val set_pre_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately following a token *) +val set_post_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings not immediately adjacent to a token *) +val set_floating_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately following the token which precedes this one *) +val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately preceding the token which follows this one *) +val set_post_extra_docstrings : Lexing.position -> docstring list -> unit + +(** {2 Items} + + The {!docs} type represents documentation attached to an item. *) + +type docs = + { docs_pre: docstring option; + docs_post: docstring option; } + +val empty_docs : docs + +val docs_attr : docstring -> Parsetree.attribute + +(** Convert item documentation to attributes and add them to an + attribute list *) +val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the item documentation for the current symbol. This also + marks this documentation (for ambiguity warnings). *) +val symbol_docs : unit -> docs +val symbol_docs_lazy : unit -> docs Lazy.t + +(** Fetch the item documentation for the symbols between two + positions. This also marks this documentation (for ambiguity + warnings). *) +val rhs_docs : int -> int -> docs +val rhs_docs_lazy : int -> int -> docs Lazy.t + +(** Mark the item documentation for the current symbol (for ambiguity + warnings). *) +val mark_symbol_docs : unit -> unit + +(** Mark as associated the item documentation for the symbols between + two positions (for ambiguity warnings) *) +val mark_rhs_docs : int -> int -> unit + +(** {2 Fields and constructors} + + The {!info} type represents documentation attached to a field or + constructor. *) + +type info = docstring option + +val empty_info : info + +val info_attr : docstring -> Parsetree.attribute + +(** Convert field info to attributes and add them to an + attribute list *) +val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the field info for the current symbol. *) +val symbol_info : unit -> info + +(** Fetch the field info following the symbol at a given position. *) +val rhs_info : int -> info + +(** {2 Unattached comments} + + The {!text} type represents documentation which is not attached to + anything. *) + +type text = docstring list + +val empty_text : text +val empty_text_lazy : text Lazy.t + +val text_attr : docstring -> Parsetree.attribute + +(** Convert text to attributes and add them to an attribute list *) +val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the text preceding the current symbol. *) +val symbol_text : unit -> text +val symbol_text_lazy : unit -> text Lazy.t + +(** Fetch the text preceding the symbol at the given position. *) +val rhs_text : int -> text +val rhs_text_lazy : int -> text Lazy.t + +(** {2 Extra text} + + There may be additional text attached to the delimiters of a block + (e.g. [struct] and [end]). This is fetched by the following + functions, which are applied to the contents of the block rather + than the delimiters. *) + +(** Fetch additional text preceding the current symbol *) +val symbol_pre_extra_text : unit -> text + +(** Fetch additional text following the current symbol *) +val symbol_post_extra_text : unit -> text + +(** Fetch additional text preceding the symbol at the given position *) +val rhs_pre_extra_text : int -> text + +(** Fetch additional text following the symbol at the given position *) +val rhs_post_extra_text : int -> text + +(** Fetch text following the symbol at the given position *) +val rhs_post_text : int -> text + +module WithMenhir: sig +(** Fetch the item documentation for the current symbol. This also + marks this documentation (for ambiguity warnings). *) +val symbol_docs : Lexing.position * Lexing.position -> docs +val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t + +(** Fetch the item documentation for the symbols between two + positions. This also marks this documentation (for ambiguity + warnings). *) +val rhs_docs : Lexing.position -> Lexing.position -> docs +val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t + +(** Mark the item documentation for the current symbol (for ambiguity + warnings). *) +val mark_symbol_docs : Lexing.position * Lexing.position -> unit + +(** Mark as associated the item documentation for the symbols between + two positions (for ambiguity warnings) *) +val mark_rhs_docs : Lexing.position -> Lexing.position -> unit + +(** Fetch the field info for the current symbol. *) +val symbol_info : Lexing.position -> info + +(** Fetch the field info following the symbol at a given position. *) +val rhs_info : Lexing.position -> info + +(** Fetch the text preceding the current symbol. *) +val symbol_text : Lexing.position -> text +val symbol_text_lazy : Lexing.position -> text Lazy.t + +(** Fetch the text preceding the symbol at the given position. *) +val rhs_text : Lexing.position -> text +val rhs_text_lazy : Lexing.position -> text Lazy.t + +(** {3 Extra text} + + There may be additional text attached to the delimiters of a block + (e.g. [struct] and [end]). This is fetched by the following + functions, which are applied to the contents of the block rather + than the delimiters. *) + +(** Fetch additional text preceding the current symbol *) +val symbol_pre_extra_text : Lexing.position -> text + +(** Fetch additional text following the current symbol *) +val symbol_post_extra_text : Lexing.position -> text + +(** Fetch additional text preceding the symbol at the given position *) +val rhs_pre_extra_text : Lexing.position -> text + +(** Fetch additional text following the symbol at the given position *) +val rhs_post_extra_text : Lexing.position -> text + +(** Fetch text following the symbol at the given position *) +val rhs_post_text : Lexing.position -> text + +end diff --git a/upstream/ocaml_503/parsing/lexer.mli b/upstream/ocaml_503/parsing/lexer.mli new file mode 100644 index 000000000..3d4bbc461 --- /dev/null +++ b/upstream/ocaml_503/parsing/lexer.mli @@ -0,0 +1,70 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** The lexical analyzer + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +val init : unit -> unit +val token: Lexing.lexbuf -> Parser.token +val skip_hash_bang: Lexing.lexbuf -> unit + +type error = + | Illegal_character of char + | Illegal_escape of string * string option + | Reserved_sequence of string * string option + | Unterminated_comment of Location.t + | Unterminated_string + | Unterminated_string_in_comment of Location.t * Location.t + | Empty_character_literal + | Keyword_as_label of string + | Capitalized_label of string + | Invalid_literal of string + | Invalid_directive of string * string option + | Invalid_encoding of string + | Invalid_char_in_ident of Uchar.t + | Non_lowercase_delimiter of string + | Capitalized_raw_identifier of string + +exception Error of error * Location.t + +val in_comment : unit -> bool +val in_string : unit -> bool + +val is_keyword : string -> bool + +val print_warnings : bool ref +val handle_docstrings: bool ref +val comments : unit -> (string * Location.t) list +val token_with_comments : Lexing.lexbuf -> Parser.token + +(* + [set_preprocessor init preprocessor] registers [init] as the function +to call to initialize the preprocessor when the lexer is initialized, +and [preprocessor] a function that is called when a new token is needed +by the parser, as [preprocessor lexer lexbuf] where [lexer] is the +lexing function. + +When a preprocessor is configured by calling [set_preprocessor], the lexer +changes its behavior to accept backslash-newline as a token-separating blank. +*) + +val set_preprocessor : + (unit -> unit) -> + ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) -> + unit diff --git a/upstream/ocaml_503/parsing/lexer.mll b/upstream/ocaml_503/parsing/lexer.mll new file mode 100644 index 000000000..ddd970b11 --- /dev/null +++ b/upstream/ocaml_503/parsing/lexer.mll @@ -0,0 +1,975 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* The lexer definition *) + +{ +open Lexing +open Misc +open Parser + +type error = + | Illegal_character of char + | Illegal_escape of string * string option + | Reserved_sequence of string * string option + | Unterminated_comment of Location.t + | Unterminated_string + | Unterminated_string_in_comment of Location.t * Location.t + | Empty_character_literal + | Keyword_as_label of string + | Capitalized_label of string + | Invalid_literal of string + | Invalid_directive of string * string option + | Invalid_encoding of string + | Invalid_char_in_ident of Uchar.t + | Non_lowercase_delimiter of string + | Capitalized_raw_identifier of string + +exception Error of error * Location.t + +(* The table of keywords *) + +let keyword_table = + create_hashtable 149 [ + "and", AND; + "as", AS; + "assert", ASSERT; + "begin", BEGIN; + "class", CLASS; + "constraint", CONSTRAINT; + "do", DO; + "done", DONE; + "downto", DOWNTO; + "effect", EFFECT; + "else", ELSE; + "end", END; + "exception", EXCEPTION; + "external", EXTERNAL; + "false", FALSE; + "for", FOR; + "fun", FUN; + "function", FUNCTION; + "functor", FUNCTOR; + "if", IF; + "in", IN; + "include", INCLUDE; + "inherit", INHERIT; + "initializer", INITIALIZER; + "lazy", LAZY; + "let", LET; + "match", MATCH; + "method", METHOD; + "module", MODULE; + "mutable", MUTABLE; + "new", NEW; + "nonrec", NONREC; + "object", OBJECT; + "of", OF; + "open", OPEN; + "or", OR; +(* "parser", PARSER; *) + "private", PRIVATE; + "rec", REC; + "sig", SIG; + "struct", STRUCT; + "then", THEN; + "to", TO; + "true", TRUE; + "try", TRY; + "type", TYPE; + "val", VAL; + "virtual", VIRTUAL; + "when", WHEN; + "while", WHILE; + "with", WITH; + + "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) + "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) + "mod", INFIXOP3("mod"); + "land", INFIXOP3("land"); + "lsl", INFIXOP4("lsl"); + "lsr", INFIXOP4("lsr"); + "asr", INFIXOP4("asr") +] + +(* To buffer string literals *) + +let string_buffer = Buffer.create 256 +let reset_string_buffer () = Buffer.reset string_buffer +let get_stored_string () = Buffer.contents string_buffer + +let store_string_char c = Buffer.add_char string_buffer c +let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u +let store_string s = Buffer.add_string string_buffer s +let store_substring s ~pos ~len = Buffer.add_substring string_buffer s pos len + +let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf) +let store_normalized_newline newline = + (* #12502: we normalize "\r\n" to "\n" at lexing time, + to avoid behavior difference due to OS-specific + newline characters in string literals. + + (For example, Git for Windows will translate \n in versioned + files into \r\n sequences when checking out files on Windows. If + your code contains multiline quoted string literals, the raw + content of the string literal would be different between Git for + Windows users and all other users. Thanks to newline + normalization, the value of the literal as a string constant will + be the same no matter which programming tools are used.) + + Many programming languages use the same approach, for example + Java, Javascript, Kotlin, Python, Swift and C++. + *) + (* Our 'newline' regexp accepts \r*\n, but we only wish + to normalize \r?\n into \n -- see the discussion in #12502. + All carriage returns except for the (optional) last one + are reproduced in the output. We implement this by skipping + the first carriage return, if any. *) + let len = String.length newline in + if len = 1 + then store_string_char '\n' + else store_substring newline ~pos:1 ~len:(len - 1) + +(* To store the position of the beginning of a string and comment *) +let string_start_loc = ref Location.none +let comment_start_loc = ref [] +let in_comment () = !comment_start_loc <> [] +let is_in_string = ref false +let in_string () = !is_in_string +let print_warnings = ref true + +(* Escaped chars are interpreted in strings unless they are in comments. *) +let store_escaped_char lexbuf c = + if in_comment () then store_lexeme lexbuf else store_string_char c + +let store_escaped_uchar lexbuf u = + if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u + +let compute_quoted_string_idloc {Location.loc_start = orig_loc } shift id = + let id_start_pos = orig_loc.Lexing.pos_cnum + shift in + let loc_start = + Lexing.{orig_loc with pos_cnum = id_start_pos } + in + let loc_end = + Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id} + in + {Location. loc_start ; loc_end ; loc_ghost = false } + +let wrap_string_lexer f lexbuf = + let loc_start = lexbuf.lex_curr_p in + reset_string_buffer(); + is_in_string := true; + let string_start = lexbuf.lex_start_p in + string_start_loc := Location.curr lexbuf; + let loc_end = f lexbuf in + is_in_string := false; + lexbuf.lex_start_p <- string_start; + let loc = Location.{loc_ghost= false; loc_start; loc_end} in + get_stored_string (), loc + +let wrap_comment_lexer comment lexbuf = + let start_loc = Location.curr lexbuf in + comment_start_loc := [start_loc]; + reset_string_buffer (); + let end_loc = comment lexbuf in + let s = get_stored_string () in + reset_string_buffer (); + s, + { start_loc with Location.loc_end = end_loc.Location.loc_end } + +let error lexbuf e = raise (Error(e, Location.curr lexbuf)) +let error_loc loc e = raise (Error(e, loc)) + +(* to translate escape sequences *) + +let digit_value c = + match c with + | 'a' .. 'f' -> 10 + Char.code c - Char.code 'a' + | 'A' .. 'F' -> 10 + Char.code c - Char.code 'A' + | '0' .. '9' -> Char.code c - Char.code '0' + | _ -> assert false + +let num_value lexbuf ~base ~first ~last = + let c = ref 0 in + for i = first to last do + let v = digit_value (Lexing.lexeme_char lexbuf i) in + assert(v < base); + c := (base * !c) + v + done; + !c + +let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let illegal_escape lexbuf reason = + let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in + raise (Error (error, Location.curr lexbuf)) + +let char_for_decimal_code lexbuf i = + let c = num_value lexbuf ~base:10 ~first:i ~last:(i+2) in + if (c < 0 || c > 255) then + if in_comment () + then 'x' + else + illegal_escape lexbuf + (Printf.sprintf + "%d is outside the range of legal characters (0-255)." c) + else Char.chr c + +let char_for_octal_code lexbuf i = + let c = num_value lexbuf ~base:8 ~first:i ~last:(i+2) in + if (c < 0 || c > 255) then + if in_comment () + then 'x' + else + illegal_escape lexbuf + (Printf.sprintf + "o%o (=%d) is outside the range of legal characters (0-255)." c c) + else Char.chr c + +let char_for_hexadecimal_code lexbuf i = + Char.chr (num_value lexbuf ~base:16 ~first:i ~last:(i+1)) + +let uchar_for_uchar_escape lexbuf = + let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in + let first = 3 (* skip opening \u{ *) in + let last = len - 2 (* skip closing } *) in + let digit_count = last - first + 1 in + match digit_count > 6 with + | true -> + illegal_escape lexbuf + "too many digits, expected 1 to 6 hexadecimal digits" + | false -> + let cp = num_value lexbuf ~base:16 ~first ~last in + if Uchar.is_valid cp then Uchar.unsafe_of_int cp else + illegal_escape lexbuf + (Printf.sprintf "%X is not a Unicode scalar value" cp) + +let validate_encoding lexbuf raw_name = + match Utf8_lexeme.normalize raw_name with + | Error _ -> error lexbuf (Invalid_encoding raw_name) + | Ok name -> name + +let ident_for_extended lexbuf raw_name = + let name = validate_encoding lexbuf raw_name in + match Utf8_lexeme.validate_identifier name with + | Utf8_lexeme.Valid -> name + | Utf8_lexeme.Invalid_character u -> error lexbuf (Invalid_char_in_ident u) + | Utf8_lexeme.Invalid_beginning _ -> + assert false (* excluded by the regexps *) + +let validate_delim lexbuf raw_name = + let name = validate_encoding lexbuf raw_name in + if Utf8_lexeme.is_lowercase name then name + else error lexbuf (Non_lowercase_delimiter name) + +let validate_ext lexbuf name = + let name = validate_encoding lexbuf name in + match Utf8_lexeme.validate_identifier ~with_dot:true name with + | Utf8_lexeme.Valid -> name + | Utf8_lexeme.Invalid_character u -> error lexbuf (Invalid_char_in_ident u) + | Utf8_lexeme.Invalid_beginning _ -> + assert false (* excluded by the regexps *) + +let lax_delim raw_name = + match Utf8_lexeme.normalize raw_name with + | Error _ -> None + | Ok name -> + if Utf8_lexeme.is_lowercase name then Some name + else None + +let is_keyword name = Hashtbl.mem keyword_table name + +let check_label_name ?(raw_escape=false) lexbuf name = + if Utf8_lexeme.is_capitalized name then + error lexbuf (Capitalized_label name); + if not raw_escape && is_keyword name then + error lexbuf (Keyword_as_label name) + +(* Update the current location with file name and line number. *) + +let update_loc lexbuf file line absolute chars = + let pos = lexbuf.lex_curr_p in + let new_file = match file with + | None -> pos.pos_fname + | Some s -> s + in + lexbuf.lex_curr_p <- { pos with + pos_fname = new_file; + pos_lnum = if absolute then line else pos.pos_lnum + line; + pos_bol = pos.pos_cnum - chars; + } + +let preprocessor = ref None + +let escaped_newlines = ref false + +let handle_docstrings = ref true +let comment_list = ref [] + +let add_comment com = + comment_list := com :: !comment_list + +let add_docstring_comment ds = + let com = + ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds) + in + add_comment com + +let comments () = List.rev !comment_list + +(* Error report *) + +open Format_doc + +let prepare_error loc = function + | Illegal_character c -> + Location.errorf ~loc "Illegal character (%s)" (Char.escaped c) + | Illegal_escape (s, explanation) -> + Location.errorf ~loc + "Illegal backslash escape in string or character (%s)%t" s + (fun ppf -> match explanation with + | None -> () + | Some expl -> fprintf ppf ": %s" expl) + | Reserved_sequence (s, explanation) -> + Location.errorf ~loc + "Reserved character sequence: %s%t" s + (fun ppf -> match explanation with + | None -> () + | Some expl -> fprintf ppf " %s" expl) + | Unterminated_comment _ -> + Location.errorf ~loc "Comment not terminated" + | Unterminated_string -> + Location.errorf ~loc "String literal not terminated" + | Unterminated_string_in_comment (_, literal_loc) -> + Location.errorf ~loc + "This comment contains an unterminated string literal" + ~sub:[Location.msg ~loc:literal_loc "String literal begins here"] + | Empty_character_literal -> + let msg = "Illegal empty character literal ''" in + let sub = + [Location.msg + "@{Hint@}: Did you mean ' ' or a type variable 'a?"] in + Location.error ~loc ~sub msg + | Keyword_as_label kwd -> + Location.errorf ~loc + "%a is a keyword, it cannot be used as label name" Style.inline_code kwd + | Capitalized_label lbl -> + Location.errorf ~loc + "%a cannot be used as label name, \ + it must start with a lowercase letter" Style.inline_code lbl + | Invalid_literal s -> + Location.errorf ~loc "Invalid literal %s" s + | Invalid_directive (dir, explanation) -> + Location.errorf ~loc "Invalid lexer directive %S%t" dir + (fun ppf -> match explanation with + | None -> () + | Some expl -> fprintf ppf ": %s" expl) + | Invalid_encoding s -> + Location.errorf ~loc "Invalid encoding of identifier %s." s + | Invalid_char_in_ident u -> + Location.errorf ~loc "Invalid character U+%X in identifier" + (Uchar.to_int u) + | Capitalized_raw_identifier lbl -> + Location.errorf ~loc + "%a cannot be used as a raw identifier, \ + it must start with a lowercase letter" Style.inline_code lbl + | Non_lowercase_delimiter name -> + Location.errorf ~loc + "%a cannot be used as a quoted string delimiter,@ \ + it must contain only lowercase letters." + Style.inline_code name + +let () = + Location.register_error_of_exn + (function + | Error (err, loc) -> + Some (prepare_error loc err) + | _ -> + None + ) + +} + +let newline = ('\013'* '\010') +let blank = [' ' '\009' '\012'] +let lowercase = ['a'-'z' '_'] +let uppercase = ['A'-'Z'] +let identstart = lowercase | uppercase +let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] +let utf8 = ['\192'-'\255'] ['\128'-'\191']* +let identstart_ext = identstart | utf8 +let identchar_ext = identchar | utf8 + +let symbolchar = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] +let dotsymbolchar = + ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|'] +let symbolchar_or_hash = + symbolchar | '#' +let kwdopchar = + ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|'] + +let ident = (lowercase | uppercase) identchar* +let ident_ext = identstart_ext identchar_ext* +let extattrident = ident_ext ('.' ident_ext)* + +let decimal_literal = + ['0'-'9'] ['0'-'9' '_']* +let hex_digit = + ['0'-'9' 'A'-'F' 'a'-'f'] +let hex_literal = + '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* +let oct_literal = + '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* +let bin_literal = + '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* +let int_literal = + decimal_literal | hex_literal | oct_literal | bin_literal +let float_literal = + ['0'-'9'] ['0'-'9' '_']* + ('.' ['0'-'9' '_']* )? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? +let hex_float_literal = + '0' ['x' 'X'] + ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']* + ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? + (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? +let literal_modifier = ['G'-'Z' 'g'-'z'] +let raw_ident_escape = "\\#" + +rule token = parse + | ('\\' as bs) newline { + if not !escaped_newlines then error lexbuf (Illegal_character bs); + update_loc lexbuf None 1 false 0; + token lexbuf } + | newline + { update_loc lexbuf None 1 false 0; + EOL } + | blank + + { token lexbuf } + | "_" + { UNDERSCORE } + | "~" + { TILDE } + | ".~" + { error lexbuf + (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } + | "~" (identstart identchar * as name) ':' + { check_label_name lexbuf name; + LABEL name } + | "~" (raw_ident_escape? as escape) (ident_ext as raw_name) ':' + { let name = ident_for_extended lexbuf raw_name in + check_label_name ~raw_escape:(escape<>"") lexbuf name; + LABEL name } + | "?" + { QUESTION } + | "?" (lowercase identchar * as name) ':' + { check_label_name lexbuf name; + OPTLABEL name } + | "?" (raw_ident_escape? as escape) (ident_ext as raw_name) ':' + { let name = ident_for_extended lexbuf raw_name in + check_label_name ~raw_escape:(escape<>"") lexbuf name; + OPTLABEL name + } + | lowercase identchar * as name + { try Hashtbl.find keyword_table name + with Not_found -> LIDENT name } + | uppercase identchar * as name + { UIDENT name } (* No capitalized keywords *) + | (raw_ident_escape? as escape) (ident_ext as raw_name) + { let name = ident_for_extended lexbuf raw_name in + if Utf8_lexeme.is_capitalized name then begin + if escape="" then UIDENT name + else + (* we don't have capitalized keywords, and thus no needs for + capitalized raw identifiers. *) + error lexbuf (Capitalized_raw_identifier name) + end else + LIDENT name + } (* No non-ascii keywords *) + | int_literal as lit { INT (lit, None) } + | (int_literal as lit) (literal_modifier as modif) + { INT (lit, Some modif) } + | float_literal | hex_float_literal as lit + { FLOAT (lit, None) } + | (float_literal | hex_float_literal as lit) (literal_modifier as modif) + { FLOAT (lit, Some modif) } + | (float_literal | hex_float_literal | int_literal) identchar+ as invalid + { error lexbuf (Invalid_literal invalid) } + | "\"" + { let s, loc = wrap_string_lexer string lexbuf in + STRING (s, loc, None) } + | "{" (ident_ext? as raw_name) '|' + { let delim = validate_delim lexbuf raw_name in + let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in + STRING (s, loc, Some delim) + } + | "{%" (extattrident as raw_id) "|" + { let orig_loc = Location.curr lexbuf in + let id = validate_ext lexbuf raw_id in + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in + let idloc = compute_quoted_string_idloc orig_loc 2 id in + QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") } + | "{%" (extattrident as raw_id) blank+ (ident_ext as raw_delim) "|" + { let orig_loc = Location.curr lexbuf in + let id = validate_ext lexbuf raw_id in + let delim = validate_delim lexbuf raw_delim in + let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in + let idloc = compute_quoted_string_idloc orig_loc 2 id in + QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) } + | "{%%" (extattrident as raw_id) "|" + { let orig_loc = Location.curr lexbuf in + let id = validate_ext lexbuf raw_id in + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in + let idloc = compute_quoted_string_idloc orig_loc 3 id in + QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") } + | "{%%" (extattrident as raw_id) blank+ (ident_ext as raw_delim) "|" + { let orig_loc = Location.curr lexbuf in + let id = validate_ext lexbuf raw_id in + let delim = validate_delim lexbuf raw_delim in + let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in + let idloc = compute_quoted_string_idloc orig_loc 3 id in + QUOTED_STRING_ITEM (id, idloc, s, loc, Some delim) } + | "\'" newline "\'" + { update_loc lexbuf None 1 false 1; + (* newline is ('\013'* '\010') *) + CHAR '\n' } + | "\'" ([^ '\\' '\'' '\010' '\013'] as c) "\'" + { CHAR c } + | "\'\\" (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) "\'" + { CHAR (char_for_backslash c) } + | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" + { CHAR(char_for_decimal_code lexbuf 2) } + | "\'\\" 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] "\'" + { CHAR(char_for_octal_code lexbuf 3) } + | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" + { CHAR(char_for_hexadecimal_code lexbuf 3) } + | "\'" ("\\" [^ '#'] as esc) + { error lexbuf (Illegal_escape (esc, None)) } + | "\'\'" + { error lexbuf Empty_character_literal } + | "(*" + { let s, loc = wrap_comment_lexer comment lexbuf in + COMMENT (s, loc) } + | "(**" + { let s, loc = wrap_comment_lexer comment lexbuf in + if !handle_docstrings then + DOCSTRING (Docstrings.docstring s loc) + else + COMMENT ("*" ^ s, loc) + } + | "(**" (('*'+) as stars) + { let s, loc = + wrap_comment_lexer + (fun lexbuf -> + store_string ("*" ^ stars); + comment lexbuf) + lexbuf + in + COMMENT (s, loc) } + | "(*)" + { if !print_warnings then + Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start; + let s, loc = wrap_comment_lexer comment lexbuf in + COMMENT (s, loc) } + | "(*" (('*'*) as stars) "*)" + { if !handle_docstrings && stars="" then + (* (**) is an empty docstring *) + DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf)) + else + COMMENT (stars, Location.curr lexbuf) } + | "*)" + { let loc = Location.curr lexbuf in + Location.prerr_warning loc Warnings.Comment_not_end; + lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; + let curpos = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 }; + STAR + } + | "#" + { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in + if not (at_beginning_of_line lexbuf.lex_start_p) + then HASH + else try directive lexbuf with Failure _ -> HASH + } + | "&" { AMPERSAND } + | "&&" { AMPERAMPER } + | "`" { BACKQUOTE } + | "\'" { QUOTE } + | "(" { LPAREN } + | ")" { RPAREN } + | "*" { STAR } + | "," { COMMA } + | "->" { MINUSGREATER } + | "." { DOT } + | ".." { DOTDOT } + | "." (dotsymbolchar symbolchar* as op) { DOTOP op } + | ":" { COLON } + | "::" { COLONCOLON } + | ":=" { COLONEQUAL } + | ":>" { COLONGREATER } + | ";" { SEMI } + | ";;" { SEMISEMI } + | "<" { LESS } + | "<-" { LESSMINUS } + | "=" { EQUAL } + | "[" { LBRACKET } + | "[|" { LBRACKETBAR } + | "[<" { LBRACKETLESS } + | "[>" { LBRACKETGREATER } + | "]" { RBRACKET } + | "{" { LBRACE } + | "{<" { LBRACELESS } + | "|" { BAR } + | "||" { BARBAR } + | "|]" { BARRBRACKET } + | ">" { GREATER } + | ">]" { GREATERRBRACKET } + | "}" { RBRACE } + | ">}" { GREATERRBRACE } + | "[@" { LBRACKETAT } + | "[@@" { LBRACKETATAT } + | "[@@@" { LBRACKETATATAT } + | "[%" { LBRACKETPERCENT } + | "[%%" { LBRACKETPERCENTPERCENT } + | "!" { BANG } + | "!=" { INFIXOP0 "!=" } + | "+" { PLUS } + | "+." { PLUSDOT } + | "+=" { PLUSEQ } + | "-" { MINUS } + | "-." { MINUSDOT } + + | "!" symbolchar_or_hash + as op + { PREFIXOP op } + | ['~' '?'] symbolchar_or_hash + as op + { PREFIXOP op } + | ['=' '<' '>' '|' '&' '$'] symbolchar * as op + { INFIXOP0 op } + | ['@' '^'] symbolchar * as op + { INFIXOP1 op } + | ['+' '-'] symbolchar * as op + { INFIXOP2 op } + | "**" symbolchar * as op + { INFIXOP4 op } + | '%' { PERCENT } + | ['*' '/' '%'] symbolchar * as op + { INFIXOP3 op } + | '#' symbolchar_or_hash + as op + { HASHOP op } + | "let" kwdopchar dotsymbolchar * as op + { LETOP op } + | "and" kwdopchar dotsymbolchar * as op + { ANDOP op } + | eof { EOF } + | (_ as illegal_char) + { error lexbuf (Illegal_character illegal_char) } + +and directive = parse + | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive) + [^ '\010' '\013'] * + { + match int_of_string num with + | exception _ -> + (* PR#7165 *) + let explanation = "line number out of range" in + error lexbuf (Invalid_directive ("#" ^ directive, Some explanation)) + | line_num -> + (* Documentation says that the line number should be + positive, but we have never guarded against this and it + might have useful hackish uses. *) + update_loc lexbuf (Some name) (line_num - 1) true 0; + token lexbuf + } +and comment = parse + "(*" + { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; + store_lexeme lexbuf; + comment lexbuf + } + | "*)" + { match !comment_start_loc with + | [] -> assert false + | [_] -> comment_start_loc := []; Location.curr lexbuf + | _ :: l -> comment_start_loc := l; + store_lexeme lexbuf; + comment lexbuf + } + | "\"" + { + string_start_loc := Location.curr lexbuf; + store_string_char '\"'; + is_in_string := true; + let _loc = try string lexbuf + with Error (Unterminated_string, str_start) -> + match !comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + error_loc loc (Unterminated_string_in_comment (start, str_start)) + in + is_in_string := false; + store_string_char '\"'; + comment lexbuf } + | "{" ('%' '%'? extattrident blank*)? (ident_ext? as raw_delim) "|" + { match lax_delim raw_delim with + | None -> store_lexeme lexbuf; comment lexbuf + | Some delim -> + string_start_loc := Location.curr lexbuf; + store_lexeme lexbuf; + is_in_string := true; + let _loc = try quoted_string delim lexbuf + with Error (Unterminated_string, str_start) -> + match !comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + error_loc loc (Unterminated_string_in_comment (start, str_start)) + in + is_in_string := false; + store_string_char '|'; + store_string delim; + store_string_char '}'; + comment lexbuf } + | "\'\'" + { store_lexeme lexbuf; comment lexbuf } + | "\'" (newline as nl) "\'" + { update_loc lexbuf None 1 false 1; + store_string_char '\''; + store_normalized_newline nl; + store_string_char '\''; + comment lexbuf + } + | "\'" [^ '\\' '\'' '\010' '\013' ] "\'" + { store_lexeme lexbuf; comment lexbuf } + | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'" + { store_lexeme lexbuf; comment lexbuf } + | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" + { store_lexeme lexbuf; comment lexbuf } + | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" + { store_lexeme lexbuf; comment lexbuf } + | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" + { store_lexeme lexbuf; comment lexbuf } + | eof + { match !comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + error_loc loc (Unterminated_comment start) + } + | newline as nl + { update_loc lexbuf None 1 false 0; + store_normalized_newline nl; + comment lexbuf + } + | ident + { store_lexeme lexbuf; comment lexbuf } + | _ + { store_lexeme lexbuf; comment lexbuf } + +and string = parse + '\"' + { lexbuf.lex_start_p } + | '\\' (newline as nl) ([' ' '\t'] * as space) + { update_loc lexbuf None 1 false (String.length space); + if in_comment () then begin + store_string_char '\\'; + store_normalized_newline nl; + store_string space; + end; + string lexbuf + } + | '\\' (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) + { store_escaped_char lexbuf (char_for_backslash c); + string lexbuf } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1); + string lexbuf } + | '\\' 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] + { store_escaped_char lexbuf (char_for_octal_code lexbuf 2); + string lexbuf } + | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] + { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2); + string lexbuf } + | '\\' 'u' '{' hex_digit+ '}' + { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf); + string lexbuf } + | '\\' _ + { if not (in_comment ()) then begin +(* Should be an error, but we are very lax. + error lexbuf (Illegal_escape (Lexing.lexeme lexbuf, None)) +*) + let loc = Location.curr lexbuf in + Location.prerr_warning loc Warnings.Illegal_backslash; + end; + store_lexeme lexbuf; + string lexbuf + } + | newline as nl + { update_loc lexbuf None 1 false 0; + store_normalized_newline nl; + string lexbuf + } + | eof + { is_in_string := false; + error_loc !string_start_loc Unterminated_string } + | (_ as c) + { store_string_char c; + string lexbuf } + +and quoted_string delim = parse + | newline as nl + { update_loc lexbuf None 1 false 0; + store_normalized_newline nl; + quoted_string delim lexbuf + } + | eof + { is_in_string := false; + error_loc !string_start_loc Unterminated_string } + | "|" (ident_ext? as raw_edelim) "}" + { + let edelim = validate_encoding lexbuf raw_edelim in + if delim = edelim then lexbuf.lex_start_p + else (store_lexeme lexbuf; quoted_string delim lexbuf) + } + | (_ as c) + { store_string_char c; + quoted_string delim lexbuf } + +and skip_hash_bang = parse + | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" + { update_loc lexbuf None 3 false 0 } + | "#!" [^ '\n']* '\n' + { update_loc lexbuf None 1 false 0 } + | "" { () } + +{ + + let token_with_comments lexbuf = + match !preprocessor with + | None -> token lexbuf + | Some (_init, preprocess) -> preprocess token lexbuf + + type newline_state = + | NoLine (* There have been no blank lines yet. *) + | NewLine + (* There have been no blank lines, and the previous + token was a newline. *) + | BlankLine (* There have been blank lines. *) + + type doc_state = + | Initial (* There have been no docstrings yet *) + | After of docstring list + (* There have been docstrings, none of which were + preceded by a blank line *) + | Before of docstring list * docstring list * docstring list + (* There have been docstrings, some of which were + preceded by a blank line *) + + and docstring = Docstrings.docstring + + let token lexbuf = + let post_pos = lexeme_end_p lexbuf in + let attach lines docs pre_pos = + let open Docstrings in + match docs, lines with + | Initial, _ -> () + | After a, (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_pre_docstrings pre_pos a; + | After a, BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_pre_extra_docstrings pre_pos (List.rev a) + | Before(a, f, b), (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos + (List.rev_append f (List.rev b)); + set_floating_docstrings pre_pos (List.rev f); + set_pre_extra_docstrings pre_pos (List.rev a); + set_pre_docstrings pre_pos b + | Before(a, f, b), BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos + (List.rev_append f (List.rev b)); + set_floating_docstrings pre_pos + (List.rev_append f (List.rev b)); + set_pre_extra_docstrings pre_pos (List.rev a) + in + let rec loop lines docs lexbuf = + match token_with_comments lexbuf with + | COMMENT (s, loc) -> + add_comment (s, loc); + let lines' = + match lines with + | NoLine -> NoLine + | NewLine -> NoLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | EOL -> + let lines' = + match lines with + | NoLine -> NewLine + | NewLine -> BlankLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | DOCSTRING doc -> + Docstrings.register doc; + add_docstring_comment doc; + let docs' = + if Docstrings.docstring_body doc = "/*" then + match docs with + | Initial -> Before([], [doc], []) + | After a -> Before (a, [doc], []) + | Before(a, f, b) -> Before(a, doc :: b @ f, []) + else + match docs, lines with + | Initial, (NoLine | NewLine) -> After [doc] + | Initial, BlankLine -> Before([], [], [doc]) + | After a, (NoLine | NewLine) -> After (doc :: a) + | After a, BlankLine -> Before (a, [], [doc]) + | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) + | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) + in + loop NoLine docs' lexbuf + | tok -> + attach lines docs (lexeme_start_p lexbuf); + tok + in + loop NoLine Initial lexbuf + + let init () = + is_in_string := false; + comment_start_loc := []; + comment_list := []; + match !preprocessor with + | None -> () + | Some (init, _preprocess) -> init () + + let set_preprocessor init preprocess = + escaped_newlines := true; + preprocessor := Some (init, preprocess) + +} diff --git a/upstream/ocaml_503/parsing/location.ml b/upstream/ocaml_503/parsing/location.ml new file mode 100644 index 000000000..865ca5f20 --- /dev/null +++ b/upstream/ocaml_503/parsing/location.ml @@ -0,0 +1,1016 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Lexing + +type t = Warnings.loc = + { loc_start: position; loc_end: position; loc_ghost: bool } + +let in_file = Warnings.ghost_loc_in_file + +let none = in_file "_none_" +let is_none l = (l = none) + +let curr lexbuf = { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.lex_curr_p; + loc_ghost = false +} + +let init lexbuf fname = + lexbuf.lex_curr_p <- { + pos_fname = fname; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = 0; + } + +let symbol_rloc () = { + loc_start = Parsing.symbol_start_pos (); + loc_end = Parsing.symbol_end_pos (); + loc_ghost = false; +} + +let symbol_gloc () = { + loc_start = Parsing.symbol_start_pos (); + loc_end = Parsing.symbol_end_pos (); + loc_ghost = true; +} + +let rhs_loc n = { + loc_start = Parsing.rhs_start_pos n; + loc_end = Parsing.rhs_end_pos n; + loc_ghost = false; +} + +let rhs_interval m n = { + loc_start = Parsing.rhs_start_pos m; + loc_end = Parsing.rhs_end_pos n; + loc_ghost = false; +} + +(* return file, line, char from the given position *) +let get_pos_info pos = + (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) + +type 'a loc = { + txt : 'a; + loc : t; +} + +let mkloc txt loc = { txt ; loc } +let mknoloc txt = mkloc txt none + +(******************************************************************************) +(* Input info *) + +let input_name = ref "_none_" +let input_lexbuf = ref (None : lexbuf option) +let input_phrase_buffer = ref (None : Buffer.t option) + +(******************************************************************************) +(* Terminal info *) + +let status = ref Terminfo.Uninitialised + +let setup_terminal () = + if !status = Terminfo.Uninitialised then + status := Terminfo.setup stdout + +(* The number of lines already printed after input. + + This is used by [highlight_terminfo] to identify the current position of the + input in the terminal. This would not be possible without this information, + since printing several warnings/errors adds text between the user input and + the bottom of the terminal. + + We also use for {!is_first_report}, see below. +*) +let num_loc_lines = ref 0 + +(* We use [num_loc_lines] to determine if the report about to be + printed is the first or a follow-up report of the current + "batch" -- contiguous reports without user input in between, for + example for the current toplevel phrase. We use this to print + a blank line between messages of the same batch. +*) +let is_first_message () = + !num_loc_lines = 0 + +(* This is used by the toplevel to reset [num_loc_lines] before each phrase *) +let reset () = + num_loc_lines := 0 + +(* This is used by the toplevel *) +let echo_eof () = + print_newline (); + incr num_loc_lines + +(* Code printing errors and warnings must be wrapped using this function, in + order to update [num_loc_lines]. + + [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf + arg], and additionally updates [num_loc_lines]. *) +let print_updating_num_loc_lines ppf f arg = + let open Format in + let out_functions = pp_get_formatter_out_functions ppf () in + let out_string str start len = + let rec count i c = + if i = start + len then c + else if String.get str i = '\n' then count (succ i) (succ c) + else count (succ i) c in + num_loc_lines := !num_loc_lines + count start 0 ; + out_functions.out_string str start len in + pp_set_formatter_out_functions ppf + { out_functions with out_string } ; + f ppf arg ; + pp_print_flush ppf (); + pp_set_formatter_out_functions ppf out_functions + +(** {1 Printing setup }*) + +let setup_tags () = + Misc.Style.setup !Clflags.color + +(******************************************************************************) +(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *) + +let rewrite_absolute_path path = + match Misc.get_build_path_prefix_map () with + | None -> path + | Some map -> Build_path_prefix_map.rewrite map path + +let rewrite_find_first_existing path = + match Misc.get_build_path_prefix_map () with + | None -> + if Sys.file_exists path then Some path + else None + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if Sys.file_exists path then Some path + else None + | matches -> + Some (List.find Sys.file_exists matches) + +let rewrite_find_all_existing_dirs path = + let ok path = Sys.file_exists path && Sys.is_directory path in + match Misc.get_build_path_prefix_map () with + | None -> + if ok path then [path] + else [] + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if ok path then [path] + else [] + | matches -> + match (List.filter ok matches) with + | [] -> raise Not_found + | results -> results + +let absolute_path s = (* This function could go into Filename *) + let open Filename in + let s = if (is_relative s) then (concat (Sys.getcwd ()) s) else s in + let s = rewrite_absolute_path s in + (* Now simplify . and .. components *) + let rec aux s = + let base = basename s in + let dir = dirname s in + if dir = s then dir + else if base = current_dir_name then aux dir + else if base = parent_dir_name then dirname (aux dir) + else concat (aux dir) base + in + aux s + +let show_filename file = + if !Clflags.absname then absolute_path file else file + +module Fmt = Format_doc +module Doc = struct + + (* This is used by the toplevel and the report printers below. *) + let separate_new_message ppf () = + if not (is_first_message ()) then begin + Fmt.pp_print_newline ppf (); + incr num_loc_lines + end + + let filename ppf file = + Fmt.pp_print_string ppf (show_filename file) + +(* Best-effort printing of the text describing a location, of the form + 'File "foo.ml", line 3, characters 10-12'. + + Some of the information (filename, line number or characters numbers) in the + location might be invalid; in which case we do not print it. + *) + let loc ppf loc = + setup_tags (); + let file_valid = function + | "_none_" -> + (* This is a dummy placeholder, but we print it anyway to please + editors that parse locations in error messages (e.g. Emacs). *) + true + | "" | "//toplevel//" -> false + | _ -> true + in + let line_valid line = line > 0 in + let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in + + let file = + (* According to the comment in location.mli, if [pos_fname] is "", we must + use [!input_name]. *) + if loc.loc_start.pos_fname = "" then !input_name + else loc.loc_start.pos_fname + in + let startline = loc.loc_start.pos_lnum in + let endline = loc.loc_end.pos_lnum in + let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in + let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in + + let first = ref true in + let capitalize s = + if !first then (first := false; String.capitalize_ascii s) + else s in + let comma () = + if !first then () else Fmt.fprintf ppf ", " in + + Fmt.fprintf ppf "@{"; + + if file_valid file then + Fmt.fprintf ppf "%s \"%a\"" (capitalize "file") filename file; + + (* Print "line 1" in the case of a dummy line number. This is to please the + existing setup of editors that parse locations in error messages (e.g. + Emacs). *) + comma (); + let startline = if line_valid startline then startline else 1 in + let endline = if line_valid endline then endline else startline in + begin if startline = endline then + Fmt.fprintf ppf "%s %i" (capitalize "line") startline + else + Fmt.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline + end; + + if chars_valid ~startchar ~endchar then ( + comma (); + Fmt.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar + ); + + Fmt.fprintf ppf "@}" + + (* Print a comma-separated list of locations *) + let locs ppf locs = + Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.fprintf ppf ",@ ") + loc ppf locs + let quoted_filename ppf f = Misc.Style.as_inline_code filename ppf f + +end + +let print_filename = Fmt.compat Doc.filename +let print_loc = Fmt.compat Doc.loc +let print_locs = Fmt.compat Doc.locs +let separate_new_message ppf = Fmt.compat Doc.separate_new_message ppf () + +(******************************************************************************) +(* An interval set structure; additionally, it stores user-provided information + at interval boundaries. + + The implementation provided here is naive and assumes the number of intervals + to be small, but the interface would allow for a more efficient + implementation if needed. + + Note: the structure only stores maximal intervals (that therefore do not + overlap). +*) + +module ISet : sig + type 'a bound = 'a * int + type 'a t + (* bounds are included *) + val of_intervals : ('a bound * 'a bound) list -> 'a t + + val mem : 'a t -> pos:int -> bool + val find_bound_in : 'a t -> range:(int * int) -> 'a bound option + + val is_start : 'a t -> pos:int -> 'a option + val is_end : 'a t -> pos:int -> 'a option + + val extrema : 'a t -> ('a bound * 'a bound) option +end += +struct + type 'a bound = 'a * int + + (* non overlapping intervals *) + type 'a t = ('a bound * 'a bound) list + + let of_intervals intervals = + let pos = + List.map (fun ((a, x), (b, y)) -> + if x > y then [] else [((a, x), `S); ((b, y), `E)] + ) intervals + |> List.flatten + |> List.sort (fun ((_, x), k) ((_, y), k') -> + (* Make `S come before `E so that consecutive intervals get merged + together in the fold below *) + let kn = function `S -> 0 | `E -> 1 in + compare (x, kn k) (y, kn k')) + in + let nesting, acc = + List.fold_left (fun (nesting, acc) (a, kind) -> + match kind, nesting with + | `S, `Outside -> `Inside (a, 0), acc + | `S, `Inside (s, n) -> `Inside (s, n+1), acc + | `E, `Outside -> assert false + | `E, `Inside (s, 0) -> `Outside, ((s, a) :: acc) + | `E, `Inside (s, n) -> `Inside (s, n-1), acc + ) (`Outside, []) pos in + assert (nesting = `Outside); + List.rev acc + + let mem iset ~pos = + List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset + + let find_bound_in iset ~range:(start, end_) = + List.find_map (fun ((a, x), (b, y)) -> + if start <= x && x <= end_ then Some (a, x) + else if start <= y && y <= end_ then Some (b, y) + else None + ) iset + + let is_start iset ~pos = + List.find_map (fun ((a, x), _) -> + if pos = x then Some a else None + ) iset + + let is_end iset ~pos = + List.find_map (fun (_, (b, y)) -> + if pos = y then Some b else None + ) iset + + let extrema iset = + if iset = [] then None + else Some (fst (List.hd iset), snd (List.hd (List.rev iset))) +end + +(******************************************************************************) +(* Toplevel: highlighting and quoting locations *) + +(* Highlight the locations using standout mode. + + If [locs] is empty, this function is a no-op. +*) +let highlight_terminfo lb ppf locs = + Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *) + (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) + let pos0 = -lb.lex_abs_pos in + (* Do nothing if the buffer does not contain the whole phrase. *) + if pos0 < 0 then raise Exit; + (* Count number of lines in phrase *) + let lines = ref !num_loc_lines in + for i = pos0 to lb.lex_buffer_len - 1 do + if Bytes.get lb.lex_buffer i = '\n' then incr lines + done; + (* If too many lines, give up *) + if !lines >= Terminfo.num_lines stdout - 2 then raise Exit; + (* Move cursor up that number of lines *) + flush stdout; Terminfo.backup stdout !lines; + (* Print the input, switching to standout for the location *) + let bol = ref false in + print_string "# "; + for pos = 0 to lb.lex_buffer_len - pos0 - 1 do + if !bol then (print_string " "; bol := false); + if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then + Terminfo.standout stdout true; + if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then + Terminfo.standout stdout false; + let c = Bytes.get lb.lex_buffer (pos + pos0) in + print_char c; + bol := (c = '\n') + done; + (* Make sure standout mode is over *) + Terminfo.standout stdout false; + (* Position cursor back to original location *) + Terminfo.resume stdout !num_loc_lines; + flush stdout + +let highlight_terminfo lb ppf locs = + try highlight_terminfo lb ppf locs + with Exit -> () + +(* Highlight the location by printing it again. + + There are two different styles for highlighting errors in "dumb" mode, + depending if the error fits on a single line or spans across several lines. + + For single-line errors, + + foo the_error bar + + gets displayed as follows, where X is the line number: + + X | foo the_error bar + ^^^^^^^^^ + + + For multi-line errors, + + foo the_ + error bar + + gets displayed as: + + X1 | ....the_ + X2 | error.... + + An ellipsis hides the middle lines of the multi-line error if it has more + than [max_lines] lines. + + If [locs] is empty then this function is a no-op. +*) + +type input_line = { + text : string; + start_pos : int; +} + +(* Takes a list of lines with possibly missing line numbers. + + If the line numbers that are present are consistent with the number of lines + between them, then infer the intermediate line numbers. + + This is not always the case, typically if lexer line directives are + involved... *) +let infer_line_numbers + (lines: (int option * input_line) list): + (int option * input_line) list + = + let (_, offset, consistent) = + List.fold_left (fun (i, offset, consistent) (lnum, _) -> + match lnum, offset with + | None, _ -> (i+1, offset, consistent) + | Some n, None -> (i+1, Some (n - i), consistent) + | Some n, Some m -> (i+1, offset, consistent && n = m + i) + ) (0, None, true) lines + in + match offset, consistent with + | Some m, true -> + List.mapi (fun i (_, line) -> (Some (m + i), line)) lines + | _, _ -> + lines + +(* [get_lines] must return the lines to highlight, given starting and ending + positions. + + See [lines_around_from_current_input] below for an instantiation of + [get_lines] that reads from the current input. +*) +let highlight_quote ppf + ~(get_lines: start_pos:position -> end_pos:position -> input_line list) + ?(max_lines = 10) + highlight_tag + locs + = + let iset = ISet.of_intervals @@ List.filter_map (fun loc -> + let s, e = loc.loc_start, loc.loc_end in + if s.pos_cnum = -1 || e.pos_cnum = -1 then None + else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1)) + ) locs in + match ISet.extrema iset with + | None -> () + | Some ((leftmost, _), (rightmost, _)) -> + let lines = + get_lines ~start_pos:leftmost ~end_pos:rightmost + |> List.map (fun ({ text; start_pos } as line) -> + let end_pos = start_pos + String.length text - 1 in + let line_nb = + match ISet.find_bound_in iset ~range:(start_pos, end_pos) with + | None -> None + | Some (p, _) -> Some p.pos_lnum + in + (line_nb, line)) + |> infer_line_numbers + |> List.map (fun (lnum, { text; start_pos }) -> + (text, + Option.fold ~some:Int.to_string ~none:"" lnum, + start_pos)) + in + Fmt.fprintf ppf "@["; + begin match lines with + | [] | [("", _, _)] -> () + | [(line, line_nb, line_start_cnum)] -> + (* Single-line error *) + Fmt.fprintf ppf "%s | %s@," line_nb line; + Fmt.fprintf ppf "%*s " (String.length line_nb) ""; + (* Iterate up to [rightmost], which can be larger than the length of + the line because we may point to a location after the end of the + last token on the line, for instance: + {[ + token + ^ + Did you forget ... + ]} *) + for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do + let pos = line_start_cnum + i in + if ISet.is_start iset ~pos <> None then + Fmt.fprintf ppf "@{<%s>" highlight_tag; + if ISet.mem iset ~pos then Fmt.pp_print_char ppf '^' + else if i < String.length line then begin + (* For alignment purposes, align using a tab for each tab in the + source code *) + if line.[i] = '\t' then Fmt.pp_print_char ppf '\t' + else Fmt.pp_print_char ppf ' ' + end; + if ISet.is_end iset ~pos <> None then + Fmt.fprintf ppf "@}" + done; + Fmt.fprintf ppf "@}@," + | _ -> + (* Multi-line error *) + Fmt.pp_two_columns ~sep:"|" ~max_lines ppf + @@ List.map (fun (line, line_nb, line_start_cnum) -> + let line = String.mapi (fun i car -> + if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.' + ) line in + (line_nb, line) + ) lines + end; + Fmt.fprintf ppf "@]" + + + +let lines_around + ~(start_pos: position) ~(end_pos: position) + ~(seek: int -> unit) + ~(read_char: unit -> char option): + input_line list + = + seek start_pos.pos_bol; + let lines = ref [] in + let bol = ref start_pos.pos_bol in + let cur = ref start_pos.pos_bol in + let b = Buffer.create 80 in + let add_line () = + if !bol < !cur then begin + let text = Buffer.contents b in + Buffer.clear b; + lines := { text; start_pos = !bol } :: !lines; + bol := !cur + end + in + let rec loop () = + if !bol >= end_pos.pos_cnum then () + else begin + match read_char () with + | None -> + (* end of input *) + add_line () + | Some c -> + incr cur; + match c with + | '\r' -> loop () + | '\n' -> add_line (); loop () + | _ -> Buffer.add_char b c; loop () + end + in + loop (); + List.rev !lines + +(* Attempt to get lines from the lexing buffer. *) +let lines_around_from_lexbuf + ~(start_pos: position) ~(end_pos: position) + (lb: lexbuf): + input_line list + = + (* Converts a global position to one that is relative to the lexing buffer *) + let rel n = n - lb.lex_abs_pos in + if rel start_pos.pos_bol < 0 then begin + (* Do nothing if the buffer does not contain the input (because it has been + refilled while lexing it) *) + [] + end else begin + let pos = ref 0 in (* relative position *) + let seek n = pos := rel n in + let read_char () = + if !pos >= lb.lex_buffer_len then (* end of buffer *) None + else + let c = Bytes.get lb.lex_buffer !pos in + incr pos; Some c + in + lines_around ~start_pos ~end_pos ~seek ~read_char + end + +(* Attempt to get lines from the phrase buffer *) +let lines_around_from_phrasebuf + ~(start_pos: position) ~(end_pos: position) + (pb: Buffer.t): + input_line list + = + let pos = ref 0 in + let seek n = pos := n in + let read_char () = + if !pos >= Buffer.length pb then None + else begin + let c = Buffer.nth pb !pos in + incr pos; Some c + end + in + lines_around ~start_pos ~end_pos ~seek ~read_char + +(* A [get_lines] function for [highlight_quote] that reads from the current + input. *) +let lines_around_from_current_input ~start_pos ~end_pos = + match !input_lexbuf, !input_phrase_buffer, !input_name with + | _, Some pb, "//toplevel//" -> + lines_around_from_phrasebuf pb ~start_pos ~end_pos + | Some lb, _, _ -> + lines_around_from_lexbuf lb ~start_pos ~end_pos + | None, _, _ -> + [] + +(******************************************************************************) +(* Reporting errors and warnings *) + +type msg = Fmt.t loc + +let msg ?(loc = none) fmt = + Fmt.kdoc_printf (fun txt -> { loc; txt }) fmt + +type report_kind = + | Report_error + | Report_warning of string + | Report_warning_as_error of string + | Report_alert of string + | Report_alert_as_error of string + +type report = { + kind : report_kind; + main : msg; + sub : msg list; + footnote: Fmt.t option; +} + +type report_printer = { + (* The entry point *) + pp : report_printer -> + Format.formatter -> report -> unit; + + pp_report_kind : report_printer -> report -> + Format.formatter -> report_kind -> unit; + pp_main_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_main_txt : report_printer -> report -> + Format.formatter -> Fmt.t -> unit; + pp_submsgs : report_printer -> report -> + Format.formatter -> msg list -> unit; + pp_submsg : report_printer -> report -> + Format.formatter -> msg -> unit; + pp_submsg_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_submsg_txt : report_printer -> report -> + Format.formatter -> Fmt.t -> unit; +} + +let is_dummy_loc loc = + (* Fixme: this should be just [loc.loc_ghost] and the function should be + inlined below. However, currently, the compiler emits in some places ghost + locations with valid ranges that should still be printed. These locations + should be made non-ghost -- in the meantime we just check if the ranges are + valid. *) + loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1 + +(* It only makes sense to highlight (i.e. quote or underline the corresponding + source code) locations that originate from the current input. + + As of now, this should only happen in the following cases: + + - if dummy locs or ghost locs leak out of the compiler or a buggy ppx; + + - more generally, if some code uses the compiler-libs API and feeds it + locations that do not match the current values of [!Location.input_name], + [!Location.input_lexbuf]; + + - when calling the compiler on a .ml file that contains lexer line directives + indicating an other file. This should happen relatively rarely in practice -- + in particular this is not what happens when using -pp or -ppx or a ppx + driver. +*) +let is_quotable_loc loc = + not (is_dummy_loc loc) + && loc.loc_start.pos_fname = !input_name + && loc.loc_end.pos_fname = !input_name + +let error_style () = + match !Clflags.error_style with + | Some setting -> setting + | None -> Misc.Error_style.default_setting + +let batch_mode_printer : report_printer = + let pp_loc _self report ppf loc = + let tag = match report.kind with + | Report_warning_as_error _ + | Report_alert_as_error _ + | Report_error -> "error" + | Report_warning _ + | Report_alert _ -> "warning" + in + let highlight ppf loc = + match error_style () with + | Misc.Error_style.Contextual -> + if is_quotable_loc loc then + highlight_quote ppf + ~get_lines:lines_around_from_current_input + tag [loc] + | Misc.Error_style.Short -> + () + in + Format.fprintf ppf "@[%a:@ %a@]" print_loc loc + (Fmt.compat highlight) loc + in + let pp_txt ppf txt = Format.fprintf ppf "@[%a@]" Fmt.Doc.format txt in + let pp_footnote ppf f = + Option.iter (Format.fprintf ppf "@,%a" pp_txt) f + in + let pp self ppf report = + setup_tags (); + separate_new_message ppf; + (* Make sure we keep [num_loc_lines] updated. + The tabulation box is here to give submessage the option + to be aligned with the main message box + *) + print_updating_num_loc_lines ppf (fun ppf () -> + Format.fprintf ppf "@[%a%a%a: %a%a%a%a%a@]@." + Format.pp_open_tbox () + (self.pp_main_loc self report) report.main.loc + (self.pp_report_kind self report) report.kind + Format.pp_set_tab () + (self.pp_main_txt self report) report.main.txt + (self.pp_submsgs self report) report.sub + pp_footnote report.footnote + Format.pp_close_tbox () + ) () + in + let pp_report_kind _self _ ppf = function + | Report_error -> Format.fprintf ppf "@{Error@}" + | Report_warning w -> Format.fprintf ppf "@{Warning@} %s" w + | Report_warning_as_error w -> + Format.fprintf ppf "@{Error@} (warning %s)" w + | Report_alert w -> Format.fprintf ppf "@{Alert@} %s" w + | Report_alert_as_error w -> + Format.fprintf ppf "@{Error@} (alert %s)" w + in + let pp_main_loc self report ppf loc = + pp_loc self report ppf loc + in + let pp_main_txt _self _ ppf txt = + pp_txt ppf txt + in + let pp_submsgs self report ppf msgs = + List.iter (fun msg -> + Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg + ) msgs + in + let pp_submsg self report ppf { loc; txt } = + Format.fprintf ppf "@[%a %a@]" + (self.pp_submsg_loc self report) loc + (self.pp_submsg_txt self report) txt + in + let pp_submsg_loc self report ppf loc = + if not loc.loc_ghost then + pp_loc self report ppf loc + in + let pp_submsg_txt _self _ ppf loc = + pp_txt ppf loc + in + { pp; pp_report_kind; pp_main_loc; pp_main_txt; + pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt } + +let terminfo_toplevel_printer (lb: lexbuf): report_printer = + let pp self ppf err = + setup_tags (); + (* Highlight all toplevel locations of the report, instead of displaying + the main location. Do it now instead of in [pp_main_loc], to avoid + messing with Format boxes. *) + let sub_locs = List.map (fun { loc; _ } -> loc) err.sub in + let all_locs = err.main.loc :: sub_locs in + let locs_highlighted = List.filter is_quotable_loc all_locs in + highlight_terminfo lb ppf locs_highlighted; + batch_mode_printer.pp self ppf err + in + let pp_main_loc _ _ _ _ = () in + let pp_submsg_loc _ _ ppf loc = + if not loc.loc_ghost then + Format.fprintf ppf "%a:@ " print_loc loc in + { batch_mode_printer with pp; pp_main_loc; pp_submsg_loc } + +let best_toplevel_printer () = + setup_terminal (); + match !status, !input_lexbuf with + | Terminfo.Good_term, Some lb -> + terminfo_toplevel_printer lb + | _, _ -> + batch_mode_printer + +(* Creates a printer for the current input *) +let default_report_printer () : report_printer = + if !input_name = "//toplevel//" then + best_toplevel_printer () + else + batch_mode_printer + +let report_printer = ref default_report_printer + +let print_report ppf report = + let printer = !report_printer () in + printer.pp printer ppf report + +(******************************************************************************) +(* Reporting errors *) + +type error = report +type delayed_msg = unit -> Fmt.t option + +let report_error ppf err = + print_report ppf err + +let mkerror loc sub footnote txt = + { kind = Report_error; main = { loc; txt }; sub; footnote=footnote () } + +let errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = + Fmt.kdoc_printf (mkerror loc sub footnote) + +let error ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) msg_str = + mkerror loc sub footnote Fmt.Doc.(string msg_str empty) + +let error_of_printer ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) pp x = + mkerror loc sub footnote (Fmt.doc_printf "%a" pp x) + +let error_of_printer_file print x = + error_of_printer ~loc:(in_file !input_name) print x + +(******************************************************************************) +(* Reporting warnings: generating a report from a warning number using the + information in [Warnings] + convenience functions. *) + +let default_warning_alert_reporter report mk (loc: t) w : report option = + match report w with + | `Inactive -> None + | `Active { Warnings.id; message; is_error; sub_locs } -> + let msg_of_str str = Format_doc.Doc.(empty |> string str) in + let kind = mk is_error id in + let main = { loc; txt = msg_of_str message } in + let sub = List.map (fun (loc, sub_message) -> + { loc; txt = msg_of_str sub_message } + ) sub_locs in + Some { kind; main; sub; footnote=None } + + +let default_warning_reporter = + default_warning_alert_reporter + Warnings.report + (fun is_error id -> + if is_error then Report_warning_as_error id + else Report_warning id + ) + +let warning_reporter = ref default_warning_reporter +let report_warning loc w = !warning_reporter loc w + +let formatter_for_warnings = ref Format.err_formatter + +let print_warning loc ppf w = + match report_warning loc w with + | None -> () + | Some report -> print_report ppf report + +let prerr_warning loc w = print_warning loc !formatter_for_warnings w + +let default_alert_reporter = + default_warning_alert_reporter + Warnings.report_alert + (fun is_error id -> + if is_error then Report_alert_as_error id + else Report_alert id + ) + +let alert_reporter = ref default_alert_reporter +let report_alert loc w = !alert_reporter loc w + +let print_alert loc ppf w = + match report_alert loc w with + | None -> () + | Some report -> print_report ppf report + +let prerr_alert loc w = print_alert loc !formatter_for_warnings w + +let alert ?(def = none) ?(use = none) ~kind loc message = + prerr_alert loc {Warnings.kind; message; def; use} + +let deprecated ?def ?use loc message = + alert ?def ?use ~kind:"deprecated" loc message + +module Style = Misc.Style + +let auto_include_alert lib = + let message = Fmt.asprintf "\ + OCaml's lib directory layout changed in 5.0. The %a subdirectory has been \ + automatically added to the search path, but you should add %a to the \ + command-line to silence this alert (e.g. by adding %a to the list of \ + libraries in your dune file, or adding %a to your %a file for \ + ocamlbuild, or using %a for ocamlfind)." + Style.inline_code lib + Style.inline_code ("-I +" ^lib) + Style.inline_code lib + Style.inline_code ("use_"^lib) + Style.inline_code "_tags" + Style.inline_code ("-package " ^ lib) in + let alert = + {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +let deprecated_script_alert program = + let message = Fmt.asprintf "\ + Running %a where the first argument is an implicit basename with no \ + extension (e.g. %a) is deprecated. Either rename the script \ + (%a) or qualify the basename (%a)" + Style.inline_code program + Style.inline_code (program ^ " script-file") + Style.inline_code (program ^ " script-file.ml") + Style.inline_code (program ^ " ./script-file") + in + let alert = + {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +(******************************************************************************) +(* Reporting errors on exceptions *) + +let error_of_exn : (exn -> error option) list ref = ref [] + +let register_error_of_exn f = error_of_exn := f :: !error_of_exn + +exception Already_displayed_error = Warnings.Errors + +let error_of_exn exn = + match exn with + | Already_displayed_error -> Some `Already_displayed + | _ -> + let rec loop = function + | [] -> None + | f :: rest -> + match f exn with + | Some error -> Some (`Ok error) + | None -> loop rest + in + loop !error_of_exn + +let () = + register_error_of_exn + (function + | Sys_error msg -> + Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg) + | _ -> None + ) + +external reraise : exn -> 'a = "%reraise" + +let report_exception ppf exn = + let rec loop n exn = + match error_of_exn exn with + | None -> reraise exn + | Some `Already_displayed -> () + | Some (`Ok err) -> report_error ppf err + | exception exn when n > 0 -> loop (n-1) exn + in + loop 5 exn + +exception Error of error + +let () = + register_error_of_exn + (function + | Error e -> Some e + | _ -> None + ) + +let raise_errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = + Fmt.kdoc_printf (fun txt -> raise (Error (mkerror loc sub footnote txt))) diff --git a/upstream/ocaml_503/parsing/location.mli b/upstream/ocaml_503/parsing/location.mli new file mode 100644 index 000000000..5298386f3 --- /dev/null +++ b/upstream/ocaml_503/parsing/location.mli @@ -0,0 +1,368 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Source code locations (ranges of positions), used in parsetree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Format + +type t = Warnings.loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +(** Note on the use of Lexing.position in this module. + If [pos_fname = ""], then use [!input_name] instead. + If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and + re-parse the file to get the line and character numbers. + Else all fields are correct. +*) + +val none : t +(** An arbitrary value of type [t]; describes an empty ghost range. *) + +val is_none : t -> bool +(** True for [Location.none], false any other location *) + +val in_file : string -> t +(** Return an empty ghost range located in a given file. *) + +val init : Lexing.lexbuf -> string -> unit +(** Set the file name and line number of the [lexbuf] to be the start + of the named file. *) + +val curr : Lexing.lexbuf -> t +(** Get the location of the current token from the [lexbuf]. *) + +val symbol_rloc: unit -> t +val symbol_gloc: unit -> t + +(** [rhs_loc n] returns the location of the symbol at position [n], starting + at 1, in the current parser rule. *) +val rhs_loc: int -> t + +val rhs_interval: int -> int -> t + +val get_pos_info: Lexing.position -> string * int * int +(** file, line, char *) + +type 'a loc = { + txt : 'a; + loc : t; +} + +val mknoloc : 'a -> 'a loc +val mkloc : 'a -> t -> 'a loc + + +(** {1 Input info} *) + +val input_name: string ref +val input_lexbuf: Lexing.lexbuf option ref + +(* This is used for reporting errors coming from the toplevel. + + When running a toplevel session (i.e. when [!input_name] is "//toplevel//"), + [!input_phrase_buffer] should be [Some buf] where [buf] contains the last + toplevel phrase. *) +val input_phrase_buffer: Buffer.t option ref + + +(** {1 Toplevel-specific functions} *) + +val echo_eof: unit -> unit +val reset: unit -> unit + + +(** {1 Rewriting path } *) + +val rewrite_absolute_path: string -> string +(** [rewrite_absolute_path path] rewrites [path] to honor the + BUILD_PATH_PREFIX_MAP variable + if it is set. It does not check whether [path] is absolute or not. + The result is as follows: + - If BUILD_PATH_PREFIX_MAP is not set, just return [path]. + - otherwise, rewrite using the mapping (and if there are no + matching prefixes that will just return [path]). + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val rewrite_find_first_existing: string -> string option +(** [rewrite_find_first_existing path] uses a BUILD_PATH_PREFIX_MAP mapping + and tries to find a source in mapping + that maps to a result that exists in the file system. + There are the following return values: + - [None], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [path] does not exists, or} + {- no source prefixes of [path] in the mapping were found,}} + - [Some target], means [target] exists and either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [target] = [path], or} + {- [target] is the first file (in priority + order) that [path] mapped to that exists in the file system.}} + - [Not_found] raised, means some source prefixes in the map + were found that matched [path], but none of them existed + in the file system. The caller should catch this and issue + an appropriate error message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val rewrite_find_all_existing_dirs: string -> string list +(** [rewrite_find_all_existing_dirs dir] accumulates a list of existing + directories, [dirs], that are the result of mapping a potentially + abstract directory, [dir], over all the mapping pairs in the + BUILD_PATH_PREFIX_MAP environment variable, if any. The list [dirs] + will be in priority order (head as highest priority). + + The possible results are: + - [[]], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dir] is not an existing + directory, or} + {- if set, then there were no matching prefixes of [dir].}} + - [Some dirs], means dirs are the directories found. Either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dirs = [dir]], or} + {- it was set and [dirs] are the mapped existing directories.}} + - Not_found raised, means some source prefixes in the map + were found that matched [dir], but none of mapping results + were existing directories (possibly due to misconfiguration). + The caller should catch this and issue an appropriate error + message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val absolute_path: string -> string + (** [absolute_path path] first makes an absolute path, [s] from [path], + prepending the current working directory if [path] was relative. + Then [s] is rewritten using [rewrite_absolute_path]. + Finally the result is normalized by eliminating instances of + ['.'] or ['..']. *) + +(** {1 Printing locations} *) + +val show_filename: string -> string + (** In -absname mode, return the absolute path for this filename. + Otherwise, returns the filename unchanged. *) + +val print_filename: formatter -> string -> unit +val print_loc: formatter -> t -> unit +val print_locs: formatter -> t list -> unit +val separate_new_message: formatter -> unit + +module Doc: sig + val separate_new_message: unit Format_doc.printer + val filename: string Format_doc.printer + val quoted_filename: string Format_doc.printer + val loc: t Format_doc.printer + val locs: t list Format_doc.printer +end + +(** {1 Toplevel-specific location highlighting} *) + +val highlight_terminfo: + Lexing.lexbuf -> formatter -> t list -> unit + + +(** {1 Reporting errors and warnings} *) + +(** {2 The type of reports and report printers} *) + +type msg = Format_doc.t loc + +val msg: ?loc:t -> ('a, Format_doc.formatter, unit, msg) format4 -> 'a + +type report_kind = + | Report_error + | Report_warning of string + | Report_warning_as_error of string + | Report_alert of string + | Report_alert_as_error of string + +type report = { + kind : report_kind; + main : msg; + sub : msg list; + footnote: Format_doc.t option +} + +type report_printer = { + (* The entry point *) + pp : report_printer -> + Format.formatter -> report -> unit; + + pp_report_kind : report_printer -> report -> + Format.formatter -> report_kind -> unit; + pp_main_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_main_txt : report_printer -> report -> + Format.formatter -> Format_doc.t -> unit; + pp_submsgs : report_printer -> report -> + Format.formatter -> msg list -> unit; + pp_submsg : report_printer -> report -> + Format.formatter -> msg -> unit; + pp_submsg_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_submsg_txt : report_printer -> report -> + Format.formatter -> Format_doc.t -> unit; +} +(** A printer for [report]s, defined using open-recursion. + The goal is to make it easy to define new printers by re-using code from + existing ones. +*) + +(** {2 Report printers used in the compiler} *) + +val batch_mode_printer: report_printer + +val terminfo_toplevel_printer: Lexing.lexbuf -> report_printer + +val best_toplevel_printer: unit -> report_printer +(** Detects the terminal capabilities and selects an adequate printer *) + +(** {2 Printing a [report]} *) + +val print_report: formatter -> report -> unit +(** Display an error or warning report. *) + +val report_printer: (unit -> report_printer) ref +(** Hook for redefining the printer of reports. + + The hook is a [unit -> report_printer] and not simply a [report_printer]: + this is useful so that it can detect the type of the output (a file, a + terminal, ...) and select a printer accordingly. *) + +val default_report_printer: unit -> report_printer +(** Original report printer for use in hooks. *) + + +(** {1 Reporting warnings} *) + +(** {2 Converting a [Warnings.t] into a [report]} *) + +val report_warning: t -> Warnings.t -> report option +(** [report_warning loc w] produces a report for the given warning [w], or + [None] if the warning is not to be printed. *) + +val warning_reporter: (t -> Warnings.t -> report option) ref +(** Hook for intercepting warnings. *) + +val default_warning_reporter: t -> Warnings.t -> report option +(** Original warning reporter for use in hooks. *) + +(** {2 Printing warnings} *) + +val formatter_for_warnings : formatter ref + +val print_warning: t -> formatter -> Warnings.t -> unit +(** Prints a warning. This is simply the composition of [report_warning] and + [print_report]. *) + +val prerr_warning: t -> Warnings.t -> unit +(** Same as [print_warning], but uses [!formatter_for_warnings] as output + formatter. *) + +(** {1 Reporting alerts} *) + +(** {2 Converting an [Alert.t] into a [report]} *) + +val report_alert: t -> Warnings.alert -> report option +(** [report_alert loc w] produces a report for the given alert [w], or + [None] if the alert is not to be printed. *) + +val alert_reporter: (t -> Warnings.alert -> report option) ref +(** Hook for intercepting alerts. *) + +val default_alert_reporter: t -> Warnings.alert -> report option +(** Original alert reporter for use in hooks. *) + +(** {2 Printing alerts} *) + +val print_alert: t -> formatter -> Warnings.alert -> unit +(** Prints an alert. This is simply the composition of [report_alert] and + [print_report]. *) + +val prerr_alert: t -> Warnings.alert -> unit +(** Same as [print_alert], but uses [!formatter_for_warnings] as output + formatter. *) + +val deprecated: ?def:t -> ?use:t -> t -> string -> unit +(** Prints a deprecation alert. *) + +val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit +(** Prints an arbitrary alert. *) + +val auto_include_alert: string -> unit +(** Prints an alert that -I +lib has been automatically added to the load + path *) + +val deprecated_script_alert: string -> unit +(** [deprecated_script_alert command] prints an alert that [command foo] has + been deprecated in favour of [command ./foo] *) + +(** {1 Reporting errors} *) + +type error = report +(** An [error] is a [report] which [report_kind] must be [Report_error]. *) + +type delayed_msg = unit -> Format_doc.t option + +val error: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> string -> error + +val errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> + ('a, Format_doc.formatter, unit, error) format4 -> 'a + +val error_of_printer: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> + (Format_doc.formatter -> 'a -> unit) -> 'a -> error + +val error_of_printer_file: (Format_doc.formatter -> 'a -> unit) -> 'a -> error + + +(** {1 Automatically reporting errors for raised exceptions} *) + +val register_error_of_exn: (exn -> error option) -> unit +(** Each compiler module which defines a custom type of exception + which can surface as a user-visible error should register + a "printer" for this exception using [register_error_of_exn]. + The result of the printer is an [error] value containing + a location, a message, and optionally sub-messages (each of them + being located as well). *) + +val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option + +exception Error of error +(** Raising [Error e] signals an error [e]; the exception will be caught and the + error will be printed. *) + +exception Already_displayed_error +(** Raising [Already_displayed_error] signals an error which has already been + printed. The exception will be caught, but nothing will be printed *) + +val raise_errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> + ('a, Format_doc.formatter, unit, 'b) format4 -> 'a + +val report_exception: formatter -> exn -> unit +(** Reraise the exception if it is unknown. *) diff --git a/upstream/ocaml_503/parsing/longident.ml b/upstream/ocaml_503/parsing/longident.ml new file mode 100644 index 000000000..eaafb02be --- /dev/null +++ b/upstream/ocaml_503/parsing/longident.ml @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + Lident of string + | Ldot of t * string + | Lapply of t * t + +let rec flat accu = function + Lident s -> s :: accu + | Ldot(lid, s) -> flat (s :: accu) lid + | Lapply(_, _) -> Misc.fatal_error "Longident.flat" + +let flatten lid = flat [] lid + +let last = function + Lident s -> s + | Ldot(_, s) -> s + | Lapply(_, _) -> Misc.fatal_error "Longident.last" + + +let rec split_at_dots s pos = + try + let dot = String.index_from s pos '.' in + String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) + with Not_found -> + [String.sub s pos (String.length s - pos)] + +let unflatten l = + match l with + | [] -> None + | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) + +let parse s = + match unflatten (split_at_dots s 0) with + | None -> Lident "" (* should not happen, but don't put assert false + so as not to crash the toplevel (see Genprintval) *) + | Some v -> v diff --git a/upstream/ocaml_503/parsing/longident.mli b/upstream/ocaml_503/parsing/longident.mli new file mode 100644 index 000000000..8704a7780 --- /dev/null +++ b/upstream/ocaml_503/parsing/longident.mli @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Long identifiers, used in parsetree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + + To print a longident, see {!Pprintast.longident}, using + {!Format.asprintf} to convert to a string. + +*) + +type t = + Lident of string + | Ldot of t * string + | Lapply of t * t + +val flatten: t -> string list +val unflatten: string list -> t option +(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is + the long identifier created by concatenating the elements of [l] + with [Ldot]. + [unflatten []] is [None]. +*) + +val last: t -> string +val parse: string -> t +[@@deprecated "this function may misparse its input,\n\ +use \"Parse.longident\" or \"Longident.unflatten\""] +(** + + This function is broken on identifiers that are not just "Word.Word.word"; + for example, it returns incorrect results on infix operators + and extended module paths. + + If you want to generate long identifiers that are a list of + dot-separated identifiers, the function {!unflatten} is safer and faster. + {!unflatten} is available since OCaml 4.06.0. + + If you want to parse any identifier correctly, use the long-identifiers + functions from the {!Parse} module, in particular {!Parse.longident}. + They are available since OCaml 4.11, and also provide proper + input-location support. + +*) diff --git a/upstream/ocaml_503/parsing/parse.ml b/upstream/ocaml_503/parsing/parse.ml new file mode 100644 index 000000000..ead7f2b2f --- /dev/null +++ b/upstream/ocaml_503/parsing/parse.ml @@ -0,0 +1,178 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Entry points in the parser *) + +(* Skip tokens to the end of the phrase *) + +let last_token = ref Parser.EOF + +let token lexbuf = + let token = Lexer.token lexbuf in + last_token := token; + token + +let rec skip_phrase lexbuf = + match token lexbuf with + | Parser.SEMISEMI | Parser.EOF -> () + | _ -> skip_phrase lexbuf + | exception (Lexer.Error (Lexer.Unterminated_comment _, _) + | Lexer.Error (Lexer.Unterminated_string, _) + | Lexer.Error (Lexer.Reserved_sequence _, _) + | Lexer.Error (Lexer.Unterminated_string_in_comment _, _) + | Lexer.Error (Lexer.Illegal_character _, _)) -> + skip_phrase lexbuf + +let maybe_skip_phrase lexbuf = + match !last_token with + | Parser.SEMISEMI | Parser.EOF -> () + | _ -> skip_phrase lexbuf + +type 'a parser = + (Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> 'a + +let wrap (parser : 'a parser) lexbuf : 'a = + try + Docstrings.init (); + Lexer.init (); + let ast = parser token lexbuf in + Parsing.clear_parser(); + Docstrings.warn_bad_docstrings (); + last_token := Parser.EOF; + ast + with + | Lexer.Error(Lexer.Illegal_character _, _) as err + when !Location.input_name = "//toplevel//"-> + skip_phrase lexbuf; + raise err + | Syntaxerr.Error _ as err + when !Location.input_name = "//toplevel//" -> + maybe_skip_phrase lexbuf; + raise err + | Parsing.Parse_error | Syntaxerr.Escape_error -> + let loc = Location.curr lexbuf in + if !Location.input_name = "//toplevel//" + then maybe_skip_phrase lexbuf; + raise(Syntaxerr.Error(Syntaxerr.Other loc)) + +(* We pass [--strategy simplified] to Menhir, which means that we wish to use + its "simplified" strategy for handling errors. When a syntax error occurs, + the current token is replaced with an [error] token. The parser then + continues shifting and reducing, as far as possible. After (possibly) + shifting the [error] token, though, the parser remains in error-handling + mode, and does not request the next token, so the current token remains + [error]. + + In OCaml's grammar, the [error] token always appears at the end of a + production, and this production always raises an exception. In such + a situation, the strategy described above means that: + + - either the parser will not be able to shift [error], + and will raise [Parser.Error]; + + - or it will be able to shift [error] and will then reduce + a production whose semantic action raises an exception. + + In either case, the parser will not attempt to read one token past + the syntax error. *) + +let implementation = wrap Parser.implementation +and interface = wrap Parser.interface +and toplevel_phrase = wrap Parser.toplevel_phrase +and use_file = wrap Parser.use_file +and core_type = wrap Parser.parse_core_type +and expression = wrap Parser.parse_expression +and pattern = wrap Parser.parse_pattern +let module_type = wrap Parser.parse_module_type +let module_expr = wrap Parser.parse_module_expr + +let longident = wrap Parser.parse_any_longident +let val_ident = wrap Parser.parse_val_longident +let constr_ident= wrap Parser.parse_constr_longident +let extended_module_path = wrap Parser.parse_mod_ext_longident +let simple_module_path = wrap Parser.parse_mod_longident +let type_ident = wrap Parser.parse_mty_longident + +(* Error reporting for Syntaxerr *) +(* The code has been moved here so that one can reuse Pprintast.tyvar *) + +module Style = Misc.Style + +let prepare_error err = + let open Syntaxerr in + match err with + | Unclosed(opening_loc, opening, closing_loc, closing) -> + Location.errorf + ~loc:closing_loc + ~sub:[ + Location.msg ~loc:opening_loc + "This %a might be unmatched" Style.inline_code opening + ] + "Syntax error: %a expected" Style.inline_code closing + + | Expecting (loc, nonterm) -> + Location.errorf ~loc "Syntax error: %a expected." + Style.inline_code nonterm + | Not_expecting (loc, nonterm) -> + Location.errorf ~loc "Syntax error: %a not expected." + Style.inline_code nonterm + | Applicative_path loc -> + Location.errorf ~loc + "Syntax error: applicative paths of the form %a \ + are not supported when the option %a is set." + Style.inline_code "F(X).t" + Style.inline_code "-no-app-func" + | Variable_in_scope (loc, var) -> + Location.errorf ~loc + "In this scoped type, variable %a \ + is reserved for the local type %a." + (Style.as_inline_code Pprintast.Doc.tyvar) var + Style.inline_code var + | Other loc -> + Location.errorf ~loc "Syntax error" + | Ill_formed_ast (loc, s) -> + Location.errorf ~loc + "broken invariant in parsetree: %s" s + | Invalid_package_type (loc, ipt) -> + let invalid ppf ipt = match ipt with + | Syntaxerr.Parameterized_types -> + Format_doc.fprintf ppf "parametrized types are not supported" + | Constrained_types -> + Format_doc.fprintf ppf "constrained types are not supported" + | Private_types -> + Format_doc.fprintf ppf "private types are not supported" + | Not_with_type -> + Format_doc.fprintf ppf "only %a constraints are supported" + Style.inline_code "with type t =" + | Neither_identifier_nor_with_type -> + Format_doc.fprintf ppf + "only module type identifier and %a constraints are supported" + Style.inline_code "with type" + in + Location.errorf ~loc "Syntax error: invalid package type: %a" invalid ipt + | Removed_string_set loc -> + Location.errorf ~loc + "Syntax error: strings are immutable, there is no assignment \ + syntax for them.\n\ + @{Hint@}: Mutable sequences of bytes are available in \ + the Bytes module.\n\ + @{Hint@}: Did you mean to use %a?" + Style.inline_code "Bytes.set" +let () = + Location.register_error_of_exn + (function + | Syntaxerr.Error err -> Some (prepare_error err) + | _ -> None + ) diff --git a/upstream/ocaml_503/parsing/parse.mli b/upstream/ocaml_503/parsing/parse.mli new file mode 100644 index 000000000..0de6b48a1 --- /dev/null +++ b/upstream/ocaml_503/parsing/parse.mli @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Entry points in the parser + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +val implementation : Lexing.lexbuf -> Parsetree.structure +val interface : Lexing.lexbuf -> Parsetree.signature +val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase +val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list +val core_type : Lexing.lexbuf -> Parsetree.core_type +val expression : Lexing.lexbuf -> Parsetree.expression +val pattern : Lexing.lexbuf -> Parsetree.pattern +val module_type : Lexing.lexbuf -> Parsetree.module_type +val module_expr : Lexing.lexbuf -> Parsetree.module_expr + +(** The functions below can be used to parse Longident safely. *) + +val longident: Lexing.lexbuf -> Longident.t +(** + The function [longident] is guaranteed to parse all subclasses + of {!Longident.t} used in OCaml: values, constructors, simple or extended + module paths, and types or module types. + + However, this function accepts inputs which are not accepted by the + compiler, because they combine functor applications and infix operators. + In valid OCaml syntax, only value-level identifiers may end with infix + operators [Foo.( + )]. + Moreover, in value-level identifiers the module path [Foo] must be simple + ([M.N] rather than [F(X)]): functor applications may only appear in + type-level identifiers. + As a consequence, a path such as [F(X).( + )] is not a valid OCaml + identifier; but it is accepted by this function. +*) + +(** The next functions are specialized to a subclass of {!Longident.t} *) + +val val_ident: Lexing.lexbuf -> Longident.t +(** + This function parses a syntactically valid path for a value. For instance, + [x], [M.x], and [(+.)] are valid. Contrarily, [M.A], [F(X).x], and [true] + are rejected. + + Longident for OCaml's value cannot contain functor application. + The last component of the {!Longident.t} is not capitalized, + but can be an operator [A.Path.To.(.%.%.(;..)<-)] +*) + +val constr_ident: Lexing.lexbuf -> Longident.t +(** + This function parses a syntactically valid path for a variant constructor. + For instance, [A], [M.A] and [M.(::)] are valid, but both [M.a] + and [F(X).A] are rejected. + + Longident for OCaml's variant constructors cannot contain functor + application. + The last component of the {!Longident.t} is capitalized, + or it may be one the special constructors: [true],[false],[()],[[]],[(::)]. + Among those special constructors, only [(::)] can be prefixed by a module + path ([A.B.C.(::)]). +*) + + +val simple_module_path: Lexing.lexbuf -> Longident.t +(** + This function parses a syntactically valid path for a module. + For instance, [A], and [M.A] are valid, but both [M.a] + and [F(X).A] are rejected. + + Longident for OCaml's module cannot contain functor application. + The last component of the {!Longident.t} is capitalized. +*) + + +val extended_module_path: Lexing.lexbuf -> Longident.t +(** + This function parse syntactically valid path for an extended module. + For instance, [A.B] and [F(A).B] are valid. Contrarily, + [(.%())] or [[]] are both rejected. + + The last component of the {!Longident.t} is capitalized. + +*) + +val type_ident: Lexing.lexbuf -> Longident.t +(** + This function parse syntactically valid path for a type or a module type. + For instance, [A], [t], [M.t] and [F(X).t] are valid. Contrarily, + [(.%())] or [[]] are both rejected. + + In path for type and module types, only operators and special constructors + are rejected. + +*) diff --git a/upstream/ocaml_503/parsing/parser.mly b/upstream/ocaml_503/parsing/parser.mly new file mode 100644 index 000000000..84597d962 --- /dev/null +++ b/upstream/ocaml_503/parsing/parser.mly @@ -0,0 +1,4152 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* The parser definition */ + +/* The commands [make list-parse-errors] and [make generate-parse-errors] + run Menhir on a modified copy of the parser where every block of + text comprised between the markers [BEGIN AVOID] and ----------- + [END AVOID] has been removed. This file should be formatted in + such a way that this results in a clean removal of certain + symbols, productions, or declarations. */ + +%{ + +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + +open Asttypes +open Longident +open Parsetree +open Ast_helper +open Docstrings +open Docstrings.WithMenhir + +let mkloc = Location.mkloc +let mknoloc = Location.mknoloc + +let make_loc (startpos, endpos) = { + Location.loc_start = startpos; + Location.loc_end = endpos; + Location.loc_ghost = false; +} + +let ghost_loc (startpos, endpos) = { + Location.loc_start = startpos; + Location.loc_end = endpos; + Location.loc_ghost = true; +} + +let mktyp ~loc ?attrs d = Typ.mk ~loc:(make_loc loc) ?attrs d +let mkpat ~loc d = Pat.mk ~loc:(make_loc loc) d +let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d +let mkmty ~loc ?attrs d = Mty.mk ~loc:(make_loc loc) ?attrs d +let mksig ~loc d = Sig.mk ~loc:(make_loc loc) d +let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d +let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d +let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d +let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d +let mkconst ~loc c = Const.mk ~loc:(make_loc loc) c + +let pstr_typext (te, ext) = + (Pstr_typext te, ext) +let pstr_primitive (vd, ext) = + (Pstr_primitive vd, ext) +let pstr_type ((nr, ext), tys) = + (Pstr_type (nr, tys), ext) +let pstr_exception (te, ext) = + (Pstr_exception te, ext) +let pstr_include (body, ext) = + (Pstr_include body, ext) +let pstr_recmodule (ext, bindings) = + (Pstr_recmodule bindings, ext) + +let psig_typext (te, ext) = + (Psig_typext te, ext) +let psig_value (vd, ext) = + (Psig_value vd, ext) +let psig_type ((nr, ext), tys) = + (Psig_type (nr, tys), ext) +let psig_typesubst ((nr, ext), tys) = + assert (nr = Recursive); (* see [no_nonrec_flag] *) + (Psig_typesubst tys, ext) +let psig_exception (te, ext) = + (Psig_exception te, ext) +let psig_include (body, ext) = + (Psig_include body, ext) + +let mkctf ~loc ?attrs ?docs d = + Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d +let mkcf ~loc ?attrs ?docs d = + Cf.mk ~loc:(make_loc loc) ?attrs ?docs d + +let mkrhs rhs loc = mkloc rhs (make_loc loc) +let ghrhs rhs loc = mkloc rhs (ghost_loc loc) + +let push_loc x acc = + if x.Location.loc_ghost + then acc + else x :: acc + +let reloc_pat ~loc x = + { x with ppat_loc = make_loc loc; + ppat_loc_stack = push_loc x.ppat_loc x.ppat_loc_stack } +let reloc_exp ~loc x = + { x with pexp_loc = make_loc loc; + pexp_loc_stack = push_loc x.pexp_loc x.pexp_loc_stack } +let reloc_typ ~loc x = + { x with ptyp_loc = make_loc loc; + ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack } + +let mkexpvar ~loc (name : string) = + mkexp ~loc (Pexp_ident(mkrhs (Lident name) loc)) + +let mkoperator = + mkexpvar + +let mkpatvar ~loc name = + mkpat ~loc (Ppat_var (mkrhs name loc)) + +(* + Ghost expressions and patterns: + expressions and patterns that do not appear explicitly in the + source file they have the loc_ghost flag set to true. + Then the profiler will not try to instrument them and the + -annot option will not try to display their type. + + Every grammar rule that generates an element with a location must + make at most one non-ghost element, the topmost one. + + How to tell whether your location must be ghost: + A location corresponds to a range of characters in the source file. + If the location contains a piece of code that is syntactically + valid (according to the documentation), and corresponds to the + AST node, then the location must be real; in all other cases, + it must be ghost. +*) +let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d +let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d +let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d +let ghloc ~loc d = { txt = d; loc = ghost_loc loc } +let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d +let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d + +let mkinfix arg1 op arg2 = + Pexp_apply(op, [Nolabel, arg1; Nolabel, arg2]) + +let neg_string f = + if String.length f > 0 && f.[0] = '-' + then String.sub f 1 (String.length f - 1) + else "-" ^ f + +(* Pre-apply the special [-], [-.], [+] and [+.] prefix operators into + constants if possible, otherwise turn them into the corresponding prefix + operators [~-], [~-.], etc.. *) +let mkuminus ~sloc ~oploc name arg = + match name, arg.pexp_desc, arg.pexp_attributes with + | "-", + Pexp_constant({pconst_desc = Pconst_integer (n,m); pconst_loc=_}), + [] -> + Pexp_constant(mkconst ~loc:sloc (Pconst_integer(neg_string n, m))) + | ("-" | "-."), + Pexp_constant({pconst_desc = Pconst_float (f, m); pconst_loc=_}), [] -> + Pexp_constant(mkconst ~loc:sloc (Pconst_float(neg_string f, m))) + | _ -> + Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) + +let mkuplus ~sloc ~oploc name arg = + let desc = arg.pexp_desc in + match name, desc, arg.pexp_attributes with + | "+", + Pexp_constant({pconst_desc = Pconst_integer _ as desc; pconst_loc=_}), + [] + | ("+" | "+."), + Pexp_constant({pconst_desc = Pconst_float _ as desc; pconst_loc=_}), + [] -> + Pexp_constant(mkconst ~loc:sloc desc) + | _ -> + Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) + +let mk_attr ~loc name payload = + Builtin_attributes.(register_attr Parser name); + Attr.mk ~loc name payload + +(* TODO define an abstraction boundary between locations-as-pairs + and locations-as-Location.t; it should be clear when we move from + one world to the other *) + +let mkexp_cons_desc consloc args = + Pexp_construct(mkrhs (Lident "::") consloc, Some args) +let mkexp_cons ~loc consloc args = + mkexp ~loc (mkexp_cons_desc consloc args) + +let mkpat_cons_desc consloc args = + Ppat_construct(mkrhs (Lident "::") consloc, Some ([], args)) +let mkpat_cons ~loc consloc args = + mkpat ~loc (mkpat_cons_desc consloc args) + +let ghexp_cons_desc consloc args = + Pexp_construct(ghrhs (Lident "::") consloc, Some args) +let ghpat_cons_desc consloc args = + Ppat_construct(ghrhs (Lident "::") consloc, Some ([], args)) + +let rec mktailexp nilloc = let open Location in function + [] -> + let nil = ghloc ~loc:nilloc (Lident "[]") in + Pexp_construct (nil, None), nilloc + | e1 :: el -> + let exp_el, el_loc = mktailexp nilloc el in + let loc = (e1.pexp_loc.loc_start, snd el_loc) in + let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in + ghexp_cons_desc loc arg, loc + +let rec mktailpat nilloc = let open Location in function + [] -> + let nil = ghloc ~loc:nilloc (Lident "[]") in + Ppat_construct (nil, None), nilloc + | p1 :: pl -> + let pat_pl, el_loc = mktailpat nilloc pl in + let loc = (p1.ppat_loc.loc_start, snd el_loc) in + let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in + ghpat_cons_desc loc arg, loc + +let mkstrexp e attrs = + { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } + +let mkexp_desc_constraint e t = + match t with + | Pconstraint t -> Pexp_constraint(e, t) + | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) + +let mkexp_constraint ~loc e t = + mkexp ~loc (mkexp_desc_constraint e t) + +let mkexp_opt_constraint ~loc e = function + | None -> e + | Some constraint_ -> mkexp_constraint ~loc e constraint_ + +let mkpat_opt_constraint ~loc p = function + | None -> p + | Some typ -> mkpat ~loc (Ppat_constraint(p, typ)) + +let syntax_error () = + raise Syntaxerr.Escape_error + +let unclosed opening_name opening_loc closing_name closing_loc = + raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name, + make_loc closing_loc, closing_name))) + +let expecting loc nonterm = + raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm))) + +let removed_string_set loc = + raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc))) + +(* Using the function [not_expecting] in a semantic action means that this + syntactic form is recognized by the parser but is in fact incorrect. This + idiom is used in a few places to produce ad hoc syntax error messages. *) + +(* This idiom should be used as little as possible, because it confuses the + analyses performed by Menhir. Because Menhir views the semantic action as + opaque, it believes that this syntactic form is correct. This can lead + [make generate-parse-errors] to produce sentences that cause an early + (unexpected) syntax error and do not achieve the desired effect. This could + also lead a completion system to propose completions which in fact are + incorrect. In order to avoid these problems, the productions that use + [not_expecting] should be marked with AVOID. *) + +let not_expecting loc nonterm = + raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm))) + +(* Helper functions for desugaring array indexing operators *) +type paren_kind = Paren | Brace | Bracket + +(* We classify the dimension of indices: Bigarray distinguishes + indices of dimension 1,2,3, or more. Similarly, user-defined + indexing operator behave differently for indices of dimension 1 + or more. +*) +type index_dim = + | One + | Two + | Three + | Many +type ('dot,'index) array_family = { + + name: + Lexing.position * Lexing.position -> 'dot -> assign:bool -> paren_kind + -> index_dim -> Longident.t Location.loc + (* + This functions computes the name of the explicit indexing operator + associated with a sugared array indexing expression. + + For instance, for builtin arrays, if Clflags.unsafe is set, + * [ a.[index] ] => [String.unsafe_get] + * [ a.{x,y} <- 1 ] => [ Bigarray.Array2.unsafe_set] + + User-defined indexing operator follows a more local convention: + * [ a .%(index)] => [ (.%()) ] + * [ a.![1;2] <- 0 ] => [(.![;..]<-)] + * [ a.My.Map.?(0) => [My.Map.(.?())] + *); + + index: + Lexing.position * Lexing.position -> paren_kind -> 'index + -> index_dim * (arg_label * expression) list + (* + [index (start,stop) paren index] computes the dimension of the + index argument and how it should be desugared when transformed + to a list of arguments for the indexing operator. + In particular, in both the Bigarray case and the user-defined case, + beyond a certain dimension, multiple indices are packed into a single + array argument: + * [ a.(x) ] => [ [One, [Nolabel, <>] ] + * [ a.{1,2} ] => [ [Two, [Nolabel, <<1>>; Nolabel, <<2>>] ] + * [ a.{1,2,3,4} ] => [ [Many, [Nolabel, <<[|1;2;3;4|]>>] ] ] + *); + +} + +let bigarray_untuplify = function + { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist + | exp -> [exp] + +let builtin_arraylike_name loc _ ~assign paren_kind n = + let opname = if assign then "set" else "get" in + let opname = if !Clflags.unsafe then "unsafe_" ^ opname else opname in + let prefix = match paren_kind with + | Paren -> Lident "Array" + | Bracket -> + if assign then removed_string_set loc + else Lident "String" + | Brace -> + let submodule_name = match n with + | One -> "Array1" + | Two -> "Array2" + | Three -> "Array3" + | Many -> "Genarray" in + Ldot(Lident "Bigarray", submodule_name) in + ghloc ~loc (Ldot(prefix,opname)) + +let builtin_arraylike_index loc paren_kind index = match paren_kind with + | Paren | Bracket -> One, [Nolabel, index] + | Brace -> + (* Multi-indices for bigarray are comma-separated ([a.{1,2,3,4}]) *) + match bigarray_untuplify index with + | [x] -> One, [Nolabel, x] + | [x;y] -> Two, [Nolabel, x; Nolabel, y] + | [x;y;z] -> Three, [Nolabel, x; Nolabel, y; Nolabel, z] + | coords -> Many, [Nolabel, ghexp ~loc (Pexp_array coords)] + +let builtin_indexing_operators : (unit, expression) array_family = + { index = builtin_arraylike_index; name = builtin_arraylike_name } + +let paren_to_strings = function + | Paren -> "(", ")" + | Bracket -> "[", "]" + | Brace -> "{", "}" + +let user_indexing_operator_name loc (prefix,ext) ~assign paren_kind n = + let name = + let assign = if assign then "<-" else "" in + let mid = match n with + | Many | Three | Two -> ";.." + | One -> "" in + let left, right = paren_to_strings paren_kind in + String.concat "" ["."; ext; left; mid; right; assign] in + let lid = match prefix with + | None -> Lident name + | Some p -> Ldot(p,name) in + ghloc ~loc lid + +let user_index loc _ index = + (* Multi-indices for user-defined operators are semicolon-separated + ([a.%[1;2;3;4]]) *) + match index with + | [a] -> One, [Nolabel, a] + | l -> Many, [Nolabel, mkexp ~loc (Pexp_array l)] + +let user_indexing_operators: + (Longident.t option * string, expression list) array_family + = { index = user_index; name = user_indexing_operator_name } + +let mk_indexop_expr array_indexing_operator ~loc + (array,dot,paren,index,set_expr) = + let assign = match set_expr with None -> false | Some _ -> true in + let n, index = array_indexing_operator.index loc paren index in + let fn = array_indexing_operator.name loc dot ~assign paren n in + let set_arg = match set_expr with + | None -> [] + | Some expr -> [Nolabel, expr] in + let args = (Nolabel,array) :: index @ set_arg in + mkexp ~loc (Pexp_apply(ghexp ~loc (Pexp_ident fn), args)) + +let indexop_unclosed_error loc_s s loc_e = + let left, right = paren_to_strings s in + unclosed left loc_s right loc_e + +let lapply ~loc p1 p2 = + if !Clflags.applicative_functors + then Lapply(p1, p2) + else raise (Syntaxerr.Error( + Syntaxerr.Applicative_path (make_loc loc))) + +(* [loc_map] could be [Location.map]. *) +let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc = + { x with txt = f x.txt } + +let make_ghost x = { x with loc = { x.loc with loc_ghost = true }} + +let loc_last (id : Longident.t Location.loc) : string Location.loc = + loc_map Longident.last id + +let loc_lident (id : string Location.loc) : Longident.t Location.loc = + loc_map (fun x -> Lident x) id + +let exp_of_longident lid = + let lid = loc_map (fun id -> Lident (Longident.last id)) lid in + Exp.mk ~loc:lid.loc (Pexp_ident lid) + +let exp_of_label lbl = + Exp.mk ~loc:lbl.loc (Pexp_ident (loc_lident lbl)) + +let pat_of_label lbl = + Pat.mk ~loc:lbl.loc (Ppat_var (loc_last lbl)) + +let mk_newtypes ~loc newtypes exp = + let mkexp = mkexp ~loc in + List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) + newtypes exp + +let wrap_type_annotation ~loc newtypes core_type body = + let mkexp, ghtyp = mkexp ~loc, ghtyp ~loc in + let mk_newtypes = mk_newtypes ~loc in + let exp = mkexp(Pexp_constraint(body,core_type)) in + let exp = mk_newtypes newtypes exp in + (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type))) + +let wrap_exp_attrs ~loc body (ext, attrs) = + let ghexp = ghexp ~loc in + (* todo: keep exact location for the entire attribute *) + let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in + match ext with + | None -> body + | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []])) + +let mkexp_attrs ~loc d attrs = + wrap_exp_attrs ~loc (mkexp ~loc d) attrs + +let wrap_typ_attrs ~loc typ (ext, attrs) = + (* todo: keep exact location for the entire attribute *) + let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in + match ext with + | None -> typ + | Some id -> ghtyp ~loc (Ptyp_extension (id, PTyp typ)) + +let wrap_pat_attrs ~loc pat (ext, attrs) = + (* todo: keep exact location for the entire attribute *) + let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in + match ext with + | None -> pat + | Some id -> ghpat ~loc (Ppat_extension (id, PPat (pat, None))) + +let mkpat_attrs ~loc d attrs = + wrap_pat_attrs ~loc (mkpat ~loc d) attrs + +let wrap_class_attrs ~loc:_ body attrs = + {body with pcl_attributes = attrs @ body.pcl_attributes} +let wrap_mod_attrs ~loc:_ attrs body = + {body with pmod_attributes = attrs @ body.pmod_attributes} +let wrap_mty_attrs ~loc:_ attrs body = + {body with pmty_attributes = attrs @ body.pmty_attributes} + +let wrap_str_ext ~loc body ext = + match ext with + | None -> body + | Some id -> ghstr ~loc (Pstr_extension ((id, PStr [body]), [])) + +let wrap_mkstr_ext ~loc (item, ext) = + wrap_str_ext ~loc (mkstr ~loc item) ext + +let wrap_sig_ext ~loc body ext = + match ext with + | None -> body + | Some id -> ghsig ~loc (Psig_extension ((id, PSig [body]), [])) + +let wrap_mksig_ext ~loc (item, ext) = + wrap_sig_ext ~loc (mksig ~loc item) ext + +let mk_quotedext ~loc (id, idloc, str, strloc, delim) = + let exp_id = mkloc id idloc in + let const = Const.mk ~loc:strloc (Pconst_string (str, strloc, delim)) in + let e = ghexp ~loc (Pexp_constant const) in + (exp_id, PStr [mkstrexp e []]) + +let text_str pos = Str.text (rhs_text pos) +let text_sig pos = Sig.text (rhs_text pos) +let text_cstr pos = Cf.text (rhs_text pos) +let text_csig pos = Ctf.text (rhs_text pos) +let text_def pos = + List.map (fun def -> Ptop_def [def]) (Str.text (rhs_text pos)) + +let extra_text startpos endpos text items = + match items with + | [] -> + let post = rhs_post_text endpos in + let post_extras = rhs_post_extra_text endpos in + text post @ text post_extras + | _ :: _ -> + let pre_extras = rhs_pre_extra_text startpos in + let post_extras = rhs_post_extra_text endpos in + text pre_extras @ items @ text post_extras + +let extra_str p1 p2 items = extra_text p1 p2 Str.text items +let extra_sig p1 p2 items = extra_text p1 p2 Sig.text items +let extra_cstr p1 p2 items = extra_text p1 p2 Cf.text items +let extra_csig p1 p2 items = extra_text p1 p2 Ctf.text items +let extra_def p1 p2 items = + extra_text p1 p2 + (fun txt -> List.map (fun def -> Ptop_def [def]) (Str.text txt)) + items + +let extra_rhs_core_type ct ~pos = + let docs = rhs_info pos in + { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes } + +type let_binding = + { lb_pattern: pattern; + lb_expression: expression; + lb_constraint: value_constraint option; + lb_is_pun: bool; + lb_attributes: attributes; + lb_docs: docs Lazy.t; + lb_text: text Lazy.t; + lb_loc: Location.t; } + +type let_bindings = + { lbs_bindings: let_binding list; + lbs_rec: rec_flag; + lbs_extension: string Asttypes.loc option } + +let mklb first ~loc (p, e, typ, is_pun) attrs = + { + lb_pattern = p; + lb_expression = e; + lb_constraint=typ; + lb_is_pun = is_pun; + lb_attributes = attrs; + lb_docs = symbol_docs_lazy loc; + lb_text = (if first then empty_text_lazy + else symbol_text_lazy (fst loc)); + lb_loc = make_loc loc; + } + +let addlb lbs lb = + if lb.lb_is_pun && lbs.lbs_extension = None then syntax_error (); + { lbs with lbs_bindings = lb :: lbs.lbs_bindings } + +let mklbs ext rf lb = + let lbs = { + lbs_bindings = []; + lbs_rec = rf; + lbs_extension = ext; + } in + addlb lbs lb + +let val_of_let_bindings ~loc lbs = + let bindings = + List.map + (fun lb -> + Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes + ~docs:(Lazy.force lb.lb_docs) + ~text:(Lazy.force lb.lb_text) + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) + lbs.lbs_bindings + in + let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in + match lbs.lbs_extension with + | None -> str + | Some id -> ghstr ~loc (Pstr_extension((id, PStr [str]), [])) + +let expr_of_let_bindings ~loc lbs body = + let bindings = + List.map + (fun lb -> + Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) + lbs.lbs_bindings + in + mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) + (lbs.lbs_extension, []) + +let class_of_let_bindings ~loc lbs body = + let bindings = + List.map + (fun lb -> + Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) + lbs.lbs_bindings + in + (* Our use of let_bindings(no_ext) guarantees the following: *) + assert (lbs.lbs_extension = None); + mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body)) + +(* If all the parameters are [Pparam_newtype x], then return [Some xs] where + [xs] is the corresponding list of values [x]. This function is optimized for + the common case, where a list of parameters contains at least one value + parameter. +*) +let all_params_as_newtypes = + let is_newtype { pparam_desc; _ } = + match pparam_desc with + | Pparam_newtype _ -> true + | Pparam_val _ -> false + in + let as_newtype { pparam_desc; pparam_loc } = + match pparam_desc with + | Pparam_newtype x -> Some (x, pparam_loc) + | Pparam_val _ -> None + in + fun params -> + if List.for_all is_newtype params + then Some (List.filter_map as_newtype params) + else None + +(* Given a construct [fun (type a b c) : t -> e], we construct + [Pexp_newtype(a, Pexp_newtype(b, Pexp_newtype(c, Pexp_constraint(e, t))))] + rather than a [Pexp_function]. +*) +let mkghost_newtype_function_body newtypes body_constraint body = + let wrapped_body = + match body_constraint with + | None -> body + | Some body_constraint -> + let loc = { body.pexp_loc with loc_ghost = true } in + Exp.mk (mkexp_desc_constraint body body_constraint) ~loc + in + let expr = + List.fold_right + (fun (newtype, newtype_loc) e -> + (* Mints a ghost location that approximates the newtype's "extent" as + being from the start of the newtype param until the end of the + function body. + *) + let loc = (newtype_loc.Location.loc_start, body.pexp_loc.loc_end) in + ghexp (Pexp_newtype (newtype, e)) ~loc) + newtypes + wrapped_body + in + expr.pexp_desc + +let mkfunction params body_constraint body = + match body with + | Pfunction_cases _ -> Pexp_function (params, body_constraint, body) + | Pfunction_body body_exp -> + (* If all the params are newtypes, then we don't create a function node; + we create nested newtype nodes. *) + match all_params_as_newtypes params with + | None -> Pexp_function (params, body_constraint, body) + | Some newtypes -> + mkghost_newtype_function_body newtypes body_constraint body_exp + +let mk_functor_typ args mty = + List.fold_left (fun acc (startpos, arg) -> + mkmty ~loc:(startpos, mty.pmty_loc.loc_end) (Pmty_functor (arg, acc))) + mty args + +(* Alternatively, we could keep the generic module type in the Parsetree + and extract the package type during type-checking. In that case, + the assertions below should be turned into explicit checks. *) +let package_type_of_module_type pmty = + let err loc s = + raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s))) + in + let map_cstr = function + | Pwith_type (lid, ptyp) -> + let loc = ptyp.ptype_loc in + if ptyp.ptype_params <> [] then + err loc Syntaxerr.Parameterized_types; + if ptyp.ptype_cstrs <> [] then + err loc Syntaxerr.Constrained_types; + if ptyp.ptype_private <> Public then + err loc Syntaxerr.Private_types; + + (* restrictions below are checked by the 'with_constraint' rule *) + assert (ptyp.ptype_kind = Ptype_abstract); + assert (ptyp.ptype_attributes = []); + let ty = + match ptyp.ptype_manifest with + | Some ty -> ty + | None -> assert false + in + (lid, ty) + | _ -> + err pmty.pmty_loc Not_with_type + in + match pmty with + | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes) + | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} -> + (lid, List.map map_cstr cstrs, pmty.pmty_attributes) + | _ -> + err pmty.pmty_loc Neither_identifier_nor_with_type + +let mk_directive_arg ~loc k = + { pdira_desc = k; + pdira_loc = make_loc loc; + } + +let mk_directive ~loc name arg = + Ptop_dir { + pdir_name = name; + pdir_arg = arg; + pdir_loc = make_loc loc; + } + +%} + +/* Tokens */ + +/* The alias that follows each token is used by Menhir when it needs to + produce a sentence (that is, a sequence of tokens) in concrete syntax. */ + +/* Some tokens represent multiple concrete strings. In most cases, an + arbitrary concrete string can be chosen. In a few cases, one must + be careful: e.g., in PREFIXOP and INFIXOP2, one must choose a concrete + string that will not trigger a syntax error; see how [not_expecting] + is used in the definition of [type_variance]. */ + +%token AMPERAMPER "&&" +%token AMPERSAND "&" +%token AND "and" +%token AS "as" +%token ASSERT "assert" +%token BACKQUOTE "`" +%token BANG "!" +%token BAR "|" +%token BARBAR "||" +%token BARRBRACKET "|]" +%token BEGIN "begin" +%token CHAR "'a'" (* just an example *) +%token CLASS "class" +%token COLON ":" +%token COLONCOLON "::" +%token COLONEQUAL ":=" +%token COLONGREATER ":>" +%token COMMA "," +%token CONSTRAINT "constraint" +%token DO "do" +%token DONE "done" +%token DOT "." +%token DOTDOT ".." +%token DOWNTO "downto" +%token EFFECT "effect" +%token ELSE "else" +%token END "end" +%token EOF "" +%token EQUAL "=" +%token EXCEPTION "exception" +%token EXTERNAL "external" +%token FALSE "false" +%token FLOAT "42.0" (* just an example *) +%token FOR "for" +%token FUN "fun" +%token FUNCTION "function" +%token FUNCTOR "functor" +%token GREATER ">" +%token GREATERRBRACE ">}" +%token GREATERRBRACKET ">]" +%token IF "if" +%token IN "in" +%token INCLUDE "include" +%token INFIXOP0 "!=" (* just an example *) +%token INFIXOP1 "@" (* just an example *) +%token INFIXOP2 "+!" (* chosen with care; see above *) +%token INFIXOP3 "land" (* just an example *) +%token INFIXOP4 "**" (* just an example *) +%token DOTOP ".+" +%token LETOP "let*" (* just an example *) +%token ANDOP "and*" (* just an example *) +%token INHERIT "inherit" +%token INITIALIZER "initializer" +%token INT "42" (* just an example *) +%token LABEL "~label:" (* just an example *) +%token LAZY "lazy" +%token LBRACE "{" +%token LBRACELESS "{<" +%token LBRACKET "[" +%token LBRACKETBAR "[|" +%token LBRACKETLESS "[<" +%token LBRACKETGREATER "[>" +%token LBRACKETPERCENT "[%" +%token LBRACKETPERCENTPERCENT "[%%" +%token LESS "<" +%token LESSMINUS "<-" +%token LET "let" +%token LIDENT "lident" (* just an example *) +%token LPAREN "(" +%token LBRACKETAT "[@" +%token LBRACKETATAT "[@@" +%token LBRACKETATATAT "[@@@" +%token MATCH "match" +%token METHOD "method" +%token MINUS "-" +%token MINUSDOT "-." +%token MINUSGREATER "->" +%token MODULE "module" +%token MUTABLE "mutable" +%token NEW "new" +%token NONREC "nonrec" +%token OBJECT "object" +%token OF "of" +%token OPEN "open" +%token OPTLABEL "?label:" (* just an example *) +%token OR "or" +/* %token PARSER "parser" */ +%token PERCENT "%" +%token PLUS "+" +%token PLUSDOT "+." +%token PLUSEQ "+=" +%token PREFIXOP "!+" (* chosen with care; see above *) +%token PRIVATE "private" +%token QUESTION "?" +%token QUOTE "'" +%token RBRACE "}" +%token RBRACKET "]" +%token REC "rec" +%token RPAREN ")" +%token SEMI ";" +%token SEMISEMI ";;" +%token HASH "#" +%token HASHOP "##" (* just an example *) +%token SIG "sig" +%token STAR "*" +%token + STRING "\"hello\"" (* just an example *) +%token + QUOTED_STRING_EXPR "{%hello|world|}" (* just an example *) +%token + QUOTED_STRING_ITEM "{%%hello|world|}" (* just an example *) +%token STRUCT "struct" +%token THEN "then" +%token TILDE "~" +%token TO "to" +%token TRUE "true" +%token TRY "try" +%token TYPE "type" +%token UIDENT "UIdent" (* just an example *) +%token UNDERSCORE "_" +%token VAL "val" +%token VIRTUAL "virtual" +%token WHEN "when" +%token WHILE "while" +%token WITH "with" +%token COMMENT "(* comment *)" +%token DOCSTRING "(** documentation *)" + +%token EOL "\\n" (* not great, but EOL is unused *) + +(* see the [metaocaml_expr] comment *) +%token METAOCAML_ESCAPE ".~" +%token METAOCAML_BRACKET_OPEN ".<" +%token METAOCAML_BRACKET_CLOSE ">." + +/* Precedences and associativities. + +Tokens and rules have precedences. A reduce/reduce conflict is resolved +in favor of the first rule (in source file order). A shift/reduce conflict +is resolved by comparing the precedence and associativity of the token to +be shifted with those of the rule to be reduced. + +By default, a rule has the precedence of its rightmost terminal (if any). + +When there is a shift/reduce conflict between a rule and a token that +have the same precedence, it is resolved using the associativity: +if the token is left-associative, the parser will reduce; if +right-associative, the parser will shift; if non-associative, +the parser will declare a syntax error. + +We will only use associativities with operators of the kind x * x -> x +for example, in the rules of the form expr: expr BINOP expr +in all other cases, we define two precedences if needed to resolve +conflicts. + +The precedences must be listed from low to high. +*/ + +%nonassoc IN +%nonassoc below_SEMI +%nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */ +%nonassoc LET /* above SEMI ( ...; let ... in ...) */ +%nonassoc below_WITH +%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */ +%nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */ +%nonassoc THEN /* below ELSE (if ... then ...) */ +%nonassoc ELSE /* (if ... then ... else ...) */ +%nonassoc LESSMINUS /* below COLONEQUAL (lbl <- x := e) */ +%right COLONEQUAL /* expr (e := e := e) */ +%nonassoc AS +%left BAR /* pattern (p|p|p) */ +%nonassoc below_COMMA +%left COMMA /* expr/expr_comma_list (e,e,e) */ +%right MINUSGREATER /* function_type (t -> t -> t) */ +%right OR BARBAR /* expr (e || e || e) */ +%right AMPERSAND AMPERAMPER /* expr (e && e && e) */ +%nonassoc below_EQUAL +%left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */ +%right INFIXOP1 /* expr (e OP e OP e) */ +%nonassoc below_LBRACKETAT +%nonassoc LBRACKETAT +%right COLONCOLON /* expr (e :: e :: e) */ +%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */ +%left PERCENT INFIXOP3 STAR /* expr (e OP e OP e) */ +%right INFIXOP4 /* expr (e OP e OP e) */ +%nonassoc prec_unary_minus prec_unary_plus /* unary - */ +%nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */ +%nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */ +%nonassoc below_HASH +%nonassoc HASH /* simple_expr/toplevel_directive */ +%left HASHOP +%nonassoc below_DOT +%nonassoc DOT DOTOP +/* Finally, the first tokens of simple_expr are above everything else. */ +%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT OBJECT + LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN + NEW PREFIXOP STRING TRUE UIDENT + LBRACKETPERCENT QUOTED_STRING_EXPR + METAOCAML_BRACKET_OPEN METAOCAML_ESCAPE + +/* Entry points */ + +/* Several start symbols are marked with AVOID so that they are not used by + [make generate-parse-errors]. The three start symbols that we keep are + [implementation], [use_file], and [toplevel_phrase]. The latter two are + of marginal importance; only [implementation] really matters, since most + states in the automaton are reachable from it. */ + +%start implementation /* for implementation files */ +%type implementation +/* BEGIN AVOID */ +%start interface /* for interface files */ +%type interface +/* END AVOID */ +%start toplevel_phrase /* for interactive use */ +%type toplevel_phrase +%start use_file /* for the #use directive */ +%type use_file +/* BEGIN AVOID */ +%start parse_module_type +%type parse_module_type +%start parse_module_expr +%type parse_module_expr +%start parse_core_type +%type parse_core_type +%start parse_expression +%type parse_expression +%start parse_pattern +%type parse_pattern +%start parse_constr_longident +%type parse_constr_longident +%start parse_val_longident +%type parse_val_longident +%start parse_mty_longident +%type parse_mty_longident +%start parse_mod_ext_longident +%type parse_mod_ext_longident +%start parse_mod_longident +%type parse_mod_longident +%start parse_any_longident +%type parse_any_longident +/* END AVOID */ + +%% + +/* macros */ +%inline extra_str(symb): symb { extra_str $startpos $endpos $1 }; +%inline extra_sig(symb): symb { extra_sig $startpos $endpos $1 }; +%inline extra_cstr(symb): symb { extra_cstr $startpos $endpos $1 }; +%inline extra_csig(symb): symb { extra_csig $startpos $endpos $1 }; +%inline extra_def(symb): symb { extra_def $startpos $endpos $1 }; +%inline extra_text(symb): symb { extra_text $startpos $endpos $1 }; +%inline extra_rhs(symb): symb { extra_rhs_core_type $1 ~pos:$endpos($1) }; +%inline mkrhs(symb): symb + { mkrhs $1 $sloc } +; + +%inline text_str(symb): symb + { text_str $startpos @ [$1] } +%inline text_str_SEMISEMI: SEMISEMI + { text_str $startpos } +%inline text_sig(symb): symb + { text_sig $startpos @ [$1] } +%inline text_sig_SEMISEMI: SEMISEMI + { text_sig $startpos } +%inline text_def(symb): symb + { text_def $startpos @ [$1] } +%inline top_def(symb): symb + { Ptop_def [$1] } +%inline text_cstr(symb): symb + { text_cstr $startpos @ [$1] } +%inline text_csig(symb): symb + { text_csig $startpos @ [$1] } + +(* Using this %inline definition means that we do not control precisely + when [mark_rhs_docs] is called, but I don't think this matters. *) +%inline mark_rhs_docs(symb): symb + { mark_rhs_docs $startpos $endpos; + $1 } + +%inline op(symb): symb + { mkoperator ~loc:$sloc $1 } + +%inline mkloc(symb): symb + { mkloc $1 (make_loc $sloc) } + +%inline mkexp(symb): symb + { mkexp ~loc:$sloc $1 } +%inline mkpat(symb): symb + { mkpat ~loc:$sloc $1 } +%inline mktyp(symb): symb + { mktyp ~loc:$sloc $1 } +%inline mkstr(symb): symb + { mkstr ~loc:$sloc $1 } +%inline mksig(symb): symb + { mksig ~loc:$sloc $1 } +%inline mkmod(symb): symb + { mkmod ~loc:$sloc $1 } +%inline mkmty(symb): symb + { mkmty ~loc:$sloc $1 } +%inline mkcty(symb): symb + { mkcty ~loc:$sloc $1 } +%inline mkctf(symb): symb + { mkctf ~loc:$sloc $1 } +%inline mkcf(symb): symb + { mkcf ~loc:$sloc $1 } +%inline mkclass(symb): symb + { mkclass ~loc:$sloc $1 } + +%inline wrap_mkstr_ext(symb): symb + { wrap_mkstr_ext ~loc:$sloc $1 } +%inline wrap_mksig_ext(symb): symb + { wrap_mksig_ext ~loc:$sloc $1 } + +%inline mk_directive_arg(symb): symb + { mk_directive_arg ~loc:$sloc $1 } + +/* Generic definitions */ + +(* [iloption(X)] recognizes either nothing or [X]. Assuming [X] produces + an OCaml list, it produces an OCaml list, too. *) + +%inline iloption(X): + /* nothing */ + { [] } +| x = X + { x } + +(* [llist(X)] recognizes a possibly empty list of [X]s. It is left-recursive. *) + +reversed_llist(X): + /* empty */ + { [] } +| xs = reversed_llist(X) x = X + { x :: xs } + +%inline llist(X): + xs = rev(reversed_llist(X)) + { xs } + +(* [reversed_nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces + an OCaml list in reverse order -- that is, the last element in the input text + appears first in this list. Its definition is left-recursive. *) + +reversed_nonempty_llist(X): + x = X + { [ x ] } +| xs = reversed_nonempty_llist(X) x = X + { x :: xs } + +(* [nonempty_llist(X)] recognizes a nonempty list of [X]s, and produces an OCaml + list in direct order -- that is, the first element in the input text appears + first in this list. *) + +%inline nonempty_llist(X): + xs = rev(reversed_nonempty_llist(X)) + { xs } + +(* [reversed_nonempty_concat(X)] recognizes a nonempty sequence of [X]s (each of + which is a list), and produces an OCaml list of their concatenation in + reverse order -- that is, the last element of the last list in the input text + appears first in the list. +*) +reversed_nonempty_concat(X): + x = X + { List.rev x } +| xs = reversed_nonempty_concat(X) x = X + { List.rev_append x xs } + +(* [nonempty_concat(X)] recognizes a nonempty sequence of [X]s + (each of which is a list), and produces an OCaml list of their concatenation + in direct order -- that is, the first element of the first list in the input + text appears first in the list. +*) + +%inline nonempty_concat(X): + xs = rev(reversed_nonempty_concat(X)) + { xs } + +(* [reversed_separated_nonempty_llist(separator, X)] recognizes a nonempty list + of [X]s, separated with [separator]s, and produces an OCaml list in reverse + order -- that is, the last element in the input text appears first in this + list. Its definition is left-recursive. *) + +(* [inline_reversed_separated_nonempty_llist(separator, X)] is semantically + equivalent to [reversed_separated_nonempty_llist(separator, X)], but is + marked %inline, which means that the case of a list of length one and + the case of a list of length more than one will be distinguished at the + use site, and will give rise there to two productions. This can be used + to avoid certain conflicts. *) + +%inline inline_reversed_separated_nonempty_llist(separator, X): + x = X + { [ x ] } +| xs = reversed_separated_nonempty_llist(separator, X) + separator + x = X + { x :: xs } + +reversed_separated_nonempty_llist(separator, X): + xs = inline_reversed_separated_nonempty_llist(separator, X) + { xs } + +(* [separated_nonempty_llist(separator, X)] recognizes a nonempty list of [X]s, + separated with [separator]s, and produces an OCaml list in direct order -- + that is, the first element in the input text appears first in this list. *) + +%inline separated_nonempty_llist(separator, X): + xs = rev(reversed_separated_nonempty_llist(separator, X)) + { xs } + +%inline inline_separated_nonempty_llist(separator, X): + xs = rev(inline_reversed_separated_nonempty_llist(separator, X)) + { xs } + +(* [reversed_separated_nontrivial_llist(separator, X)] recognizes a list of at + least two [X]s, separated with [separator]s, and produces an OCaml list in + reverse order -- that is, the last element in the input text appears first + in this list. Its definition is left-recursive. *) + +reversed_separated_nontrivial_llist(separator, X): + xs = reversed_separated_nontrivial_llist(separator, X) + separator + x = X + { x :: xs } +| x1 = X + separator + x2 = X + { [ x2; x1 ] } + +(* [separated_nontrivial_llist(separator, X)] recognizes a list of at least + two [X]s, separated with [separator]s, and produces an OCaml list in direct + order -- that is, the first element in the input text appears first in this + list. *) + +%inline separated_nontrivial_llist(separator, X): + xs = rev(reversed_separated_nontrivial_llist(separator, X)) + { xs } + +(* [separated_or_terminated_nonempty_list(delimiter, X)] recognizes a nonempty + list of [X]s, separated with [delimiter]s, and optionally terminated with a + final [delimiter]. Its definition is right-recursive. *) + +separated_or_terminated_nonempty_list(delimiter, X): + x = X ioption(delimiter) + { [x] } +| x = X + delimiter + xs = separated_or_terminated_nonempty_list(delimiter, X) + { x :: xs } + +(* [reversed_preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a + nonempty list of [X]s, separated with [delimiter]s, and optionally preceded + with a leading [delimiter]. It produces an OCaml list in reverse order. Its + definition is left-recursive. *) + +reversed_preceded_or_separated_nonempty_llist(delimiter, X): + ioption(delimiter) x = X + { [x] } +| xs = reversed_preceded_or_separated_nonempty_llist(delimiter, X) + delimiter + x = X + { x :: xs } + +(* [preceded_or_separated_nonempty_llist(delimiter, X)] recognizes a nonempty + list of [X]s, separated with [delimiter]s, and optionally preceded with a + leading [delimiter]. It produces an OCaml list in direct order. *) + +%inline preceded_or_separated_nonempty_llist(delimiter, X): + xs = rev(reversed_preceded_or_separated_nonempty_llist(delimiter, X)) + { xs } + +(* [bar_llist(X)] recognizes a nonempty list of [X]'s, separated with BARs, + with an optional leading BAR. We assume that [X] is itself parameterized + with an opening symbol, which can be [epsilon] or [BAR]. *) + +(* This construction may seem needlessly complicated: one might think that + using [preceded_or_separated_nonempty_llist(BAR, X)], where [X] is *not* + itself parameterized, would be sufficient. Indeed, this simpler approach + would recognize the same language. However, the two approaches differ in + the footprint of [X]. We want the start location of [X] to include [BAR] + when present. In the future, we might consider switching to the simpler + definition, at the cost of producing slightly different locations. TODO *) + +reversed_bar_llist(X): + (* An [X] without a leading BAR. *) + x = X(epsilon) + { [x] } + | (* An [X] with a leading BAR. *) + x = X(BAR) + { [x] } + | (* An initial list, followed with a BAR and an [X]. *) + xs = reversed_bar_llist(X) + x = X(BAR) + { x :: xs } + +%inline bar_llist(X): + xs = reversed_bar_llist(X) + { List.rev xs } + +(* [xlist(A, B)] recognizes [AB*]. We assume that the semantic value for [A] + is a pair [x, b], while the semantic value for [B*] is a list [bs]. + We return the pair [x, b :: bs]. *) + +%inline xlist(A, B): + a = A bs = B* + { let (x, b) = a in x, b :: bs } + +(* [listx(delimiter, X, Y)] recognizes a nonempty list of [X]s, optionally + followed with a [Y], separated-or-terminated with [delimiter]s. The + semantic value is a pair of a list of [X]s and an optional [Y]. *) + +listx(delimiter, X, Y): +| x = X ioption(delimiter) + { [x], None } +| x = X delimiter y = Y delimiter? + { [x], Some y } +| x = X + delimiter + tail = listx(delimiter, X, Y) + { let xs, y = tail in + x :: xs, y } + +(* -------------------------------------------------------------------------- *) + +(* Entry points. *) + +(* An .ml file. *) +implementation: + structure EOF + { $1 } +; + +/* BEGIN AVOID */ +(* An .mli file. *) +interface: + signature EOF + { $1 } +; +/* END AVOID */ + +(* A toplevel phrase. *) +toplevel_phrase: + (* An expression with attributes, ended by a double semicolon. *) + extra_str(text_str(str_exp)) + SEMISEMI + { Ptop_def $1 } +| (* A list of structure items, ended by a double semicolon. *) + extra_str(flatten(text_str(structure_item)*)) + SEMISEMI + { Ptop_def $1 } +| (* A directive, ended by a double semicolon. *) + toplevel_directive + SEMISEMI + { $1 } +| (* End of input. *) + EOF + { raise End_of_file } +; + +(* An .ml file that is read by #use. *) +use_file: + (* An optional standalone expression, + followed with a series of elements, + followed with EOF. *) + extra_def(append( + optional_use_file_standalone_expression, + flatten(use_file_element*) + )) + EOF + { $1 } +; + +(* An optional standalone expression is just an expression with attributes + (str_exp), with extra wrapping. *) +%inline optional_use_file_standalone_expression: + iloption(text_def(top_def(str_exp))) + { $1 } +; + +(* An element in a #used file is one of the following: + - a double semicolon followed with an optional standalone expression; + - a structure item; + - a toplevel directive. + *) +%inline use_file_element: + preceded(SEMISEMI, optional_use_file_standalone_expression) +| text_def(top_def(structure_item)) +| text_def(mark_rhs_docs(toplevel_directive)) + { $1 } +; + +/* BEGIN AVOID */ +parse_module_type: + module_type EOF + { $1 } +; + +parse_module_expr: + module_expr EOF + { $1 } +; + +parse_core_type: + core_type EOF + { $1 } +; + +parse_expression: + seq_expr EOF + { $1 } +; + +parse_pattern: + pattern EOF + { $1 } +; + +parse_mty_longident: + mty_longident EOF + { $1 } +; + +parse_val_longident: + val_longident EOF + { $1 } +; + +parse_constr_longident: + constr_longident EOF + { $1 } +; + +parse_mod_ext_longident: + mod_ext_longident EOF + { $1 } +; + +parse_mod_longident: + mod_longident EOF + { $1 } +; + +parse_any_longident: + any_longident EOF + { $1 } +; +/* END AVOID */ + +(* -------------------------------------------------------------------------- *) + +(* Functor arguments appear in module expressions and module types. *) + +%inline functor_args: + reversed_nonempty_llist(functor_arg) + { $1 } + (* Produce a reversed list on purpose; + later processed using [fold_left]. *) +; + +functor_arg: + (* An anonymous and untyped argument. *) + LPAREN RPAREN + { $startpos, Unit } + | (* An argument accompanied with an explicit type. *) + LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN + { $startpos, Named (x, mty) } +; + +module_name: + (* A named argument. *) + x = UIDENT + { Some x } + | (* An anonymous argument. *) + UNDERSCORE + { None } +; + +(* -------------------------------------------------------------------------- *) + +(* Module expressions. *) + +(* The syntax of module expressions is not properly stratified. The cases of + functors, functor applications, and attributes interact and cause conflicts, + which are resolved by precedence declarations. This is concise but fragile. + Perhaps in the future an explicit stratification could be used. *) + +module_expr: + | STRUCT attrs = attributes s = structure END + { mkmod ~loc:$sloc ~attrs (Pmod_structure s) } + | STRUCT attributes structure error + { unclosed "struct" $loc($1) "end" $loc($4) } + | SIG error + { expecting $loc($1) "struct" } + | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr + { wrap_mod_attrs ~loc:$sloc attrs ( + List.fold_left (fun acc (startpos, arg) -> + mkmod ~loc:(startpos, $endpos) (Pmod_functor (arg, acc)) + ) me args + ) } + | me = paren_module_expr + { me } + | me = module_expr attr = attribute + { Mod.attr me attr } + | mkmod( + (* A module identifier. *) + x = mkrhs(mod_longident) + { Pmod_ident x } + | (* In a functor application, the actual argument must be parenthesized. *) + me1 = module_expr me2 = paren_module_expr + { Pmod_apply(me1, me2) } + | (* Functor applied to unit. *) + me = module_expr LPAREN RPAREN + { Pmod_apply_unit me } + | (* An extension. *) + ex = extension + { Pmod_extension ex } + ) + { $1 } +; + +(* A parenthesized module expression is a module expression that begins + and ends with parentheses. *) + +paren_module_expr: + (* A module expression annotated with a module type. *) + LPAREN me = module_expr COLON mty = module_type RPAREN + { mkmod ~loc:$sloc (Pmod_constraint(me, mty)) } + | LPAREN module_expr COLON module_type error + { unclosed "(" $loc($1) ")" $loc($5) } + | (* A module expression within parentheses. *) + LPAREN me = module_expr RPAREN + { me (* TODO consider reloc *) } + | LPAREN module_expr error + { unclosed "(" $loc($1) ")" $loc($3) } + | (* A core language expression that produces a first-class module. + This expression can be annotated in various ways. *) + LPAREN VAL attrs = attributes e = expr_colon_package_type RPAREN + { mkmod ~loc:$sloc ~attrs (Pmod_unpack e) } + | LPAREN VAL attributes expr COLON error + { unclosed "(" $loc($1) ")" $loc($6) } + | LPAREN VAL attributes expr COLONGREATER error + { unclosed "(" $loc($1) ")" $loc($6) } + | LPAREN VAL attributes expr error + { unclosed "(" $loc($1) ")" $loc($5) } +; + +(* The various ways of annotating a core language expression that + produces a first-class module that we wish to unpack. *) +%inline expr_colon_package_type: + e = expr + { e } + | e = expr COLON ty = package_type + { ghexp ~loc:$loc (Pexp_constraint (e, ty)) } + | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type + { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) } + | e = expr COLONGREATER ty2 = package_type + { ghexp ~loc:$loc (Pexp_coerce (e, None, ty2)) } +; + +(* A structure, which appears between STRUCT and END (among other places), + begins with an optional standalone expression, and continues with a list + of structure elements. *) +structure: + extra_str(append( + optional_structure_standalone_expression, + flatten(structure_element*) + )) + { $1 } +; + +(* An optional standalone expression is just an expression with attributes + (str_exp), with extra wrapping. *) +%inline optional_structure_standalone_expression: + items = iloption(mark_rhs_docs(text_str(str_exp))) + { items } +; + +(* An expression with attributes, wrapped as a structure item. *) +%inline str_exp: + e = seq_expr + attrs = post_item_attributes + { mkstrexp e attrs } +; + +(* A structure element is one of the following: + - a double semicolon followed with an optional standalone expression; + - a structure item. *) +%inline structure_element: + append(text_str_SEMISEMI, optional_structure_standalone_expression) + | text_str(structure_item) + { $1 } +; + +(* A structure item. *) +structure_item: + let_bindings(ext) + { val_of_let_bindings ~loc:$sloc $1 } + | mkstr( + item_extension post_item_attributes + { let docs = symbol_docs $sloc in + Pstr_extension ($1, add_docs_attrs docs $2) } + | floating_attribute + { Pstr_attribute $1 } + ) + | wrap_mkstr_ext( + primitive_declaration + { pstr_primitive $1 } + | value_description + { pstr_primitive $1 } + | type_declarations + { pstr_type $1 } + | str_type_extension + { pstr_typext $1 } + | str_exception_declaration + { pstr_exception $1 } + | module_binding + { $1 } + | rec_module_bindings + { pstr_recmodule $1 } + | module_type_declaration + { let (body, ext) = $1 in (Pstr_modtype body, ext) } + | open_declaration + { let (body, ext) = $1 in (Pstr_open body, ext) } + | class_declarations + { let (ext, l) = $1 in (Pstr_class l, ext) } + | class_type_declarations + { let (ext, l) = $1 in (Pstr_class_type l, ext) } + | include_statement(module_expr) + { pstr_include $1 } + ) + { $1 } +; + +(* A single module binding. *) +%inline module_binding: + MODULE + ext = ext attrs1 = attributes + name = mkrhs(module_name) + body = module_binding_body + attrs2 = post_item_attributes + { let docs = symbol_docs $sloc in + let loc = make_loc $sloc in + let attrs = attrs1 @ attrs2 in + let body = Mb.mk name body ~attrs ~loc ~docs in + Pstr_module body, ext } +; + +(* The body (right-hand side) of a module binding. *) +module_binding_body: + EQUAL me = module_expr + { me } + | COLON error + { expecting $loc($1) "=" } + | mkmod( + COLON mty = module_type EQUAL me = module_expr + { Pmod_constraint(me, mty) } + | arg_and_pos = functor_arg body = module_binding_body + { let (_, arg) = arg_and_pos in + Pmod_functor(arg, body) } + ) { $1 } +; + +(* A group of recursive module bindings. *) +%inline rec_module_bindings: + xlist(rec_module_binding, and_module_binding) + { $1 } +; + +(* The first binding in a group of recursive module bindings. *) +%inline rec_module_binding: + MODULE + ext = ext + attrs1 = attributes + REC + name = mkrhs(module_name) + body = module_binding_body + attrs2 = post_item_attributes + { + let loc = make_loc $sloc in + let attrs = attrs1 @ attrs2 in + let docs = symbol_docs $sloc in + ext, + Mb.mk name body ~attrs ~loc ~docs + } +; + +(* The following bindings in a group of recursive module bindings. *) +%inline and_module_binding: + AND + attrs1 = attributes + name = mkrhs(module_name) + body = module_binding_body + attrs2 = post_item_attributes + { + let loc = make_loc $sloc in + let attrs = attrs1 @ attrs2 in + let docs = symbol_docs $sloc in + let text = symbol_text $symbolstartpos in + Mb.mk name body ~attrs ~loc ~text ~docs + } +; + +(* -------------------------------------------------------------------------- *) + +(* Shared material between structures and signatures. *) + +(* An [include] statement can appear in a structure or in a signature, + which is why this definition is parameterized. *) +%inline include_statement(thing): + INCLUDE + ext = ext + attrs1 = attributes + thing = thing + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Incl.mk thing ~attrs ~loc ~docs, ext + } +; + +(* A module type declaration. *) +module_type_declaration: + MODULE TYPE + ext = ext + attrs1 = attributes + id = mkrhs(ident) + typ = preceded(EQUAL, module_type)? + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Mtd.mk id ?typ ~attrs ~loc ~docs, ext + } +; + +(* -------------------------------------------------------------------------- *) + +(* Opens. *) + +open_declaration: + OPEN + override = override_flag + ext = ext + attrs1 = attributes + me = module_expr + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Opn.mk me ~override ~attrs ~loc ~docs, ext + } +; + +open_description: + OPEN + override = override_flag + ext = ext + attrs1 = attributes + id = mkrhs(mod_ext_longident) + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Opn.mk id ~override ~attrs ~loc ~docs, ext + } +; + +%inline open_dot_declaration: mkrhs(mod_longident) + { let loc = make_loc $loc($1) in + let me = Mod.ident ~loc $1 in + Opn.mk ~loc me } +; + +(* -------------------------------------------------------------------------- *) + +/* Module types */ + +module_type: + | SIG attrs = attributes s = signature END + { mkmty ~loc:$sloc ~attrs (Pmty_signature s) } + | SIG attributes signature error + { unclosed "sig" $loc($1) "end" $loc($4) } + | STRUCT error + { expecting $loc($1) "sig" } + | FUNCTOR attrs = attributes args = functor_args + MINUSGREATER mty = module_type + %prec below_WITH + { wrap_mty_attrs ~loc:$sloc attrs (mk_functor_typ args mty) } + | args = functor_args + MINUSGREATER mty = module_type + %prec below_WITH + { mk_functor_typ args mty } + | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT + { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) } + | LPAREN module_type RPAREN + { $2 } + | LPAREN module_type error + { unclosed "(" $loc($1) ")" $loc($3) } + | module_type attribute + { Mty.attr $1 $2 } + | mkmty( + mkrhs(mty_longident) + { Pmty_ident $1 } + | module_type MINUSGREATER module_type + %prec below_WITH + { Pmty_functor(Named (mknoloc None, $1), $3) } + | module_type WITH separated_nonempty_llist(AND, with_constraint) + { Pmty_with($1, $3) } +/* | LPAREN MODULE mkrhs(mod_longident) RPAREN + { Pmty_alias $3 } */ + | extension + { Pmty_extension $1 } + ) + { $1 } +; +(* A signature, which appears between SIG and END (among other places), + is a list of signature elements. *) +signature: + extra_sig(flatten(signature_element*)) + { $1 } +; + +(* A signature element is one of the following: + - a double semicolon; + - a signature item. *) +%inline signature_element: + text_sig_SEMISEMI + | text_sig(signature_item) + { $1 } +; + +(* A signature item. *) +signature_item: + | item_extension post_item_attributes + { let docs = symbol_docs $sloc in + mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) } + | mksig( + floating_attribute + { Psig_attribute $1 } + ) + { $1 } + | wrap_mksig_ext( + value_description + { psig_value $1 } + | primitive_declaration + { psig_value $1 } + | type_declarations + { psig_type $1 } + | type_subst_declarations + { psig_typesubst $1 } + | sig_type_extension + { psig_typext $1 } + | sig_exception_declaration + { psig_exception $1 } + | module_declaration + { let (body, ext) = $1 in (Psig_module body, ext) } + | module_alias + { let (body, ext) = $1 in (Psig_module body, ext) } + | module_subst + { let (body, ext) = $1 in (Psig_modsubst body, ext) } + | rec_module_declarations + { let (ext, l) = $1 in (Psig_recmodule l, ext) } + | module_type_declaration + { let (body, ext) = $1 in (Psig_modtype body, ext) } + | module_type_subst + { let (body, ext) = $1 in (Psig_modtypesubst body, ext) } + | open_description + { let (body, ext) = $1 in (Psig_open body, ext) } + | include_statement(module_type) + { psig_include $1 } + | class_descriptions + { let (ext, l) = $1 in (Psig_class l, ext) } + | class_type_declarations + { let (ext, l) = $1 in (Psig_class_type l, ext) } + ) + { $1 } + +(* A module declaration. *) +%inline module_declaration: + MODULE + ext = ext attrs1 = attributes + name = mkrhs(module_name) + body = module_declaration_body + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Md.mk name body ~attrs ~loc ~docs, ext + } +; + +(* The body (right-hand side) of a module declaration. *) +module_declaration_body: + COLON mty = module_type + { mty } + | EQUAL error + { expecting $loc($1) ":" } + | mkmty( + arg_and_pos = functor_arg body = module_declaration_body + { let (_, arg) = arg_and_pos in + Pmty_functor(arg, body) } + ) + { $1 } +; + +(* A module alias declaration (in a signature). *) +%inline module_alias: + MODULE + ext = ext attrs1 = attributes + name = mkrhs(module_name) + EQUAL + body = module_expr_alias + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Md.mk name body ~attrs ~loc ~docs, ext + } +; +%inline module_expr_alias: + id = mkrhs(mod_longident) + { Mty.alias ~loc:(make_loc $sloc) id } +; +(* A module substitution (in a signature). *) +module_subst: + MODULE + ext = ext attrs1 = attributes + uid = mkrhs(UIDENT) + COLONEQUAL + body = mkrhs(mod_ext_longident) + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Ms.mk uid body ~attrs ~loc ~docs, ext + } +| MODULE ext attributes mkrhs(UIDENT) COLONEQUAL error + { expecting $loc($6) "module path" } +; + +(* A group of recursive module declarations. *) +%inline rec_module_declarations: + xlist(rec_module_declaration, and_module_declaration) + { $1 } +; +%inline rec_module_declaration: + MODULE + ext = ext + attrs1 = attributes + REC + name = mkrhs(module_name) + COLON + mty = module_type + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + ext, Md.mk name mty ~attrs ~loc ~docs + } +; +%inline and_module_declaration: + AND + attrs1 = attributes + name = mkrhs(module_name) + COLON + mty = module_type + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let docs = symbol_docs $sloc in + let loc = make_loc $sloc in + let text = symbol_text $symbolstartpos in + Md.mk name mty ~attrs ~loc ~text ~docs + } +; + +(* A module type substitution *) +module_type_subst: + MODULE TYPE + ext = ext + attrs1 = attributes + id = mkrhs(ident) + COLONEQUAL + typ=module_type + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Mtd.mk id ~typ ~attrs ~loc ~docs, ext + } + + +(* -------------------------------------------------------------------------- *) + +(* Class declarations. *) + +%inline class_declarations: + xlist(class_declaration, and_class_declaration) + { $1 } +; +%inline class_declaration: + CLASS + ext = ext + attrs1 = attributes + virt = virtual_flag + params = formal_class_parameters + id = mkrhs(LIDENT) + body = class_fun_binding + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + ext, + Ci.mk id body ~virt ~params ~attrs ~loc ~docs + } +; +%inline and_class_declaration: + AND + attrs1 = attributes + virt = virtual_flag + params = formal_class_parameters + id = mkrhs(LIDENT) + body = class_fun_binding + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + let text = symbol_text $symbolstartpos in + Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs + } +; + +class_fun_binding: + EQUAL class_expr + { $2 } + | mkclass( + COLON class_type EQUAL class_expr + { Pcl_constraint($4, $2) } + | labeled_simple_pattern class_fun_binding + { let (l,o,p) = $1 in Pcl_fun(l, o, p, $2) } + ) { $1 } +; + +formal_class_parameters: + params = class_parameters(type_parameter) + { params } +; + +(* -------------------------------------------------------------------------- *) + +(* Class expressions. *) + +class_expr: + class_simple_expr + { $1 } + | FUN attributes class_fun_def + { wrap_class_attrs ~loc:$sloc $3 $2 } + | let_bindings(no_ext) IN class_expr + { class_of_let_bindings ~loc:$sloc $1 $3 } + | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_expr + { let loc = ($startpos($2), $endpos($5)) in + let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in + mkclass ~loc:$sloc ~attrs:$4 (Pcl_open(od, $7)) } + | class_expr attribute + { Cl.attr $1 $2 } + | mkclass( + class_simple_expr nonempty_llist(labeled_simple_expr) + { Pcl_apply($1, $2) } + | extension + { Pcl_extension $1 } + ) { $1 } +; +class_simple_expr: + | LPAREN class_expr RPAREN + { $2 } + | LPAREN class_expr error + { unclosed "(" $loc($1) ")" $loc($3) } + | mkclass( + tys = actual_class_parameters cid = mkrhs(class_longident) + { Pcl_constr(cid, tys) } + | OBJECT attributes class_structure error + { unclosed "object" $loc($1) "end" $loc($4) } + | LPAREN class_expr COLON class_type RPAREN + { Pcl_constraint($2, $4) } + | LPAREN class_expr COLON class_type error + { unclosed "(" $loc($1) ")" $loc($5) } + ) { $1 } + | OBJECT attributes class_structure END + { mkclass ~loc:$sloc ~attrs:$2 (Pcl_structure $3) } +; + +class_fun_def: + mkclass( + labeled_simple_pattern MINUSGREATER e = class_expr + | labeled_simple_pattern e = class_fun_def + { let (l,o,p) = $1 in Pcl_fun(l, o, p, e) } + ) { $1 } +; +%inline class_structure: + | class_self_pattern extra_cstr(class_fields) + { Cstr.mk $1 $2 } +; +class_self_pattern: + LPAREN pattern RPAREN + { reloc_pat ~loc:$sloc $2 } + | mkpat(LPAREN pattern COLON core_type RPAREN + { Ppat_constraint($2, $4) }) + { $1 } + | /* empty */ + { ghpat ~loc:$sloc Ppat_any } +; +%inline class_fields: + flatten(text_cstr(class_field)*) + { $1 } +; +class_field: + | INHERIT override_flag attributes class_expr + self = preceded(AS, mkrhs(LIDENT))? + post_item_attributes + { let docs = symbol_docs $sloc in + mkcf ~loc:$sloc (Pcf_inherit ($2, $4, self)) ~attrs:($3@$6) ~docs } + | VAL value post_item_attributes + { let v, attrs = $2 in + let docs = symbol_docs $sloc in + mkcf ~loc:$sloc (Pcf_val v) ~attrs:(attrs@$3) ~docs } + | METHOD method_ post_item_attributes + { let meth, attrs = $2 in + let docs = symbol_docs $sloc in + mkcf ~loc:$sloc (Pcf_method meth) ~attrs:(attrs@$3) ~docs } + | CONSTRAINT attributes constrain_field post_item_attributes + { let docs = symbol_docs $sloc in + mkcf ~loc:$sloc (Pcf_constraint $3) ~attrs:($2@$4) ~docs } + | INITIALIZER attributes seq_expr post_item_attributes + { let docs = symbol_docs $sloc in + mkcf ~loc:$sloc (Pcf_initializer $3) ~attrs:($2@$4) ~docs } + | item_extension post_item_attributes + { let docs = symbol_docs $sloc in + mkcf ~loc:$sloc (Pcf_extension $1) ~attrs:$2 ~docs } + | mkcf(floating_attribute + { Pcf_attribute $1 }) + { $1 } +; +value: + no_override_flag + attrs = attributes + mutable_ = virtual_with_mutable_flag + label = mkrhs(label) COLON ty = core_type + { (label, mutable_, Cfk_virtual ty), attrs } + | override_flag attributes mutable_flag mkrhs(label) EQUAL seq_expr + { ($4, $3, Cfk_concrete ($1, $6)), $2 } + | override_flag attributes mutable_flag mkrhs(label) type_constraint + EQUAL seq_expr + { let e = mkexp_constraint ~loc:$sloc $7 $5 in + ($4, $3, Cfk_concrete ($1, e)), $2 + } +; +method_: + no_override_flag + attrs = attributes + private_ = virtual_with_private_flag + label = mkrhs(label) COLON ty = poly_type + { (label, private_, Cfk_virtual ty), attrs } + | override_flag attributes private_flag mkrhs(label) strict_binding + { let e = $5 in + let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in + ($4, $3, + Cfk_concrete ($1, ghexp ~loc (Pexp_poly (e, None)))), $2 } + | override_flag attributes private_flag mkrhs(label) + COLON poly_type EQUAL seq_expr + { let poly_exp = + let loc = ($startpos($6), $endpos($8)) in + ghexp ~loc (Pexp_poly($8, Some $6)) in + ($4, $3, Cfk_concrete ($1, poly_exp)), $2 } + | override_flag attributes private_flag mkrhs(label) COLON TYPE lident_list + DOT core_type EQUAL seq_expr + { let poly_exp_loc = ($startpos($7), $endpos($11)) in + let poly_exp = + let exp, poly = + (* it seems odd to use the global ~loc here while poly_exp_loc + is tighter, but this is what ocamlyacc does; + TODO improve parser.mly *) + wrap_type_annotation ~loc:$sloc $7 $9 $11 in + ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in + ($4, $3, + Cfk_concrete ($1, poly_exp)), $2 } +; + +/* Class types */ + +class_type: + class_signature + { $1 } + | mkcty( + label = arg_label + domain = tuple_type + MINUSGREATER + codomain = class_type + { Pcty_arrow(label, domain, codomain) } + ) { $1 } + ; +class_signature: + mkcty( + tys = actual_class_parameters cid = mkrhs(clty_longident) + { Pcty_constr (cid, tys) } + | extension + { Pcty_extension $1 } + ) { $1 } + | OBJECT attributes class_sig_body END + { mkcty ~loc:$sloc ~attrs:$2 (Pcty_signature $3) } + | OBJECT attributes class_sig_body error + { unclosed "object" $loc($1) "end" $loc($4) } + | class_signature attribute + { Cty.attr $1 $2 } + | LET OPEN override_flag attributes mkrhs(mod_longident) IN class_signature + { let loc = ($startpos($2), $endpos($5)) in + let od = Opn.mk ~override:$3 ~loc:(make_loc loc) $5 in + mkcty ~loc:$sloc ~attrs:$4 (Pcty_open(od, $7)) } +; +%inline class_parameters(parameter): + | /* empty */ + { [] } + | LBRACKET params = separated_nonempty_llist(COMMA, parameter) RBRACKET + { params } +; +%inline actual_class_parameters: + tys = class_parameters(core_type) + { tys } +; +%inline class_sig_body: + class_self_type extra_csig(class_sig_fields) + { Csig.mk $1 $2 } +; +class_self_type: + LPAREN core_type RPAREN + { $2 } + | mktyp((* empty *) { Ptyp_any }) + { $1 } +; +%inline class_sig_fields: + flatten(text_csig(class_sig_field)*) + { $1 } +; +class_sig_field: + INHERIT attributes class_signature post_item_attributes + { let docs = symbol_docs $sloc in + mkctf ~loc:$sloc (Pctf_inherit $3) ~attrs:($2@$4) ~docs } + | VAL attributes value_type post_item_attributes + { let docs = symbol_docs $sloc in + mkctf ~loc:$sloc (Pctf_val $3) ~attrs:($2@$4) ~docs } + | METHOD attributes private_virtual_flags mkrhs(label) COLON poly_type + post_item_attributes + { let (p, v) = $3 in + let docs = symbol_docs $sloc in + mkctf ~loc:$sloc (Pctf_method ($4, p, v, $6)) ~attrs:($2@$7) ~docs } + | CONSTRAINT attributes constrain_field post_item_attributes + { let docs = symbol_docs $sloc in + mkctf ~loc:$sloc (Pctf_constraint $3) ~attrs:($2@$4) ~docs } + | item_extension post_item_attributes + { let docs = symbol_docs $sloc in + mkctf ~loc:$sloc (Pctf_extension $1) ~attrs:$2 ~docs } + | mkctf(floating_attribute + { Pctf_attribute $1 }) + { $1 } +; +%inline value_type: + flags = mutable_virtual_flags + label = mkrhs(label) + COLON + ty = core_type + { + let mut, virt = flags in + label, mut, virt, ty + } +; +%inline constrain: + core_type EQUAL core_type + { $1, $3, make_loc $sloc } +; +constrain_field: + core_type EQUAL core_type + { $1, $3 } +; +(* A group of class descriptions. *) +%inline class_descriptions: + xlist(class_description, and_class_description) + { $1 } +; +%inline class_description: + CLASS + ext = ext + attrs1 = attributes + virt = virtual_flag + params = formal_class_parameters + id = mkrhs(LIDENT) + COLON + cty = class_type + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + ext, + Ci.mk id cty ~virt ~params ~attrs ~loc ~docs + } +; +%inline and_class_description: + AND + attrs1 = attributes + virt = virtual_flag + params = formal_class_parameters + id = mkrhs(LIDENT) + COLON + cty = class_type + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + let text = symbol_text $symbolstartpos in + Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs + } +; +class_type_declarations: + xlist(class_type_declaration, and_class_type_declaration) + { $1 } +; +%inline class_type_declaration: + CLASS TYPE + ext = ext + attrs1 = attributes + virt = virtual_flag + params = formal_class_parameters + id = mkrhs(LIDENT) + EQUAL + csig = class_signature + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + ext, + Ci.mk id csig ~virt ~params ~attrs ~loc ~docs + } +; +%inline and_class_type_declaration: + AND + attrs1 = attributes + virt = virtual_flag + params = formal_class_parameters + id = mkrhs(LIDENT) + EQUAL + csig = class_signature + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + let text = symbol_text $symbolstartpos in + Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs + } +; + +/* Core expressions */ + +%inline or_function(EXPR): + | EXPR + { $1 } + | FUNCTION ext_attributes match_cases + { let loc = make_loc $sloc in + let cases = $3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:$sloc desc $2 + } +; + +(* [fun_seq_expr] (and [fun_expr]) are legal expression bodies of a function. + [seq_expr] (and [expr]) are expressions that appear in other contexts + (e.g. subexpressions of the expression body of a function). + + [fun_seq_expr] can't be a bare [function _ -> ...]. [seq_expr] can. + + This distinction exists because [function _ -> ...] is parsed as a *function + cases* body of a function, not an expression body. This so functions can be + parsed with the intended arity. +*) +fun_seq_expr: + | fun_expr %prec below_SEMI { $1 } + | fun_expr SEMI { $1 } + | mkexp(fun_expr SEMI seq_expr + { Pexp_sequence($1, $3) }) + { $1 } + | fun_expr SEMI PERCENT attr_id seq_expr + { let seq = mkexp ~loc:$sloc (Pexp_sequence ($1, $5)) in + let payload = PStr [mkstrexp seq []] in + mkexp ~loc:$sloc (Pexp_extension ($4, payload)) } +; +seq_expr: + | or_function(fun_seq_expr) { $1 } +; +labeled_simple_pattern: + QUESTION LPAREN label_let_pattern opt_default RPAREN + { (Optional (fst $3), $4, snd $3) } + | QUESTION label_var + { (Optional (fst $2), None, snd $2) } + | OPTLABEL LPAREN let_pattern opt_default RPAREN + { (Optional $1, $4, $3) } + | OPTLABEL pattern_var + { (Optional $1, None, $2) } + | TILDE LPAREN label_let_pattern RPAREN + { (Labelled (fst $3), None, snd $3) } + | TILDE label_var + { (Labelled (fst $2), None, snd $2) } + | LABEL simple_pattern + { (Labelled $1, None, $2) } + | simple_pattern + { (Nolabel, None, $1) } +; + +pattern_var: + mkpat( + mkrhs(LIDENT) { Ppat_var $1 } + | UNDERSCORE { Ppat_any } + ) { $1 } +; + +%inline opt_default: + preceded(EQUAL, seq_expr)? + { $1 } +; +label_let_pattern: + x = label_var + { x } + | x = label_var COLON cty = core_type + { let lab, pat = x in + lab, + mkpat ~loc:$sloc (Ppat_constraint (pat, cty)) } +; +%inline label_var: + mkrhs(LIDENT) + { ($1.Location.txt, mkpat ~loc:$sloc (Ppat_var $1)) } +; +let_pattern: + pattern + { $1 } + | mkpat(pattern COLON core_type + { Ppat_constraint($1, $3) }) + { $1 } +; + +%inline indexop_expr(dot, index, right): + | array=simple_expr d=dot LPAREN i=index RPAREN r=right + { array, d, Paren, i, r } + | array=simple_expr d=dot LBRACE i=index RBRACE r=right + { array, d, Brace, i, r } + | array=simple_expr d=dot LBRACKET i=index RBRACKET r=right + { array, d, Bracket, i, r } +; + +%inline indexop_error(dot, index): + | simple_expr dot _p=LPAREN index _e=error + { indexop_unclosed_error $loc(_p) Paren $loc(_e) } + | simple_expr dot _p=LBRACE index _e=error + { indexop_unclosed_error $loc(_p) Brace $loc(_e) } + | simple_expr dot _p=LBRACKET index _e=error + { indexop_unclosed_error $loc(_p) Bracket $loc(_e) } +; + +%inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 }; + +fun_expr: + simple_expr %prec below_HASH + { $1 } + | fun_expr_attrs + { let desc, attrs = $1 in + mkexp_attrs ~loc:$sloc desc attrs } + | mkexp(expr_) + { $1 } + | let_bindings(ext) IN seq_expr + { expr_of_let_bindings ~loc:$sloc $1 $3 } + | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr + { let (pbop_pat, pbop_exp, rev_ands) = bindings in + let ands = List.rev rev_ands in + let pbop_loc = make_loc $sloc in + let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in + mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) } + | fun_expr COLONCOLON expr + { mkexp_cons ~loc:$sloc $loc($2) (ghexp ~loc:$sloc (Pexp_tuple[$1;$3])) } + | mkrhs(label) LESSMINUS expr + { mkexp ~loc:$sloc (Pexp_setinstvar($1, $3)) } + | simple_expr DOT mkrhs(label_longident) LESSMINUS expr + { mkexp ~loc:$sloc (Pexp_setfield($1, $3, $5)) } + | indexop_expr(DOT, seq_expr, LESSMINUS v=expr {Some v}) + { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 } + | indexop_expr(qualified_dotop, expr_semi_list, LESSMINUS v=expr {Some v}) + { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 } + | fun_expr attribute + { Exp.attr $1 $2 } +/* BEGIN AVOID */ + | UNDERSCORE + { not_expecting $loc($1) "wildcard \"_\"" } +/* END AVOID */ +; +%inline expr: + | or_function(fun_expr) { $1 } +; +%inline fun_expr_attrs: + | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr + { Pexp_letmodule($4, $5, $7), $3 } + | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr + { Pexp_letexception($4, $6), $3 } + | LET OPEN override_flag ext_attributes module_expr IN seq_expr + { let open_loc = make_loc ($startpos($2), $endpos($5)) in + let od = Opn.mk $5 ~override:$3 ~loc:open_loc in + Pexp_open(od, $7), $4 } + /* Cf #5939: we used to accept (fun p when e0 -> e) */ + | FUN ext_attributes fun_params preceded(COLON, atomic_type)? + MINUSGREATER fun_body + { let body_constraint = Option.map (fun x -> Pconstraint x) $4 in + mkfunction $3 body_constraint $6, $2 + } + | MATCH ext_attributes seq_expr WITH match_cases + { Pexp_match($3, $5), $2 } + | TRY ext_attributes seq_expr WITH match_cases + { Pexp_try($3, $5), $2 } + | TRY ext_attributes seq_expr WITH error + { syntax_error() } + | IF ext_attributes seq_expr THEN expr ELSE expr + { Pexp_ifthenelse($3, $5, Some $7), $2 } + | IF ext_attributes seq_expr THEN expr + { Pexp_ifthenelse($3, $5, None), $2 } + | WHILE ext_attributes seq_expr do_done_expr + { Pexp_while($3, $4), $2 } + | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr + do_done_expr + { Pexp_for($3, $5, $7, $6, $8), $2 } + | ASSERT ext_attributes simple_expr %prec below_HASH + { Pexp_assert $3, $2 } + | LAZY ext_attributes simple_expr %prec below_HASH + { Pexp_lazy $3, $2 } +; +%inline do_done_expr: + | DO e = seq_expr DONE + { e } + | DO seq_expr error + { unclosed "do" $loc($1) "done" $loc($2) } +; +%inline expr_: + | simple_expr nonempty_llist(labeled_simple_expr) + { Pexp_apply($1, $2) } + | expr_comma_list %prec below_COMMA + { Pexp_tuple($1) } + | mkrhs(constr_longident) simple_expr %prec below_HASH + { Pexp_construct($1, Some $2) } + | name_tag simple_expr %prec below_HASH + { Pexp_variant($1, Some $2) } + | e1 = fun_expr op = op(infix_operator) e2 = expr + { mkinfix e1 op e2 } + | subtractive expr %prec prec_unary_minus + { mkuminus ~sloc:$sloc ~oploc:$loc($1) $1 $2 } + | additive expr %prec prec_unary_plus + { mkuplus ~sloc:$sloc ~oploc:$loc($1) $1 $2 } +; + +simple_expr: + | LPAREN seq_expr RPAREN + { reloc_exp ~loc:$sloc $2 } + | LPAREN seq_expr error + { unclosed "(" $loc($1) ")" $loc($3) } + | LPAREN seq_expr type_constraint RPAREN + { mkexp_constraint ~loc:$sloc $2 $3 } + | indexop_expr(DOT, seq_expr, { None }) + { mk_indexop_expr builtin_indexing_operators ~loc:$sloc $1 } + | indexop_expr(qualified_dotop, expr_semi_list, { None }) + { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 } + | indexop_error (DOT, seq_expr) { $1 } + | indexop_error (qualified_dotop, expr_semi_list) { $1 } + | metaocaml_expr { $1 } + | simple_expr_attrs + { let desc, attrs = $1 in + mkexp_attrs ~loc:$sloc desc attrs } + | mkexp(simple_expr_) + { $1 } +; +%inline simple_expr_attrs: + | BEGIN ext = ext attrs = attributes e = seq_expr END + { e.pexp_desc, (ext, attrs @ e.pexp_attributes) } + | BEGIN ext_attributes END + { Pexp_construct (mkloc (Lident "()") (make_loc $sloc), None), $2 } + | BEGIN ext_attributes seq_expr error + { unclosed "begin" $loc($1) "end" $loc($4) } + | NEW ext_attributes mkrhs(class_longident) + { Pexp_new($3), $2 } + | LPAREN MODULE ext_attributes module_expr RPAREN + { Pexp_pack $4, $3 } + | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN + { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), $6), $3 } + | LPAREN MODULE ext_attributes module_expr COLON error + { unclosed "(" $loc($1) ")" $loc($6) } + | OBJECT ext_attributes class_structure END + { Pexp_object $3, $2 } + | OBJECT ext_attributes class_structure error + { unclosed "object" $loc($1) "end" $loc($4) } +; + +(* We include this parsing rule from the BER-MetaOCaml patchset + (see https://okmij.org/ftp/ML/MetaOCaml.html) + even though the lexer does *not* include any lexing rule + for the METAOCAML_* tokens, so they + will never be produced by the upstream compiler. + + The intention of this dead parsing rule is purely to ease the + future maintenance work on MetaOCaml. +*) +%inline metaocaml_expr: + | METAOCAML_ESCAPE e = simple_expr + { wrap_exp_attrs ~loc:$sloc e + (Some (mknoloc "metaocaml.escape"), []) } + | METAOCAML_BRACKET_OPEN e = seq_expr METAOCAML_BRACKET_CLOSE + { wrap_exp_attrs ~loc:$sloc e + (Some (mknoloc "metaocaml.bracket"),[]) } +; + +%inline simple_expr_: + | mkrhs(val_longident) + { Pexp_ident ($1) } + | constant + { Pexp_constant $1 } + | mkrhs(constr_longident) %prec prec_constant_constructor + { Pexp_construct($1, None) } + | name_tag %prec prec_constant_constructor + { Pexp_variant($1, None) } + | op(PREFIXOP) simple_expr + { Pexp_apply($1, [Nolabel,$2]) } + | op(BANG {"!"}) simple_expr + { Pexp_apply($1, [Nolabel,$2]) } + | LBRACELESS object_expr_content GREATERRBRACE + { Pexp_override $2 } + | LBRACELESS object_expr_content error + { unclosed "{<" $loc($1) ">}" $loc($3) } + | LBRACELESS GREATERRBRACE + { Pexp_override [] } + | simple_expr DOT mkrhs(label_longident) + { Pexp_field($1, $3) } + | od=open_dot_declaration DOT LPAREN seq_expr RPAREN + { Pexp_open(od, $4) } + | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE + { (* TODO: review the location of Pexp_override *) + Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) } + | mod_longident DOT LBRACELESS object_expr_content error + { unclosed "{<" $loc($3) ">}" $loc($5) } + | simple_expr HASH mkrhs(label) + { Pexp_send($1, $3) } + | simple_expr op(HASHOP) simple_expr + { mkinfix $1 $2 $3 } + | extension + { Pexp_extension $1 } + | od=open_dot_declaration DOT mkrhs(LPAREN RPAREN {Lident "()"}) + { Pexp_open(od, mkexp ~loc:($loc($3)) (Pexp_construct($3, None))) } + | mod_longident DOT LPAREN seq_expr error + { unclosed "(" $loc($3) ")" $loc($5) } + | LBRACE record_expr_content RBRACE + { let (exten, fields) = $2 in + Pexp_record(fields, exten) } + | LBRACE record_expr_content error + { unclosed "{" $loc($1) "}" $loc($3) } + | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE + { let (exten, fields) = $4 in + Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) + (Pexp_record(fields, exten))) } + | mod_longident DOT LBRACE record_expr_content error + { unclosed "{" $loc($3) "}" $loc($5) } + | LBRACKETBAR expr_semi_list BARRBRACKET + { Pexp_array($2) } + | LBRACKETBAR expr_semi_list error + { unclosed "[|" $loc($1) "|]" $loc($3) } + | LBRACKETBAR BARRBRACKET + { Pexp_array [] } + | od=open_dot_declaration DOT LBRACKETBAR expr_semi_list BARRBRACKET + { Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array($4))) } + | od=open_dot_declaration DOT LBRACKETBAR BARRBRACKET + { (* TODO: review the location of Pexp_array *) + Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_array [])) } + | mod_longident DOT + LBRACKETBAR expr_semi_list error + { unclosed "[|" $loc($3) "|]" $loc($5) } + | LBRACKET expr_semi_list RBRACKET + { fst (mktailexp $loc($3) $2) } + | LBRACKET expr_semi_list error + { unclosed "[" $loc($1) "]" $loc($3) } + | od=open_dot_declaration DOT LBRACKET expr_semi_list RBRACKET + { let list_exp = + (* TODO: review the location of list_exp *) + let tail_exp, _tail_loc = mktailexp $loc($5) $4 in + mkexp ~loc:($startpos($3), $endpos) tail_exp in + Pexp_open(od, list_exp) } + | od=open_dot_declaration DOT mkrhs(LBRACKET RBRACKET {Lident "[]"}) + { Pexp_open(od, mkexp ~loc:$loc($3) (Pexp_construct($3, None))) } + | mod_longident DOT + LBRACKET expr_semi_list error + { unclosed "[" $loc($3) "]" $loc($5) } + | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON + package_type RPAREN + { let modexp = + mkexp_attrs ~loc:($startpos($3), $endpos) + (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), $8)) $5 in + Pexp_open(od, modexp) } + | mod_longident DOT + LPAREN MODULE ext_attributes module_expr COLON error + { unclosed "(" $loc($3) ")" $loc($8) } +; +labeled_simple_expr: + simple_expr %prec below_HASH + { (Nolabel, $1) } + | LABEL simple_expr %prec below_HASH + { (Labelled $1, $2) } + | TILDE label = LIDENT + { let loc = $loc(label) in + (Labelled label, mkexpvar ~loc label) } + | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN + { (Labelled label, mkexp_constraint ~loc:($startpos($2), $endpos) + (mkexpvar ~loc:$loc(label) label) ty) } + | QUESTION label = LIDENT + { let loc = $loc(label) in + (Optional label, mkexpvar ~loc label) } + | OPTLABEL simple_expr %prec below_HASH + { (Optional $1, $2) } +; +%inline lident_list: + xs = mkrhs(LIDENT)+ + { xs } +; +%inline let_ident: + val_ident { mkpatvar ~loc:$sloc $1 } +; +let_binding_body_no_punning: + let_ident strict_binding + { ($1, $2, None) } + | let_ident type_constraint EQUAL seq_expr + { let v = $1 in (* PR#7344 *) + let t = + match $2 with + Pconstraint t -> + Pvc_constraint { locally_abstract_univars = []; typ=t } + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} + in + (v, $4, Some t) + } + | let_ident COLON poly(core_type) EQUAL seq_expr + { + let t = ghtyp ~loc:($loc($3)) $3 in + ($1, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) + } + | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr + { let constraint' = + Pvc_constraint { locally_abstract_univars=$4; typ = $6} + in + ($1, $8, Some constraint') } + | pattern_no_exn EQUAL seq_expr + { ($1, $3, None) } + | simple_pattern_not_ident COLON core_type EQUAL seq_expr + { ($1, $5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 })) } +; +let_binding_body: + | let_binding_body_no_punning + { let p,e,c = $1 in (p,e,c,false) } +/* BEGIN AVOID */ + | val_ident %prec below_HASH + { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, None, true) } + (* The production that allows puns is marked so that [make list-parse-errors] + does not attempt to exploit it. That would be problematic because it + would then generate bindings such as [let x], which are rejected by the + auxiliary function [addlb] via a call to [syntax_error]. *) +/* END AVOID */ +; +(* The formal parameter EXT can be instantiated with ext or no_ext + so as to indicate whether an extension is allowed or disallowed. *) +let_bindings(EXT): + let_binding(EXT) { $1 } + | let_bindings(EXT) and_let_binding { addlb $1 $2 } +; +%inline let_binding(EXT): + LET + ext = EXT + attrs1 = attributes + rec_flag = rec_flag + body = let_binding_body + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + mklbs ext rec_flag (mklb ~loc:$sloc true body attrs) + } +; +and_let_binding: + AND + attrs1 = attributes + body = let_binding_body + attrs2 = post_item_attributes + { + let attrs = attrs1 @ attrs2 in + mklb ~loc:$sloc false body attrs + } +; +letop_binding_body: + pat = let_ident exp = strict_binding + { (pat, exp) } + | val_ident + (* Let-punning *) + { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1) } + | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr + { let loc = ($startpos(pat), $endpos(typ)) in + (ghpat ~loc (Ppat_constraint(pat, typ)), exp) } + | pat = pattern_no_exn EQUAL exp = seq_expr + { (pat, exp) } +; +letop_bindings: + body = letop_binding_body + { let let_pat, let_exp = body in + let_pat, let_exp, [] } + | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = letop_binding_body + { let let_pat, let_exp, rev_ands = bindings in + let pbop_pat, pbop_exp = body in + let pbop_loc = make_loc $sloc in + let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in + let_pat, let_exp, and_ :: rev_ands } +; +strict_binding: + EQUAL seq_expr + { $2 } + | fun_params type_constraint? EQUAL fun_body + { ghexp ~loc:$sloc (mkfunction $1 $2 $4) + } +; +fun_body: + | FUNCTION ext_attributes match_cases + { let ext, attrs = $2 in + match ext with + | None -> Pfunction_cases ($3, make_loc $sloc, attrs) + | Some _ -> + (* function%foo extension nodes interrupt the arity *) + let cases = Pfunction_cases ($3, make_loc $sloc, []) in + Pfunction_body + (mkexp_attrs ~loc:$sloc (mkfunction [] None cases) $2) + } + | fun_seq_expr + { Pfunction_body $1 } +; +%inline match_cases: + xs = preceded_or_separated_nonempty_llist(BAR, match_case) + { xs } +; +match_case: + pattern MINUSGREATER seq_expr + { Exp.case $1 $3 } + | pattern WHEN seq_expr MINUSGREATER seq_expr + { Exp.case $1 ~guard:$3 $5 } + | pattern MINUSGREATER DOT + { Exp.case $1 (Exp.unreachable ~loc:(make_loc $loc($3)) ()) } +; +fun_param_as_list: + | LPAREN TYPE ty_params = lident_list RPAREN + { (* We desugar (type a b c) to (type a) (type b) (type c). + If we do this desugaring, the loc for each parameter is a ghost. + *) + let loc = + match ty_params with + | [] -> assert false (* lident_list is non-empty *) + | [_] -> make_loc $sloc + | _ :: _ :: _ -> ghost_loc $sloc + in + List.map + (fun x -> { pparam_loc = loc; pparam_desc = Pparam_newtype x }) + ty_params + } + | labeled_simple_pattern + { let a, b, c = $1 in + [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (a, b, c) } ] + } +; +fun_params: + | nonempty_concat(fun_param_as_list) { $1 } +; +%inline expr_comma_list: + es = separated_nontrivial_llist(COMMA, expr) + { es } +; +record_expr_content: + eo = ioption(terminated(simple_expr, WITH)) + fields = separated_or_terminated_nonempty_list(SEMI, record_expr_field) + { eo, fields } +; +%inline record_expr_field: + | label = mkrhs(label_longident) + c = type_constraint? + eo = preceded(EQUAL, expr)? + { let constraint_loc, label, e = + match eo with + | None -> + (* No pattern; this is a pun. Desugar it. *) + $sloc, make_ghost label, exp_of_longident label + | Some e -> + ($startpos(c), $endpos), label, e + in + label, mkexp_opt_constraint ~loc:constraint_loc e c } +; +%inline object_expr_content: + xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field) + { xs } +; +%inline object_expr_field: + label = mkrhs(label) + oe = preceded(EQUAL, expr)? + { let label, e = + match oe with + | None -> + (* No expression; this is a pun. Desugar it. *) + make_ghost label, exp_of_label label + | Some e -> + label, e + in + label, e } +; +%inline expr_semi_list: + es = separated_or_terminated_nonempty_list(SEMI, expr) + { es } +; +type_constraint: + COLON core_type { Pconstraint $2 } + | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } + | COLONGREATER core_type { Pcoerce (None, $2) } + | COLON error { syntax_error() } + | COLONGREATER error { syntax_error() } +; + +/* Patterns */ + +(* Whereas [pattern] is an arbitrary pattern, [pattern_no_exn] is a pattern + that does not begin with the [EXCEPTION] keyword. Thus, [pattern_no_exn] + is the intersection of the context-free language [pattern] with the + regular language [^EXCEPTION .*]. + + Ideally, we would like to use [pattern] everywhere and check in a later + phase that EXCEPTION patterns are used only where they are allowed (there + is code in typing/typecore.ml to this end). Unfortunately, in the + definition of [let_binding_body], we cannot allow [pattern]. That would + create a shift/reduce conflict: upon seeing LET EXCEPTION ..., the parser + wouldn't know whether this is the beginning of a LET EXCEPTION construct or + the beginning of a LET construct whose pattern happens to begin with + EXCEPTION. The conflict is avoided there by using [pattern_no_exn] in the + definition of [let_binding_body]. + + In order to avoid duplication between the definitions of [pattern] and + [pattern_no_exn], we create a parameterized definition [pattern_(self)] + and instantiate it twice. *) + +pattern: + pattern_(pattern) + { $1 } + | EXCEPTION ext_attributes pattern %prec prec_constr_appl + { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2} + | EFFECT pattern_gen COMMA simple_pattern + { mkpat ~loc:$sloc (Ppat_effect($2,$4)) } +; + +pattern_no_exn: + pattern_(pattern_no_exn) + { $1 } +; + +%inline pattern_(self): + | self COLONCOLON pattern + { mkpat_cons ~loc:$sloc $loc($2) (ghpat ~loc:$sloc (Ppat_tuple[$1;$3])) } + | self attribute + { Pat.attr $1 $2 } + | pattern_gen + { $1 } + | mkpat( + self AS mkrhs(val_ident) + { Ppat_alias($1, $3) } + | self AS error + { expecting $loc($3) "identifier" } + | pattern_comma_list(self) %prec below_COMMA + { Ppat_tuple(List.rev $1) } + | self COLONCOLON error + { expecting $loc($3) "pattern" } + | self BAR pattern + { Ppat_or($1, $3) } + | self BAR error + { expecting $loc($3) "pattern" } + ) { $1 } +; + +pattern_gen: + simple_pattern + { $1 } + | mkpat( + mkrhs(constr_longident) pattern %prec prec_constr_appl + { Ppat_construct($1, Some ([], $2)) } + | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=lident_list RPAREN + pat=simple_pattern + { Ppat_construct(constr, Some (newtypes, pat)) } + | name_tag pattern %prec prec_constr_appl + { Ppat_variant($1, Some $2) } + ) { $1 } + | LAZY ext_attributes simple_pattern + { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2} +; + +simple_pattern: + mkpat(mkrhs(val_ident) %prec below_EQUAL + { Ppat_var ($1) }) + { $1 } + | simple_pattern_not_ident { $1 } +; + +simple_pattern_not_ident: + | LPAREN pattern RPAREN + { reloc_pat ~loc:$sloc $2 } + | simple_delimited_pattern + { $1 } + | LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN + { mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 } + | LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN + { mkpat_attrs ~loc:$sloc + (Ppat_constraint(mkpat ~loc:$loc($4) (Ppat_unpack $4), $6)) + $3 } + | mkpat(simple_pattern_not_ident_) + { $1 } +; +%inline simple_pattern_not_ident_: + | UNDERSCORE + { Ppat_any } + | signed_constant + { Ppat_constant $1 } + | signed_constant DOTDOT signed_constant + { Ppat_interval ($1, $3) } + | mkrhs(constr_longident) + { Ppat_construct($1, None) } + | name_tag + { Ppat_variant($1, None) } + | HASH mkrhs(type_longident) + { Ppat_type ($2) } + | mkrhs(mod_longident) DOT simple_delimited_pattern + { Ppat_open($1, $3) } + | mkrhs(mod_longident) DOT mkrhs(LBRACKET RBRACKET {Lident "[]"}) + { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) } + | mkrhs(mod_longident) DOT mkrhs(LPAREN RPAREN {Lident "()"}) + { Ppat_open($1, mkpat ~loc:$sloc (Ppat_construct($3, None))) } + | mkrhs(mod_longident) DOT LPAREN pattern RPAREN + { Ppat_open ($1, $4) } + | mod_longident DOT LPAREN pattern error + { unclosed "(" $loc($3) ")" $loc($5) } + | mod_longident DOT LPAREN error + { expecting $loc($4) "pattern" } + | LPAREN pattern error + { unclosed "(" $loc($1) ")" $loc($3) } + | LPAREN pattern COLON core_type RPAREN + { Ppat_constraint($2, $4) } + | LPAREN pattern COLON core_type error + { unclosed "(" $loc($1) ")" $loc($5) } + | LPAREN pattern COLON error + { expecting $loc($4) "type" } + | LPAREN MODULE ext_attributes module_name COLON package_type + error + { unclosed "(" $loc($1) ")" $loc($7) } + | extension + { Ppat_extension $1 } +; + +simple_delimited_pattern: + mkpat( + LBRACE record_pat_content RBRACE + { let (fields, closed) = $2 in + Ppat_record(fields, closed) } + | LBRACE record_pat_content error + { unclosed "{" $loc($1) "}" $loc($3) } + | LBRACKET pattern_semi_list RBRACKET + { fst (mktailpat $loc($3) $2) } + | LBRACKET pattern_semi_list error + { unclosed "[" $loc($1) "]" $loc($3) } + | LBRACKETBAR pattern_semi_list BARRBRACKET + { Ppat_array $2 } + | LBRACKETBAR BARRBRACKET + { Ppat_array [] } + | LBRACKETBAR pattern_semi_list error + { unclosed "[|" $loc($1) "|]" $loc($3) } + ) { $1 } + +pattern_comma_list(self): + pattern_comma_list(self) COMMA pattern { $3 :: $1 } + | self COMMA pattern { [$3; $1] } + | self COMMA error { expecting $loc($3) "pattern" } +; +%inline pattern_semi_list: + ps = separated_or_terminated_nonempty_list(SEMI, pattern) + { ps } +; +(* A label-pattern list is a nonempty list of label-pattern pairs, optionally + followed with an UNDERSCORE, separated-or-terminated with semicolons. *) +%inline record_pat_content: + listx(SEMI, record_pat_field, UNDERSCORE) + { let fields, closed = $1 in + let closed = match closed with Some () -> Open | None -> Closed in + fields, closed } +; +%inline record_pat_field: + label = mkrhs(label_longident) + octy = preceded(COLON, core_type)? + opat = preceded(EQUAL, pattern)? + { let constraint_loc, label, pat = + match opat with + | None -> + (* No pattern; this is a pun. Desugar it. + But that the pattern was there and the label reconstructed (which + piece of AST is marked as ghost is important for warning + emission). *) + $sloc, make_ghost label, pat_of_label label + | Some pat -> + ($startpos(octy), $endpos), label, pat + in + label, mkpat_opt_constraint ~loc:constraint_loc pat octy + } +; + +/* Value descriptions */ + +value_description: + VAL + ext = ext + attrs1 = attributes + id = mkrhs(val_ident) + COLON + ty = possibly_poly(core_type) + attrs2 = post_item_attributes + { let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Val.mk id ty ~attrs ~loc ~docs, + ext } +; + +/* Primitive declarations */ + +primitive_declaration: + EXTERNAL + ext = ext + attrs1 = attributes + id = mkrhs(val_ident) + COLON + ty = possibly_poly(core_type) + EQUAL + prim = raw_string+ + attrs2 = post_item_attributes + { let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Val.mk id ty ~prim ~attrs ~loc ~docs, + ext } +; + +(* Type declarations and type substitutions. *) + +(* Type declarations [type t = u] and type substitutions [type t := u] are very + similar, so we view them as instances of [generic_type_declarations]. In the + case of a type declaration, the use of [nonrec_flag] means that [NONREC] may + be absent or present, whereas in the case of a type substitution, the use of + [no_nonrec_flag] means that [NONREC] must be absent. The use of [type_kind] + versus [type_subst_kind] means that in the first case, we expect an [EQUAL] + sign, whereas in the second case, we expect [COLONEQUAL]. *) + +%inline type_declarations: + generic_type_declarations(nonrec_flag, type_kind) + { $1 } +; + +%inline type_subst_declarations: + generic_type_declarations(no_nonrec_flag, type_subst_kind) + { $1 } +; + +(* A set of type declarations or substitutions begins with a + [generic_type_declaration] and continues with a possibly empty list of + [generic_and_type_declaration]s. *) + +%inline generic_type_declarations(flag, kind): + xlist( + generic_type_declaration(flag, kind), + generic_and_type_declaration(kind) + ) + { $1 } +; + +(* [generic_type_declaration] and [generic_and_type_declaration] look similar, + but are in reality different enough that it is difficult to share anything + between them. *) + +generic_type_declaration(flag, kind): + TYPE + ext = ext + attrs1 = attributes + flag = flag + params = type_parameters + id = mkrhs(LIDENT) + kind_priv_manifest = kind + cstrs = constraints + attrs2 = post_item_attributes + { + let (kind, priv, manifest) = kind_priv_manifest in + let docs = symbol_docs $sloc in + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + (flag, ext), + Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs + } +; +%inline generic_and_type_declaration(kind): + AND + attrs1 = attributes + params = type_parameters + id = mkrhs(LIDENT) + kind_priv_manifest = kind + cstrs = constraints + attrs2 = post_item_attributes + { + let (kind, priv, manifest) = kind_priv_manifest in + let docs = symbol_docs $sloc in + let attrs = attrs1 @ attrs2 in + let loc = make_loc $sloc in + let text = symbol_text $symbolstartpos in + Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text + } +; +%inline constraints: + llist(preceded(CONSTRAINT, constrain)) + { $1 } +; +(* Lots of %inline expansion are required for [nonempty_type_kind] to be + LR(1). At the cost of some manual expansion, it would be possible to give a + definition that leads to a smaller grammar (after expansion) and therefore + a smaller automaton. *) +nonempty_type_kind: + | priv = inline_private_flag + ty = core_type + { (Ptype_abstract, priv, Some ty) } + | oty = type_synonym + priv = inline_private_flag + cs = constructor_declarations + { (Ptype_variant cs, priv, oty) } + | oty = type_synonym + priv = inline_private_flag + DOTDOT + { (Ptype_open, priv, oty) } + | oty = type_synonym + priv = inline_private_flag + LBRACE ls = label_declarations RBRACE + { (Ptype_record ls, priv, oty) } +; +%inline type_synonym: + ioption(terminated(core_type, EQUAL)) + { $1 } +; +type_kind: + /*empty*/ + { (Ptype_abstract, Public, None) } + | EQUAL nonempty_type_kind + { $2 } +; +%inline type_subst_kind: + COLONEQUAL nonempty_type_kind + { $2 } +; +type_parameters: + /* empty */ + { [] } + | p = type_parameter + { [p] } + | LPAREN ps = separated_nonempty_llist(COMMA, type_parameter) RPAREN + { ps } +; +type_parameter: + type_variance type_variable { $2, $1 } +; +type_variable: + mktyp( + QUOTE tyvar = ident + { Ptyp_var tyvar } + | UNDERSCORE + { Ptyp_any } + ) { $1 } +; + +type_variance: + /* empty */ { NoVariance, NoInjectivity } + | PLUS { Covariant, NoInjectivity } + | MINUS { Contravariant, NoInjectivity } + | BANG { NoVariance, Injective } + | PLUS BANG | BANG PLUS { Covariant, Injective } + | MINUS BANG | BANG MINUS { Contravariant, Injective } + | INFIXOP2 + { if $1 = "+!" then Covariant, Injective else + if $1 = "-!" then Contravariant, Injective else + expecting $loc($1) "type_variance" } + | PREFIXOP + { if $1 = "!+" then Covariant, Injective else + if $1 = "!-" then Contravariant, Injective else + expecting $loc($1) "type_variance" } +; + +(* A sequence of constructor declarations is either a single BAR, which + means that the list is empty, or a nonempty BAR-separated list of + declarations, with an optional leading BAR. *) +constructor_declarations: + | BAR + { [] } + | cs = bar_llist(constructor_declaration) + { cs } +; +(* A constructor declaration begins with an opening symbol, which can + be either epsilon or BAR. Note that this opening symbol is included + in the footprint $sloc. *) +(* Because [constructor_declaration] and [extension_constructor_declaration] + are identical except for their semantic actions, we introduce the symbol + [generic_constructor_declaration], whose semantic action is neutral -- it + merely returns a tuple. *) +generic_constructor_declaration(opening): + opening + cid = mkrhs(constr_ident) + vars_args_res = generalized_constructor_arguments + attrs = attributes + { + let vars, args, res = vars_args_res in + let info = symbol_info $endpos in + let loc = make_loc $sloc in + cid, vars, args, res, attrs, loc, info + } +; +%inline constructor_declaration(opening): + d = generic_constructor_declaration(opening) + { + let cid, vars, args, res, attrs, loc, info = d in + Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info + } +; +str_exception_declaration: + sig_exception_declaration + { $1 } +| EXCEPTION + ext = ext + attrs1 = attributes + id = mkrhs(constr_ident) + EQUAL + lid = mkrhs(constr_longident) + attrs2 = attributes + attrs = post_item_attributes + { let loc = make_loc $sloc in + let docs = symbol_docs $sloc in + Te.mk_exception ~attrs + (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs) + , ext } +; +sig_exception_declaration: + EXCEPTION + ext = ext + attrs1 = attributes + id = mkrhs(constr_ident) + vars_args_res = generalized_constructor_arguments + attrs2 = attributes + attrs = post_item_attributes + { let vars, args, res = vars_args_res in + let loc = make_loc ($startpos, $endpos(attrs2)) in + let docs = symbol_docs $sloc in + Te.mk_exception ~attrs + (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) + , ext } +; +%inline let_exception_declaration: + mkrhs(constr_ident) generalized_constructor_arguments attributes + { let vars, args, res = $2 in + Te.decl $1 ~vars ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) } +; +generalized_constructor_arguments: + /*empty*/ { ([],Pcstr_tuple [],None) } + | OF constructor_arguments { ([],$2,None) } + | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH + { ([],$2,Some $4) } + | COLON typevar_list DOT constructor_arguments MINUSGREATER atomic_type + %prec below_HASH + { ($2,$4,Some $6) } + | COLON atomic_type %prec below_HASH + { ([],Pcstr_tuple [],Some $2) } + | COLON typevar_list DOT atomic_type %prec below_HASH + { ($2,Pcstr_tuple [],Some $4) } +; + +constructor_arguments: + | tys = inline_separated_nonempty_llist(STAR, atomic_type) + %prec below_HASH + { Pcstr_tuple tys } + | LBRACE label_declarations RBRACE + { Pcstr_record $2 } +; +label_declarations: + label_declaration { [$1] } + | label_declaration_semi { [$1] } + | label_declaration_semi label_declarations { $1 :: $2 } +; +label_declaration: + mutable_flag mkrhs(label) COLON poly_type_no_attr attributes + { let info = symbol_info $endpos in + Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info } +; +label_declaration_semi: + mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes + { let info = + match rhs_info $endpos($5) with + | Some _ as info_before_semi -> info_before_semi + | None -> symbol_info $endpos + in + Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info } +; + +/* Type Extensions */ + +%inline str_type_extension: + type_extension(extension_constructor) + { $1 } +; +%inline sig_type_extension: + type_extension(extension_constructor_declaration) + { $1 } +; +%inline type_extension(declaration): + TYPE + ext = ext + attrs1 = attributes + no_nonrec_flag + params = type_parameters + tid = mkrhs(type_longident) + PLUSEQ + priv = private_flag + cs = bar_llist(declaration) + attrs2 = post_item_attributes + { let docs = symbol_docs $sloc in + let attrs = attrs1 @ attrs2 in + Te.mk tid cs ~params ~priv ~attrs ~docs, + ext } +; +%inline extension_constructor(opening): + extension_constructor_declaration(opening) + { $1 } + | extension_constructor_rebind(opening) + { $1 } +; +%inline extension_constructor_declaration(opening): + d = generic_constructor_declaration(opening) + { + let cid, vars, args, res, attrs, loc, info = d in + Te.decl cid ~vars ~args ?res ~attrs ~loc ~info + } +; +extension_constructor_rebind(opening): + opening + cid = mkrhs(constr_ident) + EQUAL + lid = mkrhs(constr_longident) + attrs = attributes + { let info = symbol_info $endpos in + Te.rebind cid lid ~attrs ~loc:(make_loc $sloc) ~info } +; + +/* "with" constraints (additional type equations over signature components) */ + +with_constraint: + TYPE type_parameters mkrhs(label_longident) with_type_binder + core_type_no_attr constraints + { let lident = loc_last $3 in + Pwith_type + ($3, + (Type.mk lident + ~params:$2 + ~cstrs:$6 + ~manifest:$5 + ~priv:$4 + ~loc:(make_loc $sloc))) } + /* used label_longident instead of type_longident to disallow + functor applications in type path */ + | TYPE type_parameters mkrhs(label_longident) + COLONEQUAL core_type_no_attr + { let lident = loc_last $3 in + Pwith_typesubst + ($3, + (Type.mk lident + ~params:$2 + ~manifest:$5 + ~loc:(make_loc $sloc))) } + | MODULE mkrhs(mod_longident) EQUAL mkrhs(mod_ext_longident) + { Pwith_module ($2, $4) } + | MODULE mkrhs(mod_longident) COLONEQUAL mkrhs(mod_ext_longident) + { Pwith_modsubst ($2, $4) } + | MODULE TYPE l=mkrhs(mty_longident) EQUAL rhs=module_type + { Pwith_modtype (l, rhs) } + | MODULE TYPE l=mkrhs(mty_longident) COLONEQUAL rhs=module_type + { Pwith_modtypesubst (l, rhs) } +; +with_type_binder: + EQUAL { Public } + | EQUAL PRIVATE { Private } +; + +/* Polymorphic types */ + +%inline typevar: + QUOTE ident + { mkrhs $2 $sloc } +; +%inline typevar_list: + nonempty_llist(typevar) + { $1 } +; +%inline poly(X): + typevar_list DOT X + { Ptyp_poly($1, $3) } +; +possibly_poly(X): + X + { $1 } +| mktyp(poly(X)) + { $1 } +; +%inline poly_type: + possibly_poly(core_type) + { $1 } +; +%inline poly_type_no_attr: + possibly_poly(core_type_no_attr) + { $1 } +; + +(* -------------------------------------------------------------------------- *) + +(* Core language types. *) + +(* A core type (core_type) is a core type without attributes (core_type_no_attr) + followed with a list of attributes. *) +core_type: + core_type_no_attr + { $1 } + | core_type attribute + { Typ.attr $1 $2 } +; + +(* A core type without attributes is currently defined as an alias type, but + this could change in the future if new forms of types are introduced. From + the outside, one should use core_type_no_attr. *) +%inline core_type_no_attr: + alias_type + { $1 } +; + +(* Alias types include: + - function types (see below); + - proper alias types: 'a -> int as 'a + *) +alias_type: + function_type + { $1 } + | mktyp( + ty = alias_type AS tyvar = typevar + { Ptyp_alias(ty, tyvar) } + ) + { $1 } +; + +(* Function types include: + - tuple types (see below); + - proper function types: int -> int + foo: int -> int + ?foo: int -> int + *) +function_type: + | ty = tuple_type + %prec MINUSGREATER + { ty } + | mktyp( + label = arg_label + domain = extra_rhs(tuple_type) + MINUSGREATER + codomain = function_type + { Ptyp_arrow(label, domain, codomain) } + ) + { $1 } +; +%inline arg_label: + | label = optlabel + { Optional label } + | label = LIDENT COLON + { Labelled label } + | /* empty */ + { Nolabel } +; +(* Tuple types include: + - atomic types (see below); + - proper tuple types: int * int * int list + A proper tuple type is a star-separated list of at least two atomic types. + *) +tuple_type: + | ty = atomic_type + %prec below_HASH + { ty } + | mktyp( + tys = separated_nontrivial_llist(STAR, atomic_type) + { Ptyp_tuple tys } + ) + { $1 } +; + +(* Atomic types are the most basic level in the syntax of types. + Atomic types include: + - types between parentheses: (int -> int) + - first-class module types: (module S) + - type variables: 'a + - applications of type constructors: int, int list, int option list + - variant types: [`A] + *) + + +(* + Delimited types: + - parenthesised type (type) + - first-class module types (module S) + - object types < x: t; ... > + - variant types [ `A ] + - extension [%foo ...] + + We support local opens on the following classes of types: + - parenthesised + - first-class module types + - variant types + + Object types are not support for local opens due to a potential + conflict with MetaOCaml syntax: + M.< x: t, y: t > + and quoted expressions: + .< e >. + + Extension types are not support for local opens merely as a precaution. +*) +delimited_type_supporting_local_open: + | LPAREN type_ = core_type RPAREN + { type_ } + | LPAREN MODULE attrs = ext_attributes package_type = package_type RPAREN + { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc package_type) attrs } + | mktyp( + LBRACKET field = tag_field RBRACKET + { Ptyp_variant([ field ], Closed, None) } + | LBRACKET BAR fields = row_field_list RBRACKET + { Ptyp_variant(fields, Closed, None) } + | LBRACKET field = row_field BAR fields = row_field_list RBRACKET + { Ptyp_variant(field :: fields, Closed, None) } + | LBRACKETGREATER BAR? fields = row_field_list RBRACKET + { Ptyp_variant(fields, Open, None) } + | LBRACKETGREATER RBRACKET + { Ptyp_variant([], Open, None) } + | LBRACKETLESS BAR? fields = row_field_list RBRACKET + { Ptyp_variant(fields, Closed, Some []) } + | LBRACKETLESS BAR? fields = row_field_list + GREATER + tags = name_tag_list + RBRACKET + { Ptyp_variant(fields, Closed, Some tags) } + ) + { $1 } +; + +object_type: + | mktyp( + LESS meth_list = meth_list GREATER + { let (f, c) = meth_list in Ptyp_object (f, c) } + | LESS GREATER + { Ptyp_object ([], Closed) } + ) + { $1 } +; + +extension_type: + | mktyp ( + ext = extension + { Ptyp_extension ext } + ) + { $1 } +; + +delimited_type: + | object_type + | extension_type + | delimited_type_supporting_local_open + { $1 } +; + +atomic_type: + | type_ = delimited_type + { type_ } + | mktyp( /* begin mktyp group */ + tys = actual_type_parameters + tid = mkrhs(type_longident) + { Ptyp_constr (tid, tys) } + | tys = actual_type_parameters + HASH + cid = mkrhs(clty_longident) + { Ptyp_class (cid, tys) } + | mod_ident = mkrhs(mod_ext_longident) + DOT + type_ = delimited_type_supporting_local_open + { Ptyp_open (mod_ident, type_) } + | QUOTE ident = ident + { Ptyp_var ident } + | UNDERSCORE + { Ptyp_any } + ) + { $1 } /* end mktyp group */ +; + +(* This is the syntax of the actual type parameters in an application of + a type constructor, such as int, int list, or (int, bool) Hashtbl.t. + We allow one of the following: + - zero parameters; + - one parameter: + an atomic type; + among other things, this can be an arbitrary type between parentheses; + - two or more parameters: + arbitrary types, between parentheses, separated with commas. + *) +%inline actual_type_parameters: + | /* empty */ + { [] } + | ty = atomic_type + { [ ty ] } + | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN + { tys } +; + +%inline package_type: module_type + { let (lid, cstrs, attrs) = package_type_of_module_type $1 in + let descr = Ptyp_package (lid, cstrs) in + mktyp ~loc:$sloc ~attrs descr } +; +%inline row_field_list: + separated_nonempty_llist(BAR, row_field) + { $1 } +; +row_field: + tag_field + { $1 } + | core_type + { Rf.inherit_ ~loc:(make_loc $sloc) $1 } +; +tag_field: + mkrhs(name_tag) OF opt_ampersand amper_type_list attributes + { let info = symbol_info $endpos in + let attrs = add_info_attrs info $5 in + Rf.tag ~loc:(make_loc $sloc) ~attrs $1 $3 $4 } + | mkrhs(name_tag) attributes + { let info = symbol_info $endpos in + let attrs = add_info_attrs info $2 in + Rf.tag ~loc:(make_loc $sloc) ~attrs $1 true [] } +; +opt_ampersand: + AMPERSAND { true } + | /* empty */ { false } +; +%inline amper_type_list: + separated_nonempty_llist(AMPERSAND, core_type_no_attr) + { $1 } +; +%inline name_tag_list: + nonempty_llist(name_tag) + { $1 } +; +(* A method list (in an object type). *) +meth_list: + head = field_semi tail = meth_list + | head = inherit_field SEMI tail = meth_list + { let (f, c) = tail in (head :: f, c) } + | head = field_semi + | head = inherit_field SEMI + { [head], Closed } + | head = field + | head = inherit_field + { [head], Closed } + | DOTDOT + { [], Open } +; +%inline field: + mkrhs(label) COLON poly_type_no_attr attributes + { let info = symbol_info $endpos in + let attrs = add_info_attrs info $4 in + Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 } +; + +%inline field_semi: + mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes + { let info = + match rhs_info $endpos($4) with + | Some _ as info_before_semi -> info_before_semi + | None -> symbol_info $endpos + in + let attrs = add_info_attrs info ($4 @ $6) in + Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 } +; + +%inline inherit_field: + ty = atomic_type + { Of.inherit_ ~loc:(make_loc $sloc) ty } +; + +%inline label: + LIDENT { $1 } +; + +/* Constants */ + +constant: + | INT { let (n, m) = $1 in + mkconst ~loc:$sloc (Pconst_integer (n, m)) } + | CHAR { mkconst ~loc:$sloc (Pconst_char $1) } + | STRING { let (s, strloc, d) = $1 in + mkconst ~loc:$sloc (Pconst_string (s,strloc,d)) } + | FLOAT { let (f, m) = $1 in + mkconst ~loc:$sloc (Pconst_float (f, m)) } +; +signed_constant: + constant { $1 } + | MINUS INT { let (n, m) = $2 in + mkconst ~loc:$sloc (Pconst_integer("-" ^ n, m)) } + | MINUS FLOAT { let (f, m) = $2 in + mkconst ~loc:$sloc (Pconst_float("-" ^ f, m)) } + | PLUS INT { let (n, m) = $2 in + mkconst ~loc:$sloc (Pconst_integer (n, m)) } + | PLUS FLOAT { let (f, m) = $2 in + mkconst ~loc:$sloc (Pconst_float(f, m)) } +; + +/* Identifiers and long identifiers */ + +ident: + UIDENT { $1 } + | LIDENT { $1 } +; +val_extra_ident: + | LPAREN operator RPAREN { $2 } + | LPAREN operator error { unclosed "(" $loc($1) ")" $loc($3) } + | LPAREN error { expecting $loc($2) "operator" } + | LPAREN MODULE error { expecting $loc($3) "module-expr" } +; +val_ident: + LIDENT { $1 } + | val_extra_ident { $1 } +; +operator: + PREFIXOP { $1 } + | LETOP { $1 } + | ANDOP { $1 } + | DOTOP LPAREN index_mod RPAREN { "."^ $1 ^"(" ^ $3 ^ ")" } + | DOTOP LPAREN index_mod RPAREN LESSMINUS { "."^ $1 ^ "(" ^ $3 ^ ")<-" } + | DOTOP LBRACKET index_mod RBRACKET { "."^ $1 ^"[" ^ $3 ^ "]" } + | DOTOP LBRACKET index_mod RBRACKET LESSMINUS { "."^ $1 ^ "[" ^ $3 ^ "]<-" } + | DOTOP LBRACE index_mod RBRACE { "."^ $1 ^"{" ^ $3 ^ "}" } + | DOTOP LBRACE index_mod RBRACE LESSMINUS { "."^ $1 ^ "{" ^ $3 ^ "}<-" } + | HASHOP { $1 } + | BANG { "!" } + | infix_operator { $1 } +; +%inline infix_operator: + | op = INFIXOP0 { op } + | op = INFIXOP1 { op } + | op = INFIXOP2 { op } + | op = INFIXOP3 { op } + | op = INFIXOP4 { op } + | PLUS {"+"} + | PLUSDOT {"+."} + | PLUSEQ {"+="} + | MINUS {"-"} + | MINUSDOT {"-."} + | STAR {"*"} + | PERCENT {"%"} + | EQUAL {"="} + | LESS {"<"} + | GREATER {">"} + | OR {"or"} + | BARBAR {"||"} + | AMPERSAND {"&"} + | AMPERAMPER {"&&"} + | COLONEQUAL {":="} +; +index_mod: +| { "" } +| SEMI DOTDOT { ";.." } +; + +%inline constr_extra_ident: + | LPAREN COLONCOLON RPAREN { "::" } +; +constr_extra_nonprefix_ident: + | LBRACKET RBRACKET { "[]" } + | LPAREN RPAREN { "()" } + | FALSE { "false" } + | TRUE { "true" } +; +constr_ident: + UIDENT { $1 } + | constr_extra_ident { $1 } + | constr_extra_nonprefix_ident { $1 } +; +constr_longident: + mod_longident %prec below_DOT { $1 } /* A.B.x vs (A).B.x */ + | mod_longident DOT constr_extra_ident { Ldot($1,$3) } + | constr_extra_ident { Lident $1 } + | constr_extra_nonprefix_ident { Lident $1 } +; +mk_longident(prefix,final): + | final { Lident $1 } + | prefix DOT final { Ldot($1,$3) } +; +val_longident: + mk_longident(mod_longident, val_ident) { $1 } +; +label_longident: + mk_longident(mod_longident, LIDENT) { $1 } +; +type_longident: + mk_longident(mod_ext_longident, LIDENT) { $1 } +; +mod_longident: + mk_longident(mod_longident, UIDENT) { $1 } +; +mod_ext_longident: + mk_longident(mod_ext_longident, UIDENT) { $1 } + | mod_ext_longident LPAREN mod_ext_longident RPAREN + { lapply ~loc:$sloc $1 $3 } + | mod_ext_longident LPAREN error + { expecting $loc($3) "module path" } +; +mty_longident: + mk_longident(mod_ext_longident,ident) { $1 } +; +clty_longident: + mk_longident(mod_ext_longident,LIDENT) { $1 } +; +class_longident: + mk_longident(mod_longident,LIDENT) { $1 } +; + +/* BEGIN AVOID */ +/* For compiler-libs: parse all valid longidents and a little more: + final identifiers which are value specific are accepted even when + the path prefix is only valid for types: (e.g. F(X).(::)) */ +any_longident: + | mk_longident (mod_ext_longident, + ident | constr_extra_ident | val_extra_ident { $1 } + ) { $1 } + | constr_extra_nonprefix_ident { Lident $1 } +; +/* END AVOID */ + +/* Toplevel directives */ + +toplevel_directive: + HASH dir = mkrhs(ident) + arg = ioption(mk_directive_arg(toplevel_directive_argument)) + { mk_directive ~loc:$sloc dir arg } +; + +%inline toplevel_directive_argument: + | STRING { let (s, _, _) = $1 in Pdir_string s } + | INT { let (n, m) = $1 in Pdir_int (n ,m) } + | val_longident { Pdir_ident $1 } + | mod_longident { Pdir_ident $1 } + | FALSE { Pdir_bool false } + | TRUE { Pdir_bool true } +; + +/* Miscellaneous */ + +(* The symbol epsilon can be used instead of an /* empty */ comment. *) +%inline epsilon: + /* empty */ + { () } +; + +%inline raw_string: + s = STRING + { let body, _, _ = s in body } +; + +name_tag: + BACKQUOTE ident { $2 } +; +rec_flag: + /* empty */ { Nonrecursive } + | REC { Recursive } +; +%inline nonrec_flag: + /* empty */ { Recursive } + | NONREC { Nonrecursive } +; +%inline no_nonrec_flag: + /* empty */ { Recursive } +/* BEGIN AVOID */ + | NONREC { not_expecting $loc "nonrec flag" } +/* END AVOID */ +; +direction_flag: + TO { Upto } + | DOWNTO { Downto } +; +private_flag: + inline_private_flag + { $1 } +; +%inline inline_private_flag: + /* empty */ { Public } + | PRIVATE { Private } +; +mutable_flag: + /* empty */ { Immutable } + | MUTABLE { Mutable } +; +virtual_flag: + /* empty */ { Concrete } + | VIRTUAL { Virtual } +; +mutable_virtual_flags: + /* empty */ + { Immutable, Concrete } + | MUTABLE + { Mutable, Concrete } + | VIRTUAL + { Immutable, Virtual } + | MUTABLE VIRTUAL + | VIRTUAL MUTABLE + { Mutable, Virtual } +; +private_virtual_flags: + /* empty */ { Public, Concrete } + | PRIVATE { Private, Concrete } + | VIRTUAL { Public, Virtual } + | PRIVATE VIRTUAL { Private, Virtual } + | VIRTUAL PRIVATE { Private, Virtual } +; +(* This nonterminal symbol indicates the definite presence of a VIRTUAL + keyword and the possible presence of a MUTABLE keyword. *) +virtual_with_mutable_flag: + | VIRTUAL { Immutable } + | MUTABLE VIRTUAL { Mutable } + | VIRTUAL MUTABLE { Mutable } +; +(* This nonterminal symbol indicates the definite presence of a VIRTUAL + keyword and the possible presence of a PRIVATE keyword. *) +virtual_with_private_flag: + | VIRTUAL { Public } + | PRIVATE VIRTUAL { Private } + | VIRTUAL PRIVATE { Private } +; +%inline no_override_flag: + /* empty */ { Fresh } +; +%inline override_flag: + /* empty */ { Fresh } + | BANG { Override } +; +subtractive: + | MINUS { "-" } + | MINUSDOT { "-." } +; +additive: + | PLUS { "+" } + | PLUSDOT { "+." } +; +optlabel: + | OPTLABEL { $1 } + | QUESTION LIDENT COLON { $2 } +; + +/* Attributes and extensions */ + +single_attr_id: + LIDENT { $1 } + | UIDENT { $1 } + | AND { "and" } + | AS { "as" } + | ASSERT { "assert" } + | BEGIN { "begin" } + | CLASS { "class" } + | CONSTRAINT { "constraint" } + | DO { "do" } + | DONE { "done" } + | DOWNTO { "downto" } + | ELSE { "else" } + | END { "end" } + | EXCEPTION { "exception" } + | EXTERNAL { "external" } + | FALSE { "false" } + | FOR { "for" } + | FUN { "fun" } + | FUNCTION { "function" } + | FUNCTOR { "functor" } + | IF { "if" } + | IN { "in" } + | INCLUDE { "include" } + | INHERIT { "inherit" } + | INITIALIZER { "initializer" } + | LAZY { "lazy" } + | LET { "let" } + | MATCH { "match" } + | METHOD { "method" } + | MODULE { "module" } + | MUTABLE { "mutable" } + | NEW { "new" } + | NONREC { "nonrec" } + | OBJECT { "object" } + | OF { "of" } + | OPEN { "open" } + | OR { "or" } + | PRIVATE { "private" } + | REC { "rec" } + | SIG { "sig" } + | STRUCT { "struct" } + | THEN { "then" } + | TO { "to" } + | TRUE { "true" } + | TRY { "try" } + | TYPE { "type" } + | VAL { "val" } + | VIRTUAL { "virtual" } + | WHEN { "when" } + | WHILE { "while" } + | WITH { "with" } +/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */ +; + +attr_id: + mkloc( + single_attr_id { $1 } + | single_attr_id DOT attr_id { $1 ^ "." ^ $3.txt } + ) { $1 } +; +attribute: + LBRACKETAT attr_id attr_payload RBRACKET + { mk_attr ~loc:(make_loc $sloc) $2 $3 } +; +post_item_attribute: + LBRACKETATAT attr_id attr_payload RBRACKET + { mk_attr ~loc:(make_loc $sloc) $2 $3 } +; +floating_attribute: + LBRACKETATATAT attr_id attr_payload RBRACKET + { mark_symbol_docs $sloc; + mk_attr ~loc:(make_loc $sloc) $2 $3 } +; +%inline post_item_attributes: + post_item_attribute* + { $1 } +; +%inline attributes: + attribute* + { $1 } +; +ext: + | /* empty */ { None } + | PERCENT attr_id { Some $2 } +; +%inline no_ext: + | /* empty */ { None } +/* BEGIN AVOID */ + | PERCENT attr_id { not_expecting $loc "extension" } +/* END AVOID */ +; +%inline ext_attributes: + ext attributes { $1, $2 } +; +extension: + | LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) } + | QUOTED_STRING_EXPR + { mk_quotedext ~loc:$sloc $1 } +; +item_extension: + | LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) } + | QUOTED_STRING_ITEM + { mk_quotedext ~loc:$sloc $1 } +; +payload: + structure { PStr $1 } + | COLON signature { PSig $2 } + | COLON core_type { PTyp $2 } + | QUESTION pattern { PPat ($2, None) } + | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) } +; +attr_payload: + payload + { Builtin_attributes.mark_payload_attrs_used $1; + $1 + } +; +%% diff --git a/upstream/ocaml_503/parsing/parsetree.mli b/upstream/ocaml_503/parsing/parsetree.mli new file mode 100644 index 000000000..e22a9a781 --- /dev/null +++ b/upstream/ocaml_503/parsing/parsetree.mli @@ -0,0 +1,1125 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree produced by parsing + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Asttypes + +type constant = { + pconst_desc : constant_desc; + pconst_loc : Location.t; +} + +and constant_desc = + | Pconst_integer of string * char option + (** Integer constants such as [3] [3l] [3L] [3n]. + + Suffixes [[g-z][G-Z]] are accepted by the parser. + Suffixes except ['l'], ['L'] and ['n'] are rejected by the typechecker + *) + | Pconst_char of char (** Character such as ['c']. *) + | Pconst_string of string * Location.t * string option + (** Constant string such as ["constant"] or + [{delim|other constant|delim}]. + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (** Float constant such as [3.4], [2e5] or [1.4e-4]. + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + +type location_stack = Location.t list + +(** {1 Extension points} *) + +type attribute = { + attr_name : string loc; + attr_payload : payload; + attr_loc : Location.t; + } +(** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + +and extension = string loc * payload +(** Extension points such as [[%id ARG] and [%%id ARG]]. + + Sub-language placeholder -- rejected by the typechecker. + *) + +and attributes = attribute list + +and payload = + | PStr of structure + | PSig of signature (** [: SIG] in an attribute or an extension point *) + | PTyp of core_type (** [: T] in an attribute or an extension point *) + | PPat of pattern * expression option + (** [? P] or [? P when E], in an attribute or an extension point *) + +(** {1 Core language} *) +(** {2 Type expressions} *) + +and core_type = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_loc_stack: location_stack; + ptyp_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and core_type_desc = + | Ptyp_any (** [_] *) + | Ptyp_var of string (** A type variable such as ['a] *) + | Ptyp_arrow of arg_label * core_type * core_type + (** [Ptyp_arrow(lbl, T1, T2)] represents: + - [T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Labelled}[Labelled]}, + - [?l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Optional}[Optional]}. + *) + | Ptyp_tuple of core_type list + (** [Ptyp_tuple([T1 ; ... ; Tn])] + represents a product type [T1 * ... * Tn]. + + Invariant: [n >= 2]. + *) + | Ptyp_constr of Longident.t loc * core_type list + (** [Ptyp_constr(lident, l)] represents: + - [tconstr] when [l=[]], + - [T tconstr] when [l=[T]], + - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_object of object_field list * closed_flag + (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: + - [< l1:T1; ...; ln:Tn >] when [flag] is + {{!Asttypes.closed_flag.Closed}[Closed]}, + - [< l1:T1; ...; ln:Tn; .. >] when [flag] is + {{!Asttypes.closed_flag.Open}[Open]}. + *) + | Ptyp_class of Longident.t loc * core_type list + (** [Ptyp_class(tconstr, l)] represents: + - [#tconstr] when [l=[]], + - [T #tconstr] when [l=[T]], + - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_alias of core_type * string loc (** [T as 'a]. *) + | Ptyp_variant of row_field list * closed_flag * label list option + (** [Ptyp_variant([`A;`B], flag, labels)] represents: + - [[ `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [None], + - [[> `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]}, + and [labels] is [None], + - [[< `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some []], + - [[< `A|`B > `X `Y ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some ["X";"Y"]]. + *) + | Ptyp_poly of string loc list * core_type + (** ['a1 ... 'an. T] + + Can only appear in the following context: + + - As the {!core_type} of a + {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding + to a constraint on a let-binding: + {[let x : 'a1 ... 'an. T = e ...]} + + - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods + (not values). + + - As the {!core_type} of a + {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. + + - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} + node. + + - As the {{!label_declaration.pld_type}[pld_type]} field of a + {!label_declaration}. + + - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} + node. + + - As the {{!value_description.pval_type}[pval_type]} field of a + {!value_description}. + *) + | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *) + | Ptyp_extension of extension (** [[%id]]. *) + +and package_type = Longident.t loc * (Longident.t loc * core_type) list +(** As {!package_type} typed values: + - [(S, [])] represents [(module S)], + - [(S, [(t1, T1) ; ... ; (tn, Tn)])] + represents [(module S with type t1 = T1 and ... and tn = Tn)]. + *) + +and row_field = { + prf_desc : row_field_desc; + prf_loc : Location.t; + prf_attributes : attributes; +} + +and row_field_desc = + | Rtag of label loc * bool * core_type list + (** [Rtag(`A, b, l)] represents: + - [`A] when [b] is [true] and [l] is [[]], + - [`A of T] when [b] is [false] and [l] is [[T]], + - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], + - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[T1;...Tn]]. + + - The [bool] field is true if the tag contains a + constant (empty) constructor. + - [&] occurs when several types are used for the same constructor + (see 4.2 in the manual) + *) + | Rinherit of core_type (** [[ | t ]] *) + +and object_field = { + pof_desc : object_field_desc; + pof_loc : Location.t; + pof_attributes : attributes; +} + +and object_field_desc = + | Otag of label loc * core_type + | Oinherit of core_type + +(** {2 Patterns} *) + +and pattern = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_loc_stack: location_stack; + ppat_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and pattern_desc = + | Ppat_any (** The pattern [_]. *) + | Ppat_var of string loc (** A variable pattern such as [x] *) + | Ppat_alias of pattern * string loc + (** An alias pattern such as [P as 'a] *) + | Ppat_constant of constant + (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) + | Ppat_interval of constant * constant + (** Patterns such as ['a'..'z']. + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (** Patterns [(P1, ..., Pn)]. + + Invariant: [n >= 2] + *) + | Ppat_construct of Longident.t loc * (string loc list * pattern) option + (** [Ppat_construct(C, args)] represents: + - [C] when [args] is [None], + - [C P] when [args] is [Some ([], P)] + - [C (P1, ..., Pn)] when [args] is + [Some ([], Ppat_tuple [P1; ...; Pn])] + - [C (type a b) P] when [args] is [Some ([a; b], P)] + *) + | Ppat_variant of label * pattern option + (** [Ppat_variant(`A, pat)] represents: + - [`A] when [pat] is [None], + - [`A P] when [pat] is [Some P] + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: + - [{ l1=P1; ...; ln=Pn }] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} + - [{ l1=P1; ...; ln=Pn; _}] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + + Invariant: [n > 0] + *) + | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) + | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) + | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) + | Ppat_type of Longident.t loc (** Pattern [#tconst] *) + | Ppat_lazy of pattern (** Pattern [lazy P] *) + | Ppat_unpack of string option loc + (** [Ppat_unpack(s)] represents: + - [(module P)] when [s] is [Some "P"] + - [(module _)] when [s] is [None] + + Note: [(module P : S)] is represented as + [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] + *) + | Ppat_exception of pattern (** Pattern [exception P] *) + | Ppat_effect of pattern * pattern (* Pattern [effect P P] *) + | Ppat_extension of extension (** Pattern [[%id]] *) + | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) + +(** {2 Value expressions} *) + +and expression = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_loc_stack: location_stack; + pexp_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and expression_desc = + | Pexp_ident of Longident.t loc + (** Identifiers such as [x] and [M.x] + *) + | Pexp_constant of constant + (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], + [1L], [1n] *) + | Pexp_let of rec_flag * value_binding list * expression + (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: + - [let P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pexp_function of + function_param list * type_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] + when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] + when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] + + [C] represents a type constraint or coercion placed immediately before the + arrow, e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. + + A function must have parameters. [Pexp_function (params, _, body)] must + have non-empty [params] or a [Pfunction_cases _] body. + *) + | Pexp_apply of expression * (arg_label * expression) list + (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] + represents [E0 ~l1:E1 ... ~ln:En] + + [li] can be + {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), + {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or + {{!Asttypes.arg_label.Optional}[Optional]} (optional argument). + + Invariant: [n > 0] + *) + | Pexp_match of expression * case list + (** [match E0 with P1 -> E1 | ... | Pn -> En] *) + | Pexp_try of expression * case list + (** [try E0 with P1 -> E1 | ... | Pn -> En] *) + | Pexp_tuple of expression list + (** Expressions [(E1, ..., En)] + + Invariant: [n >= 2] + *) + | Pexp_construct of Longident.t loc * expression option + (** [Pexp_construct(C, exp)] represents: + - [C] when [exp] is [None], + - [C E] when [exp] is [Some E], + - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] + *) + | Pexp_variant of label * expression option + (** [Pexp_variant(`A, exp)] represents + - [`A] when [exp] is [None] + - [`A E] when [exp] is [Some E] + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents + - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] + + Invariant: [n > 0] + *) + | Pexp_field of expression * Longident.t loc (** [E.l] *) + | Pexp_setfield of expression * Longident.t loc * expression + (** [E1.l <- E2] *) + | Pexp_array of expression list (** [[| E1; ...; En |]] *) + | Pexp_ifthenelse of expression * expression * expression option + (** [if E1 then E2 else E3] *) + | Pexp_sequence of expression * expression (** [E1; E2] *) + | Pexp_while of expression * expression (** [while E1 do E2 done] *) + | Pexp_for of pattern * expression * expression * direction_flag * expression + (** [Pexp_for(i, E1, E2, direction, E3)] represents: + - [for i = E1 to E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Upto}[Upto]} + - [for i = E1 downto E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} + *) + | Pexp_constraint of expression * core_type (** [(E : T)] *) + | Pexp_coerce of expression * core_type option * core_type + (** [Pexp_coerce(E, from, T)] represents + - [(E :> T)] when [from] is [None], + - [(E : T0 :> T)] when [from] is [Some T0]. + *) + | Pexp_send of expression * label loc (** [E # m] *) + | Pexp_new of Longident.t loc (** [new M.c] *) + | Pexp_setinstvar of label loc * expression (** [x <- 2] *) + | Pexp_override of (label loc * expression) list + (** [{< x1 = E1; ...; xn = En >}] *) + | Pexp_letmodule of string option loc * module_expr * expression + (** [let module M = ME in E] *) + | Pexp_letexception of extension_constructor * expression + (** [let exception C in E] *) + | Pexp_assert of expression + (** [assert E]. + + Note: [assert false] is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression (** [lazy E] *) + | Pexp_poly of expression * core_type option + (** Used for method bodies. + + Can only be used as the expression under + {{!class_field_kind.Cfk_concrete}[Cfk_concrete]} for methods (not + values). *) + | Pexp_object of class_structure (** [object ... end] *) + | Pexp_newtype of string loc * expression (** [fun (type t) -> E] *) + | Pexp_pack of module_expr + (** [(module ME)]. + + [(module ME : S)] is represented as + [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) + | Pexp_open of open_declaration * expression + (** - [M.(E)] + - [let open M in E] + - [let open! M in E] *) + | Pexp_letop of letop + (** - [let* P = E0 in E1] + - [let* P0 = E00 and* P1 = E01 in E1] *) + | Pexp_extension of extension (** [[%id]] *) + | Pexp_unreachable (** [.] *) + +and case = + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } +(** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) + +and letop = + { + let_ : binding_op; + ands : binding_op list; + body : expression; + } + +and binding_op = + { + pbop_op : string loc; + pbop_pat : pattern; + pbop_exp : expression; + pbop_loc : Location.t; + } + +and function_param_desc = + | Pparam_val of arg_label * expression option * pattern + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [~l:P] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [?l:P] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Note: If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + *) + | Pparam_newtype of string loc + (** [Pparam_newtype x] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x)] + as a whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ [ { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except marked as + ghost locations. The locations on [a], [b], [c], correspond to the + variables [a], [b], and [c] in the source code. + *) + +and function_param = + { pparam_loc : Location.t; + pparam_desc : function_param_desc; + } + +and function_body = + | Pfunction_body of expression + | Pfunction_cases of case list * Location.t * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The compiler + will only use typechecking-related attributes from [attrs], e.g. enabling + or disabling a warning. + *) +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +and type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +(** {2 Value descriptions} *) + +and value_description = + { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pval_loc: Location.t; + } +(** Values of type {!value_description} represents: + - [val x: T], + when {{!value_description.pval_prim}[pval_prim]} is [[]] + - [external x: T = "s1" ... "sn"] + when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]] +*) + +(** {2 Type declarations} *) + +and type_declaration = + { + ptype_name: string loc; + ptype_params: (core_type * (variance * injectivity)) list; + (** [('a1,...'an) t] *) + ptype_cstrs: (core_type * core_type * Location.t) list; + (** [... constraint T1=T1' ... constraint Tn=Tn'] *) + ptype_kind: type_kind; + ptype_private: private_flag; (** for [= private ...] *) + ptype_manifest: core_type option; (** represents [= T] *) + ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + ptype_loc: Location.t; + } +(** + Here are type declarations and their representation, + for various {{!type_declaration.ptype_kind}[ptype_kind]} + and {{!type_declaration.ptype_manifest}[ptype_manifest]} values: + - [type t] when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [None], + - [type t = T0] + when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [Some T0], + - [type t = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [None], + - [type t = T0 = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [Some T0], + - [type t = {l: T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [None], + - [type t = T0 = {l : T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [Some T0], + - [type t = ..] + when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, + and [manifest] is [None]. +*) + +and type_kind = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + | Ptype_record of label_declaration list (** Invariant: non-empty list *) + | Ptype_open + +and label_declaration = + { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_type: core_type; + pld_loc: Location.t; + pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) + } +(** + - [{ ...; l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, + - [{ ...; mutable l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. +*) + +and constructor_declaration = + { + pcd_name: string loc; + pcd_vars: string loc list; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) + } + +and constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + (** Values of type {!constructor_declaration} + represents the constructor arguments of: + - [C of T1 * ... * Tn] when [res = None], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C: T0] when [res = Some T0], + and [args = Pcstr_tuple []], + - [C: T1 * ... * Tn -> T0] when [res = Some T0], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C of {...}] when [res = None], + and [args = Pcstr_record [...]], + - [C: {...} -> T0] when [res = Some T0], + and [args = Pcstr_record [...]]. +*) + +and type_extension = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * (variance * injectivity)) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: Location.t; + ptyext_attributes: attributes; (** ... [\@\@id1] [\@\@id2] *) + } +(** + Definition of new extensions constructors for the extensive sum type [t] + ([type t += ...]). +*) + +and extension_constructor = + { + pext_name: string loc; + pext_kind: extension_constructor_kind; + pext_loc: Location.t; + pext_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) + } + +and type_exception = + { + ptyexn_constructor : extension_constructor; + ptyexn_loc : Location.t; + ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) + } +(** Definition of a new exception ([exception E]). *) + +and extension_constructor_kind = + | Pext_decl of string loc list * constructor_arguments * core_type option + (** [Pext_decl(existentials, c_args, t_opt)] + describes a new extension constructor. It can be: + - [C of T1 * ... * Tn] when: + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [None]}.} + - [C: T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[]],} + {- [t_opt] is [Some T0].}} + - [C: T1 * ... * Tn -> T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [Some T0].}} + - [C: 'a... . T1 * ... * Tn -> T0] when + {ul {- [existentials] is [['a;...]],} + {- [c_args] is [[T1; ... ; Tn]],} + {- [t_opt] is [Some T0].}} + *) + | Pext_rebind of Longident.t loc + (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) + +(** {1 Class language} *) +(** {2 Type expressions for the class language} *) + +and class_type = + { + pcty_desc: class_type_desc; + pcty_loc: Location.t; + pcty_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and class_type_desc = + | Pcty_constr of Longident.t loc * core_type list + (** - [c] + - [['a1, ..., 'an] c] *) + | Pcty_signature of class_signature (** [object ... end] *) + | Pcty_arrow of arg_label * core_type * class_type + (** [Pcty_arrow(lbl, T, CT)] represents: + - [T -> CT] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}, + - [?l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}. + *) + | Pcty_extension of extension (** [%id] *) + | Pcty_open of open_description * class_type (** [let open M in CT] *) + +and class_signature = + { + pcsig_self: core_type; + pcsig_fields: class_type_field list; + } +(** Values of type [class_signature] represents: + - [object('selfpat) ... end] + - [object ... end] when {{!class_signature.pcsig_self}[pcsig_self]} + is {{!core_type_desc.Ptyp_any}[Ptyp_any]} +*) + +and class_type_field = + { + pctf_desc: class_type_field_desc; + pctf_loc: Location.t; + pctf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } + +and class_type_field_desc = + | Pctf_inherit of class_type (** [inherit CT] *) + | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) + (** [val x: T] *) + | Pctf_method of (label loc * private_flag * virtual_flag * core_type) + (** [method x: T] + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. + *) + | Pctf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pctf_attribute of attribute (** [[\@\@\@id]] *) + | Pctf_extension of extension (** [[%%id]] *) + +and 'a class_infos = + { + pci_virt: virtual_flag; + pci_params: (core_type * (variance * injectivity)) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } +(** Values of type [class_expr class_infos] represents: + - [class c = ...] + - [class ['a1,...,'an] c = ...] + - [class virtual c = ...] + + They are also used for "class type" declaration. +*) + +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +(** {2 Value expressions for the class language} *) + +and class_expr = + { + pcl_desc: class_expr_desc; + pcl_loc: Location.t; + pcl_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and class_expr_desc = + | Pcl_constr of Longident.t loc * core_type list + (** [c] and [['a1, ..., 'an] c] *) + | Pcl_structure of class_structure (** [object ... end] *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (** [Pcl_fun(lbl, exp0, P, CE)] represents: + - [fun P -> CE] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None], + - [fun ~l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None], + - [fun ?l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None], + - [fun ?l:(P = E0) -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0]. + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] + represents [CE ~l1:E1 ... ~ln:En]. + [li] can be empty (non labeled argument) or start with [?] + (optional argument). + + Invariant: [n > 0] + *) + | Pcl_let of rec_flag * value_binding list * class_expr + (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: + - [let P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pcl_constraint of class_expr * class_type (** [(CE : CT)] *) + | Pcl_extension of extension (** [[%id]] *) + | Pcl_open of open_description * class_expr (** [let open M in CE] *) + +and class_structure = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } +(** Values of type {!class_structure} represents: + - [object(selfpat) ... end] + - [object ... end] when {{!class_structure.pcstr_self}[pcstr_self]} + is {{!pattern_desc.Ppat_any}[Ppat_any]} +*) + +and class_field = + { + pcf_desc: class_field_desc; + pcf_loc: Location.t; + pcf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } + +and class_field_desc = + | Pcf_inherit of override_flag * class_expr * string loc option + (** [Pcf_inherit(flag, CE, s)] represents: + - [inherit CE] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [None], + - [inherit CE as x] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [Some x], + - [inherit! CE] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [None], + - [inherit! CE as x] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [Some x] + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (** [Pcf_val(x,flag, kind)] represents: + - [val x = E] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + - [val mutable x = E] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val mutable virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (** - [method x = E] + ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) + - [method virtual x: T] + ([T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}) + *) + | Pcf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pcf_initializer of expression (** [initializer E] *) + | Pcf_attribute of attribute (** [[\@\@\@id]] *) + | Pcf_extension of extension (** [[%%id]] *) + +and class_field_kind = + | Cfk_virtual of core_type + | Cfk_concrete of override_flag * expression + +and class_declaration = class_expr class_infos + +(** {1 Module language} *) +(** {2 Type expressions for the module language} *) + +and module_type = + { + pmty_desc: module_type_desc; + pmty_loc: Location.t; + pmty_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and module_type_desc = + | Pmty_ident of Longident.t loc (** [Pmty_ident(S)] represents [S] *) + | Pmty_signature of signature (** [sig ... end] *) + | Pmty_functor of functor_parameter * module_type + (** [functor(X : MT1) -> MT2] *) + | Pmty_with of module_type * with_constraint list (** [MT with ...] *) + | Pmty_typeof of module_expr (** [module type of ME] *) + | Pmty_extension of extension (** [[%id]] *) + | Pmty_alias of Longident.t loc (** [(module M)] *) + +and functor_parameter = + | Unit (** [()] *) + | Named of string option loc * module_type + (** [Named(name, MT)] represents: + - [(X : MT)] when [name] is [Some X], + - [(_ : MT)] when [name] is [None] *) + +and signature = signature_item list + +and signature_item = + { + psig_desc: signature_item_desc; + psig_loc: Location.t; + } + +and signature_item_desc = + | Psig_value of value_description + (** - [val x: T] + - [external x: T = "s1" ... "sn"] + *) + | Psig_type of rec_flag * type_declaration list + (** [type t1 = ... and ... and tn = ...] *) + | Psig_typesubst of type_declaration list + (** [type t1 := ... and ... and tn := ...] *) + | Psig_typext of type_extension (** [type t1 += ...] *) + | Psig_exception of type_exception (** [exception C of T] *) + | Psig_module of module_declaration (** [module X = M] and [module X : MT] *) + | Psig_modsubst of module_substitution (** [module X := M] *) + | Psig_recmodule of module_declaration list + (** [module rec X1 : MT1 and ... and Xn : MTn] *) + | Psig_modtype of module_type_declaration + (** [module type S = MT] and [module type S] *) + | Psig_modtypesubst of module_type_declaration + (** [module type S := ...] *) + | Psig_open of open_description (** [open X] *) + | Psig_include of include_description (** [include MT] *) + | Psig_class of class_description list + (** [class c1 : ... and ... and cn : ...] *) + | Psig_class_type of class_type_declaration list + (** [class type ct1 = ... and ... and ctn = ...] *) + | Psig_attribute of attribute (** [[\@\@\@id]] *) + | Psig_extension of extension * attributes (** [[%%id]] *) + +and module_declaration = + { + pmd_name: string option loc; + pmd_type: module_type; + pmd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmd_loc: Location.t; + } +(** Values of type [module_declaration] represents [S : MT] *) + +and module_substitution = + { + pms_name: string loc; + pms_manifest: Longident.t loc; + pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pms_loc: Location.t; + } +(** Values of type [module_substitution] represents [S := M] *) + +and module_type_declaration = + { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmtd_loc: Location.t; + } +(** Values of type [module_type_declaration] represents: + - [S = MT], + - [S] for abstract module type declaration, + when {{!module_type_declaration.pmtd_type}[pmtd_type]} is [None]. +*) + +and 'a open_infos = + { + popen_expr: 'a; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } +(** Values of type ['a open_infos] represents: + - [open! X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Override}[Override]} + (silences the "used identifier shadowing" warning) + - [open X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Fresh}[Fresh]} +*) + +and open_description = Longident.t loc open_infos +(** Values of type [open_description] represents: + - [open M.N] + - [open M(N).O] *) + +and open_declaration = module_expr open_infos +(** Values of type [open_declaration] represents: + - [open M.N] + - [open M(N).O] + - [open struct ... end] *) + +and 'a include_infos = + { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; + } + +and include_description = module_type include_infos +(** Values of type [include_description] represents [include MT] *) + +and include_declaration = module_expr include_infos +(** Values of type [include_declaration] represents [include ME] *) + +and with_constraint = + | Pwith_type of Longident.t loc * type_declaration + (** [with type X.t = ...] + + Note: the last component of the longident must match + the name of the type_declaration. *) + | Pwith_module of Longident.t loc * Longident.t loc + (** [with module X.Y = Z] *) + | Pwith_modtype of Longident.t loc * module_type + (** [with module type X.Y = Z] *) + | Pwith_modtypesubst of Longident.t loc * module_type + (** [with module type X.Y := sig end] *) + | Pwith_typesubst of Longident.t loc * type_declaration + (** [with type X.t := ..., same format as [Pwith_type]] *) + | Pwith_modsubst of Longident.t loc * Longident.t loc + (** [with module X.Y := Z] *) + +(** {2 Value expressions for the module language} *) + +and module_expr = + { + pmod_desc: module_expr_desc; + pmod_loc: Location.t; + pmod_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and module_expr_desc = + | Pmod_ident of Longident.t loc (** [X] *) + | Pmod_structure of structure (** [struct ... end] *) + | Pmod_functor of functor_parameter * module_expr + (** [functor(X : MT1) -> ME] *) + | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *) + | Pmod_apply_unit of module_expr (** [ME1()] *) + | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) + | Pmod_unpack of expression (** [(val E)] *) + | Pmod_extension of extension (** [[%id]] *) + +and structure = structure_item list + +and structure_item = + { + pstr_desc: structure_item_desc; + pstr_loc: Location.t; + } + +and structure_item_desc = + | Pstr_eval of expression * attributes (** [E] *) + | Pstr_value of rec_flag * value_binding list + (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: + - [let P1 = E1 and ... and Pn = EN] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN ] + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pstr_primitive of value_description + (** - [val x: T] + - [external x: T = "s1" ... "sn" ]*) + | Pstr_type of rec_flag * type_declaration list + (** [type t1 = ... and ... and tn = ...] *) + | Pstr_typext of type_extension (** [type t1 += ...] *) + | Pstr_exception of type_exception + (** - [exception C of T] + - [exception C = M.X] *) + | Pstr_module of module_binding (** [module X = ME] *) + | Pstr_recmodule of module_binding list + (** [module rec X1 = ME1 and ... and Xn = MEn] *) + | Pstr_modtype of module_type_declaration (** [module type S = MT] *) + | Pstr_open of open_declaration (** [open X] *) + | Pstr_class of class_declaration list + (** [class c1 = ... and ... and cn = ...] *) + | Pstr_class_type of class_type_declaration list + (** [class type ct1 = ... and ... and ctn = ...] *) + | Pstr_include of include_declaration (** [include ME] *) + | Pstr_attribute of attribute (** [[\@\@\@id]] *) + | Pstr_extension of extension * attributes (** [[%%id]] *) + +and value_constraint = + | Pvc_constraint of { + locally_abstract_univars:string loc list; + typ:core_type; + } + | Pvc_coercion of {ground:core_type option; coercion:core_type } + (** + - [Pvc_constraint { locally_abstract_univars=[]; typ}] + is a simple type constraint on a value binding: [ let x : typ] + - More generally, in [Pvc_constraint { locally_abstract_univars; typ}] + [locally_abstract_univars] is the list of locally abstract type + variables in [ let x: type a ... . typ ] + - [Pvc_coercion { ground=None; coercion }] represents [let x :> typ] + - [Pvc_coercion { ground=Some g; coercion }] represents [let x : g :> typ] + *) + +and value_binding = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_constraint: value_constraint option; + pvb_attributes: attributes; + pvb_loc: Location.t; + }(** [let pat : type_constraint = exp] *) + +and module_binding = + { + pmb_name: string option loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } +(** Values of type [module_binding] represents [module X = ME] *) + +(** {1 Toplevel} *) + +(** {2 Toplevel phrases} *) + +type toplevel_phrase = + | Ptop_def of structure + | Ptop_dir of toplevel_directive (** [#use], [#load] ... *) + +and toplevel_directive = + { + pdir_name: string loc; + pdir_arg: directive_argument option; + pdir_loc: Location.t; + } + +and directive_argument = + { + pdira_desc: directive_argument_desc; + pdira_loc: Location.t; + } + +and directive_argument_desc = + | Pdir_string of string + | Pdir_int of string * char option + | Pdir_ident of Longident.t + | Pdir_bool of bool diff --git a/upstream/ocaml_503/parsing/pprintast.ml b/upstream/ocaml_503/parsing/pprintast.ml new file mode 100644 index 000000000..015cf117d --- /dev/null +++ b/upstream/ocaml_503/parsing/pprintast.ml @@ -0,0 +1,1811 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) + +open Asttypes +open Format +open Location +open Longident +open Parsetree + +let prefix_symbols = [ '!'; '?'; '~' ] +let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; + '$'; '%'; '#' ] + +(* type fixity = Infix| Prefix *) +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] + +let letop s = + String.length s > 3 + && s.[0] = 'l' + && s.[1] = 'e' + && s.[2] = 't' + && List.mem s.[3] infix_symbols + +let andop s = + String.length s > 3 + && s.[0] = 'a' + && s.[1] = 'n' + && s.[2] = 'd' + && List.mem s.[3] infix_symbols + +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string = function + | "" -> `Normal + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | s when letop s -> `Letop s + | s when andop s -> `Andop s + | _ -> `Normal + +let view_fixity_of_exp = function + | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> + fixity_of_string l + | _ -> `Normal + +let is_infix = function `Infix _ -> true | _ -> false +let is_mixfix = function `Mixfix _ -> true | _ -> false +let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false + +let first_is c str = + str <> "" && str.[0] = c +let last_is c str = + str <> "" && str.[String.length str - 1] = c + +let first_is_in cs str = + str <> "" && List.mem str.[0] cs + +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix + || is_mixfix fix + || is_kwdop fix + || first_is_in prefix_symbols txt + +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = + first_is '*' txt || last_is '*' txt + +let tyvar_of_name s = + if String.length s >= 2 && s.[1] = '\'' then + (* without the space, this would be parsed as + a character literal *) + "' " ^ s + else if Lexer.is_keyword s then + "'\\#" ^ s + else if String.equal s "_" then + s + else + "'" ^ s + +module Doc = struct +(* Turn an arbitrary variable name into a valid OCaml identifier by adding \# + in case it is a keyword, or parenthesis when it is an infix or prefix + operator. *) + let ident_of_name ppf txt = + let format : (_, _, _) format = + if Lexer.is_keyword txt then "\\#%s" + else if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in Format_doc.fprintf ppf format txt + + let protect_longident ppf print_longident longprefix txt = + if not (needs_parens txt) then + Format_doc.fprintf ppf "%a.%a" + print_longident longprefix + ident_of_name txt + else if needs_spaces txt then + Format_doc.fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt + else + Format_doc.fprintf ppf "%a.(%s)" print_longident longprefix txt + + let rec longident f = function + | Lident s -> ident_of_name f s + | Ldot(y,s) -> protect_longident f longident y s + | Lapply (y,s) -> + Format_doc.fprintf f "%a(%a)" longident y longident s + + let tyvar ppf s = + Format_doc.fprintf ppf "%s" (tyvar_of_name s) + + (* Expressions are considered nominal if they can be used as the subject of a + sentence or action. In practice, we consider that an expression is nominal + if they satisfy one of: + - Similar to an identifier: words separated by '.' or '#'. + - Do not contain spaces when printed. + - Is a constant that is short enough. + *) + let nominal_exp t = + let open Format_doc.Doc in + let longident l = Format_doc.doc_printer longident l.Location.txt in + let rec nominal_exp doc exp = + match exp.pexp_desc with + | _ when exp.pexp_attributes <> [] -> None + | Pexp_ident l -> + Some (longident l doc) + | Pexp_variant (lbl, None) -> + Some (printf "`%s" lbl doc) + | Pexp_construct (l, None) -> + Some (longident l doc) + | Pexp_field (parent, lbl) -> + Option.map + (printf ".%t" (longident lbl)) + (nominal_exp doc parent) + | Pexp_send (parent, meth) -> + Option.map + (printf "#%s" meth.txt) + (nominal_exp doc parent) + (* String constants are syntactically too complex. For example, the + quotes conflict with the 'inline_code' style and they might contain + spaces. *) + | Pexp_constant { pconst_desc = Pconst_string _; _ } -> None + (* Char, integer and float constants are nominal. *) + | Pexp_constant { pconst_desc = Pconst_char c; _ } -> + Some (msg "%C" c) + | Pexp_constant + { pconst_desc = Pconst_integer (cst, suf) | Pconst_float (cst, suf); + _ } -> + Some (msg "%s%t" cst (option char suf)) + | _ -> None + in + nominal_exp empty t +end + +let longident ppf l = Format_doc.compat Doc.longident ppf l +let ident_of_name ppf i = Format_doc.compat Doc.ident_of_name ppf i +let ident_of_name_loc ppf s = ident_of_name ppf s.txt + +type space_formatter = (unit, Format.formatter, unit) format + +let override = function + | Override -> "!" + | Fresh -> "" + +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | NoVariance -> "" + | Covariant -> "+" + | Contravariant -> "-" + +let type_injectivity = function + | NoInjectivity -> "" + | Injective -> "!" + +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `tuple + | `btrue + | `bfalse ] + +let view_expr x = + match x.pexp_desc with + | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple + | Pexp_construct ( {txt= Lident "true"; _},_) -> `btrue + | Pexp_construct ( {txt= Lident "false"; _},_) -> `bfalse + | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil + | Pexp_construct ( {txt= Lident"::";_},Some _) -> + let rec loop exp acc = match exp with + | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); + pexp_attributes = []} -> + (List.rev acc,true) + | {pexp_desc= + Pexp_construct ({txt=Lident "::";_}, + Some ({pexp_desc= Pexp_tuple([e1;e2]); + pexp_attributes = []})); + pexp_attributes = []} + -> + loop e2 (e1::acc) + | e -> (List.rev (e::acc),false) in + let (ls,b) = loop x [] in + if b then + `list ls + else `cons ls + | Pexp_construct (x,None) -> `simple (x.txt) + | _ -> `normal + +let is_simple_construct :construct -> bool = function + | `nil | `tuple | `list _ | `simple _ | `btrue | `bfalse -> true + | `cons _ | `normal -> false + +let pp = fprintf + +type ctxt = { + pipe : bool; + semi : bool; + ifthenelse : bool; + functionrhs : bool; +} + +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false; functionrhs=false } +let under_pipe ctxt = { ctxt with pipe=true } +let under_semi ctxt = { ctxt with semi=true } +let under_ifthenelse ctxt = { ctxt with ifthenelse=true } +let under_functionrhs ctxt = { ctxt with functionrhs = true } +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) + +let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> + ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit + = fun ?sep ?first ?last fu f xs -> + let first = match first with Some x -> x |None -> ("": _ format6) + and last = match last with Some x -> x |None -> ("": _ format6) + and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in + let aux f = function + | [] -> () + | [x] -> fu f x + | xs -> + let rec loop f = function + | [x] -> fu f x + | x::xs -> fu f x; pp f sep; loop f xs; + | _ -> assert false in begin + pp f first; loop f xs; pp f last; + end in + aux f xs + +let option : 'a. ?first:space_formatter -> ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit + = fun ?first ?last fu f a -> + let first = match first with Some x -> x | None -> ("": _ format6) + and last = match last with Some x -> x | None -> ("": _ format6) in + match a with + | None -> () + | Some x -> pp f first; fu f x; pp f last + +let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> + bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit + = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") + else fu f x + +let longident_loc f x = pp f "%a" longident x.txt + +let constant_desc f = function + | Pconst_char i -> + pp f "%C" i + | Pconst_string (i, _, None) -> + pp f "%S" i + | Pconst_string (i, _, Some delim) -> + pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> + paren (first_is '-' i) (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m) + | Pconst_float (i, None) -> + paren (first_is '-' i) (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> + paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m) + +let constant f const = constant_desc f const.pconst_desc + +(* trailing space*) +let mutable_flag f = function + | Immutable -> () + | Mutable -> pp f "mutable@;" +let virtual_flag f = function + | Concrete -> () + | Virtual -> pp f "virtual@;" + +(* trailing space added *) +let rec_flag f rf = + match rf with + | Nonrecursive -> () + | Recursive -> pp f "rec " +let nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " +let private_flag f = function + | Public -> () + | Private -> pp f "private@ " + +let iter_loc f ctxt {txt; loc = _} = f ctxt txt + +let constant_string f s = pp f "%S" s + + + +let tyvar ppf v = Format_doc.compat Doc.tyvar ppf v + +let tyvar_loc f str = tyvar f str.txt +let string_quot f x = pp f "`%a" ident_of_name x + +(* c ['a,'b] *) +let rec class_params_def ctxt f = function + | [] -> () + | l -> + pp f "[%a] " (* space *) + (list (type_param ctxt) ~sep:",") l + +and type_with_label ctxt f (label, c) = + match label with + | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) + | Labelled s -> pp f "%a:%a" ident_of_name s (core_type1 ctxt) c + | Optional s -> pp f "?%a:%a" ident_of_name s (core_type1 ctxt) c + +and core_type ctxt f x = + if x.ptyp_attributes <> [] then begin + pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} + (attributes ctxt) x.ptyp_attributes + end + else match x.ptyp_desc with + | Ptyp_arrow (l, ct1, ct2) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + | Ptyp_alias (ct, s) -> + pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s.txt + | Ptyp_poly ([], ct) -> + core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x + +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else match x.ptyp_desc with + | Ptyp_any -> pp f "_"; + | Ptyp_var s -> tyvar f s; + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> match l with + |[] -> () + |[x]-> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let first_is_inherit = match l with + | {Parsetree.prf_desc = Rinherit _}::_ -> true + | _ -> false in + let type_variant_helper f x = + match x.prf_desc with + | Rtag (l, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l + (fun f l -> match l with + |[] -> () + | _ -> pp f "@;of@;%a" + (list (core_type ctxt) ~sep:"&") ctl) ctl + (attributes ctxt) x.prf_attributes + | Rinherit ct -> core_type ctxt f ct in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match l, closed with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed,low) with + | (Closed,None) -> if first_is_inherit then " |" else "" + | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) + | (Open,_) -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") l) l + (fun f low -> match low with + |Some [] |None -> () + |Some xs -> + pp f ">@ %a" + (list string_quot) xs) low + | Ptyp_object (l, o) -> + let core_field_type f x = match x.pof_desc with + | Otag (l, ct) -> + (* Cf #7200 *) + pp f "@[%a: %a@ %a@ @]" ident_of_name l.txt + (core_type ctxt) ct (attributes ctxt) x.pof_attributes + | Oinherit ct -> + pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> + match l with + | [] -> pp f ".." + | _ -> pp f " ;.." + in + pp f "@[<@ %a%a@ > @]" + (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%a#%a@]" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l + longident_loc li + | Ptyp_package (lid, cstrs) -> + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in + (match cstrs with + |[] -> pp f "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_open(li, ct) -> + pp f "@[%a.(%a)@]" longident_loc li (core_type ctxt) ct + | Ptyp_extension e -> extension ctxt f e + | (Ptyp_arrow _ | Ptyp_alias _ | Ptyp_poly _) -> + paren true (core_type ctxt) f x + +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + if x.ppat_attributes <> [] then begin + pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} + (attributes ctxt) x.ppat_attributes + end + else match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p ident_of_name s.txt + | _ -> pattern_or ctxt f x + +and pattern_or ctxt f x = + let rec left_associative x acc = match x with + | {ppat_desc=Ppat_or (p1,p2); ppat_attributes = []} -> + left_associative p1 (p2 :: acc) + | x -> x :: acc + in + match left_associative x [] with + | [] -> assert false + | [x] -> pattern1 ctxt f x + | orpats -> + pp f "@[%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats + +and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = + let rec pattern_list_helper f = function + | {ppat_desc = + Ppat_construct + ({ txt = Lident("::") ;_}, + Some ([], {ppat_desc = Ppat_tuple([pat1; pat2]);_})); + ppat_attributes = []} + + -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%a@;%a@]" ident_of_name l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]"|"true"|"false");_}), _) -> + simple_pattern ctxt f x + | Ppat_construct (({txt;_} as li), po) -> + (* FIXME The third field always false *) + if txt = Lident "::" then + pp f "%a" pattern_list_helper x + else + (match po with + | Some ([], x) -> + pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | Some (vl, x) -> + pp f "%a@ (type %a)@;%a" longident_loc li + (list ~sep:"@ " ident_of_name_loc) vl + (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x + +and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false" as x);_}), None) -> + pp f "%s" x + | Ppat_any -> pp f "_"; + | Ppat_var ({txt = txt;_}) -> ident_of_name f txt + | Ppat_array l -> + pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack { txt = None } -> + pp f "(module@ _)@ " + | Ppat_unpack { txt = Some s } -> + pp f "(module@ %s)@ " s + | Ppat_type li -> + pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + begin match closed with + | Closed -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> + pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + end + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant (c) -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l,None) -> pp f "`%a" ident_of_name l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_lazy p -> + pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_effect(p1, p2) -> + pp f "@[<2>effect@;%a, @;%a@]" (pattern1 ctxt) p1 (pattern1 ctxt) p2 + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false");_}), None) -> + false + | _ -> true in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) p + | _ -> paren true (pattern ctxt) f x + +and label_exp ctxt f (l,opt,p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional rest -> + begin match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = rest -> + (match opt with + | Some o -> + pp f "?(%a=@;%a)@;" ident_of_name rest (expression ctxt) o + | None -> pp f "?%a@ " ident_of_name rest) + | _ -> + (match opt with + | Some o -> + pp f "?%a:(%a=@;%a)@;" + ident_of_name rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%a:%a@;" ident_of_name rest (simple_pattern ctxt) p) + end + | Labelled l -> match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = l -> + pp f "~%a@;" ident_of_name l + | _ -> pp f "~%a:%a@;" ident_of_name l (simple_pattern ctxt) p + +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else match e.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; + pexp_attributes=[]; _}, args) + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin + let print_indexop a path_prefix assign left sep right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m in + match assign, rem_args with + | false, [] -> + pp f "@[%a%a%s%a%s@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep print_index) indices right; true + | true, [v] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep print_index) indices right + (simple_expr ctxt) v; true + | _ -> false in + match id, List.map snd args with + | Lident "!", [e] -> + pp f "@[!%a@]" (simple_expr ctxt) e; true + | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin + let assign = func = "set" in + let print = print_indexop a None assign in + match path, other_args with + | Lident "Array", i :: rest -> + print ".(" "" ")" (expression ctxt) [i] rest + | Lident "String", i :: rest -> + print ".[" "" "]" (expression ctxt) [i] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "," "}" (simple_expr ctxt) [i1] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest + | Ldot (Lident "Bigarray", "Genarray"), + {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> + print ".{" "," "}" (simple_expr ctxt) indexes rest + | _ -> false + end + | (Lident s | Ldot(_,s)) , a :: i :: rest + when first_is '.' s -> + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let multi_indices = String.contains s ';' in + let i = + match i.pexp_desc with + | Pexp_array l when multi_indices -> l + | _ -> [ i ] in + let assign = last_is '-' s in + let kind = + (* extract the right end bracket *) + let n = String.length s in + if assign then s.[n - 3] else s.[n - 1] in + let left, right = match kind with + | ')' -> '(', ")" + | ']' -> '[', "]" + | '}' -> '{', "}" + | _ -> assert false in + let path_prefix = match id with + | Ldot(m,_) -> Some m + | _ -> None in + let left = String.sub s 0 (1+String.index s left) in + print_indexop a path_prefix assign left ";" right + (if multi_indices then expression ctxt else simple_expr ctxt) + i rest + | _ -> false + end + | _ -> false + +and function_param ctxt f param = + match param.pparam_desc with + | Pparam_val (a, b, c) -> label_exp ctxt f (a, b, c) + | Pparam_newtype ty -> pp f "(type %a)@;" ident_of_name ty.txt + +and function_body ctxt f function_body = + match function_body with + | Pfunction_body body -> expression ctxt f body + | Pfunction_cases (cases, _, attrs) -> + pp f "@[function%a%a@]" + (item_attributes ctxt) attrs + (case_list ctxt) cases + +and type_constraint ctxt f constraint_ = + match constraint_ with + | Pconstraint ty -> + pp f ":@;%a" (core_type ctxt) ty + | Pcoerce (ty1, ty2) -> + pp f "%a:>@;%a" + (option ~first:":@;" (core_type ctxt)) ty1 + (core_type ctxt) ty2 + +and function_params_then_body ctxt f params constraint_ body ~delimiter = + pp f "%a%a%s@;%a" + (list (function_param ctxt) ~sep:"") params + (option (type_constraint ctxt)) constraint_ + delimiter + (function_body (under_functionrhs ctxt)) body + +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} + (attributes ctxt) x.pexp_attributes + else match x.pexp_desc with + | Pexp_function _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + | Pexp_newtype _ + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ + | Pexp_letexception _ | Pexp_letop _ + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_newtype (lid, e) -> + pp f "@[<2>fun@;(type@;%a)@;->@;%a@]" ident_of_name lid.txt + (expression ctxt) e + | Pexp_function (params, c, body) -> + begin match params, c with + (* Omit [fun] if there are no params. *) + | [], None -> + (* If function cases are a direct body of a function, + the function node should be wrapped in parens so + it doesn't become part of the enclosing function. *) + let should_paren = + match body with + | Pfunction_cases _ -> ctxt.functionrhs + | Pfunction_body _ -> false + in + let ctxt' = if should_paren then reset_ctxt else ctxt in + pp f "@[<2>%a@]" (paren should_paren (function_body ctxt')) body + | [], Some c -> + pp f "@[<2>(%a@;%a)@]" + (function_body ctxt) body + (type_constraint ctxt) c + | _ :: _, _ -> + pp f "@[<2>fun@;%a@]" + (fun f () -> + function_params_then_body ctxt f params c body ~delimiter:"->") + (); + + end + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l + + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" + (bindings reset_ctxt) (rf,l) + (expression ctxt) e + | Pexp_apply (e, l) -> + begin if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> + begin match l with + | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) arg1 s + (label_x_expression_param ctxt) arg2 + | _ -> + pp f "@[<2>%a %a@]" + (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | `Prefix s -> + let s = + if List.mem s ["~+";"~-";"~+.";"~-."] && + (match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + |[(_,{pexp_desc=Pexp_constant _})] -> false + | _ -> true) + then String.sub s 1 (String.length s -1) + else s in + begin match l with + | [(Nolabel, x)] -> + pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | _ -> + pp f "@[%a@]" begin fun f (e,l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) l + (* reset here only because [function,match,try,sequence] + are lower priority *) + end (e,l) + end + + | Pexp_construct (li, Some eo) + when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) + (match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> + pp f "@[<2>%a@;%a@]" longident_loc li + (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" + (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> match eo with + | Some x -> + pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () (* pp f "()" *)) eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> + sequence_helper (e1::acc) e2 + | v -> List.rev (v::acc) in + let lst = sequence_helper [] x in + pp f "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%a@ <-@ %a@]" ident_of_name s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%a@ =@ %a@]" ident_of_name s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" + (Option.value s.txt ~default:"_") + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[lazy@ %a@]" (simple_expr ctxt) e + (* Pexp_poly: impossible but we should print it anyway, rather than + assert false *) + | Pexp_poly (e, None) -> + pp f "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!poly!@ %a@ : %a)@]" + (simple_expr ctxt) e (core_type ctxt) ct + | Pexp_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) (module_expr ctxt) o.popen_expr + (expression ctxt) e + | Pexp_variant (l,Some eo) -> + pp f "@[<2>`%a@;%a@]" ident_of_name l (simple_expr ctxt) eo + | Pexp_letop {let_; ands; body} -> + pp f "@[<2>@[%a@,%a@] in@;<1 -2>%a@]" + (binding_op ctxt) let_ + (list ~sep:"@," (binding_op ctxt)) ands + (expression ctxt) body + | Pexp_extension e -> extension ctxt f e + | Pexp_unreachable -> pp f "." + | _ -> expression1 ctxt f x + +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs + | _ -> expression2 ctxt f x +(* used in [Pexp_apply] *) + +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> + pp f "@[%a#%a@]" (simple_expr ctxt) e ident_of_name s.txt + + | _ -> simple_expr ctxt f x + +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> + (match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `btrue -> pp f "true" + | `bfalse -> pp f "false" + | `list xs -> + pp f "@[[%a]@]" + (list (expression (under_semi ctxt)) ~sep:";@;") xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> + longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c; + | Pexp_pack me -> + pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, cto1, ct) -> + pp f "(%a%a :> %a)" (expression ctxt) e + (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) + (core_type ctxt) ct + | Pexp_variant (l, None) -> pp f "`%a" ident_of_name l + | Pexp_record (l, eo) -> + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l + | Pexp_array (l) -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") l + | Pexp_while (e1, e2) -> + let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt:(_,_,_)format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag + df expression e2 expression e3 + | _ -> paren true (expression ctxt) f x + +and attributes ctxt f l = + List.iter (attribute ctxt f) l + +and item_attributes ctxt f l = + List.iter (item_attribute ctxt f) l + +and attribute ctxt f a = + pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and item_attribute ctxt f a = + pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and floating_attribute ctxt f a = + pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + if x.pval_prim <> [] + then pp f "@ =@ %a" (list constant_string) x.pval_prim + ) x + +and extension ctxt f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e + +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e + +and exception_declaration ctxt f x = + pp f "@[exception@ %a@]%a" + (extension_constructor ctxt) x.ptyexn_constructor + (item_attributes ctxt) x.ptyexn_attributes + +and class_type_field ctxt f x = + match x.pctf_desc with + | Pctf_inherit (ct) -> + pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_val (s, mf, vf, ct) -> + pp f "@[<2>val @ %a%a%a@ :@ %a@]%a" + mutable_flag mf virtual_flag vf + ident_of_name s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%a :@;%a@]%a" + private_flag pf virtual_flag vf + ident_of_name s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_constraint (ct1, ct2) -> + pp f "@[<2>constraint@ %a@ =@ %a@]%a" + (core_type ctxt) ct1 (core_type ctxt) ct2 + (item_attributes ctxt) x.pctf_attributes + | Pctf_attribute a -> floating_attribute ctxt f a + | Pctf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pctf_attributes + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" + (fun f -> function + {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () + | ct -> pp f " (%a)" (core_type ctxt) ct) ct + (list (class_type_field ctxt) ~sep:"@;") l + +(* call [class_signature] called by [class_signature] *) +and class_type ctxt f x = + match x.pcty_desc with + | Pcty_signature cs -> + class_signature ctxt f cs; + attributes ctxt f x.pcty_attributes + | Pcty_constr (li, l) -> + pp f "%a%a%a" + (fun f l -> match l with + | [] -> () + | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l + longident_loc li + (attributes ctxt) x.pcty_attributes + | Pcty_arrow (l, co, cl) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,co) + (class_type ctxt) cl + | Pcty_extension e -> + extension ctxt f e; + attributes ctxt f x.pcty_attributes + | Pcty_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) longident_loc o.popen_expr + (class_type ctxt) e + +(* [class type a = object end] *) +and class_type_declaration_list ctxt f l = + let class_type_declaration kwd f x = + let { pci_params=ls; pci_name={ txt; _ }; _ } = x in + pp f "@[<2>%s %a%a%a@ =@ %a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls + ident_of_name txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_type_declaration "class type") x + (list ~sep:"@," (class_type_declaration "and")) xs + +and class_field ctxt f x = + match x.pcf_desc with + | Pcf_inherit (ovf, ce, so) -> + pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) + (class_expr ctxt) ce + (fun f so -> match so with + | None -> (); + | Some (s) -> pp f "@ as %a" ident_of_name s.txt ) so + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%a =@;%a@]%a" (override ovf) + mutable_flag mf + ident_of_name s.txt + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %a :@;%a@]%a" + private_flag pf + ident_of_name s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_virtual ct) -> + pp f "@[<2>val virtual %a%a :@ %a@]%a" + mutable_flag mf + ident_of_name s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let bind e = + binding ctxt f + {pvb_pat= + {ppat_desc=Ppat_var s; + ppat_loc=Location.none; + ppat_loc_stack=[]; + ppat_attributes=[]}; + pvb_expr=e; + pvb_constraint=None; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" + (override ovf) + private_flag pf + (fun f -> function + | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> + pp f "%a :@;%a=@;%a" + ident_of_name s.txt (core_type ctxt) ct (expression ctxt) e + | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> + bind e + | _ -> bind e) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_constraint (ct1, ct2) -> + pp f "@[<2>constraint %a =@;%a@]%a" + (core_type ctxt) ct1 + (core_type ctxt) ct2 + (item_attributes ctxt) x.pcf_attributes + | Pcf_initializer (e) -> + pp f "@[<2>initializer@ %a@]%a" + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_attribute a -> floating_attribute ctxt f a + | Pcf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pcf_attributes + +and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = + pp f "@[@[object%a@;%a@]@;end@]" + (fun f p -> match p.ppat_desc with + | Ppat_any -> () + | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p + | _ -> pp f " (%a)" (pattern ctxt) p) p + (list (class_field ctxt)) l + +and class_expr ctxt f x = + if x.pcl_attributes <> [] then begin + pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]} + (attributes ctxt) x.pcl_attributes + end else + match x.pcl_desc with + | Pcl_structure (cs) -> class_structure ctxt f cs + | Pcl_fun (l, eo, p, e) -> + pp f "fun@ %a@ ->@ %a" + (label_exp ctxt) (l,eo,p) + (class_expr ctxt) e + | Pcl_let (rf, l, ce) -> + pp f "%a@ in@ %a" + (bindings ctxt) (rf,l) + (class_expr ctxt) ce + | Pcl_apply (ce, l) -> + pp f "((%a)@ %a)" (* Cf: #7200 *) + (class_expr ctxt) ce + (list (label_x_expression_param ctxt)) l + | Pcl_constr (li, l) -> + pp f "%a%a" + (fun f l-> if l <>[] then + pp f "[%a]@ " + (list (core_type ctxt) ~sep:",") l) l + longident_loc li + | Pcl_constraint (ce, ct) -> + pp f "(%a@ :@ %a)" + (class_expr ctxt) ce + (class_type ctxt) ct + | Pcl_extension e -> extension ctxt f e + | Pcl_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) longident_loc o.popen_expr + (class_expr ctxt) e + +and module_type ctxt f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} + (attributes ctxt) x.pmty_attributes + end else + match x.pmty_desc with + | Pmty_functor (Unit, mt2) -> + pp f "@[() ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (Named (s, mt1), mt2) -> + begin match s.txt with + | None -> + pp f "@[%a@ ->@ %a@]" + (module_type1 ctxt) mt1 (module_type ctxt) mt2 + | Some name -> + pp f "@[(%s@ :@ %a)@ ->@ %a@]" name + (module_type ctxt) mt1 (module_type ctxt) mt2 + end + | Pmty_with (mt, []) -> module_type ctxt f mt + | Pmty_with (mt, l) -> + pp f "@[%a@ with@ %a@]" + (module_type1 ctxt) mt + (list (with_constraint ctxt) ~sep:"@ and@ ") l + | _ -> module_type1 ctxt f x + +and with_constraint ctxt f = function + | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> + pp f "type@ %a %a =@ %a" + (type_params ctxt) ls + longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2; + | Pwith_modtype (li, mty) -> + pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty; + | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> + pp f "type@ %a %a :=@ %a" + (type_params ctxt) ls + longident_loc li + (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 + | Pwith_modtypesubst (li, mty) -> + pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty; + + +and module_type1 ctxt f x = + if x.pmty_attributes <> [] then module_type ctxt f x + else match x.pmty_desc with + | Pmty_ident li -> + pp f "%a" longident_loc li; + | Pmty_alias li -> + pp f "(module %a)" longident_loc li; + | Pmty_signature (s) -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e + | _ -> paren true (module_type ctxt) f x + +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x + +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> + type_def_list ctxt f (rf, true, l) + | Psig_typesubst l -> + (* Psig_typesubst is never recursive, but we specify [Recursive] here to + avoid printing a [nonrec] flag, which would be rejected by the parser. + *) + type_def_list ctxt f (Recursive, false, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + ident_of_name vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> + type_extension ctxt f te + | Psig_exception ed -> + exception_declaration ctxt f ed + | Psig_class l -> + let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = + pp f "@[<2>%s %a%a%a@;:@;%a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls + ident_of_name txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_description "class" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_description "class") x + (list ~sep:"@," (class_description "and")) xs + end + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; + pmty_attributes=[]; _};_} as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" + (Option.value pmd.pmd_name.txt ~default:"_") + longident_loc alias + (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" + (Option.value pmd.pmd_name.txt ~default:"_") + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + | Psig_modsubst pms -> + pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt + longident_loc pms.pms_manifest + (item_attributes ctxt) pms.pms_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_expr + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" + (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Psig_modtypesubst {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + let md = match md with + | None -> assert false (* ast invariant *) + | Some mt -> mt in + pp f "@[module@ type@ %s@ :=@ %a@]%a" + s.txt (module_type ctxt) md + (item_attributes ctxt) attrs + | Psig_class_type (l) -> class_type_declaration_list ctxt f l + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first=true) l = + match l with + | [] -> () ; + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" + (Option.value pmd.pmd_name.txt ~default:"_") + (module_type1 ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" + (Option.value pmd.pmd_name.txt ~default:"_") + (module_type1 ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} + (attributes ctxt) x.pmod_attributes + else match x.pmod_desc with + | Pmod_structure (s) -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" + (module_expr ctxt) me + (module_type ctxt) mt + | Pmod_ident (li) -> + pp f "%a" longident_loc li; + | Pmod_functor (Unit, me) -> + pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (Named (s, mt), me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" + (Option.value s.txt ~default:"_") + (module_type ctxt) mt (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_apply_unit me1 -> + pp f "(%a)()" (module_expr ctxt) me1 + | Pmod_unpack e -> + pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension e -> extension ctxt f e + +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + +and payload ctxt f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> pp f ":@ "; core_type ctxt f x + | PSig x -> pp f ":@ "; signature ctxt f x + | PPat (x, None) -> pp f "?@ "; pattern ctxt f x + | PPat (x, Some e) -> + pp f "?@ "; pattern ctxt f x; + pp f " when "; expression ctxt f e + +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else match x.pexp_desc with + | Pexp_function (params, c, body) -> + function_params_then_body ctxt f params c body ~delimiter:"=" + | Pexp_newtype (str,e) -> + pp f "(type@ %a)@ %a" ident_of_name str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + match ct with + | Some (Pvc_constraint { locally_abstract_univars = []; typ }) -> + pp f "%a@;:@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_constraint { locally_abstract_univars = vars; typ }) -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (List.map (fun x -> x.txt) vars) + (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_coercion {ground=None; coercion }) -> + pp f "%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) coercion (expression ctxt) x + | Some (Pvc_coercion {ground=Some ground; coercion }) -> + pp f "%a@;:%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p + (core_type ctxt) ground + (core_type ctxt) coercion + (expression ctxt) x + | None -> begin + match p with + | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + end + +(* [in] is not printed *) +and bindings ctxt f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf + (binding ctxt) x (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [x] -> binding "let" rf f x + | x::xs -> + pp f "@[%a@,%a@]" + (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) xs + +and binding_op ctxt f x = + match x.pbop_pat, x.pbop_exp with + | {ppat_desc = Ppat_var { txt=pvar; _ }; ppat_attributes = []; _}, + {pexp_desc = Pexp_ident { txt=Lident evar; _}; pexp_attributes = []; _} + when pvar = evar -> + pp f "@[<2>%s %s@]" x.pbop_op.txt evar + | pat, exp -> + pp f "@[<2>%s %a@;=@;%a@]" + x.pbop_op.txt (pattern ctxt) pat (expression ctxt) exp + +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf,l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} -> + begin match arg_opt with + | Unit -> pp f "()" + | Named (s, mt) -> + pp f "(%s:%a)" (Option.value s.txt ~default:"_") + (module_type ctxt) mt + end; + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" + (Option.value x.pmb_name.txt ~default:"_") + (fun f me -> + let me = module_helper me in + match me with + | {pmod_desc= + Pmod_constraint + (me', + ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_));_} as mt)); + pmod_attributes = []} -> + pp f " :@;%a@;=@;%a@;" + (module_type ctxt) mt (module_expr ctxt) me' + | _ -> pp f " =@ %a" (module_expr ctxt) me + ) x.pmb_expr + (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + (module_expr ctxt) od.popen_expr + (item_attributes ctxt) od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Pstr_class l -> + let extract_class_args cl = + let rec loop acc = function + | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} -> + loop ((l,eo,p) :: acc) cl' + | cl -> List.rev acc, cl + in + let args, cl = loop [] cl in + let constr, cl = + match cl with + | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} -> + Some ct, cl' + | _ -> None, cl + in + args, constr, cl + in + let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in + let class_declaration kwd f + ({pci_params=ls; pci_name={txt;_}; _} as x) = + let args, constr, cl = extract_class_args x.pci_expr in + pp f "@[<2>%s %a%a%a %a%a=@;%a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls + ident_of_name txt + (list (label_exp ctxt)) args + (option class_constraint) constr + (class_expr ctxt) cl + (item_attributes ctxt) x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_declaration "class" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_declaration "class") x + (list ~sep:"@," (class_declaration "and")) xs + end + | Pstr_class_type l -> class_type_declaration_list ctxt f l + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" + ident_of_name vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" + (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> (* 3.07 *) + let aux f = function + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" + (Option.value pmb.pmb_name.txt ~default:"_") + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + | pmb -> + pp f "@[@ and@ %s@ =@ %a@]%a" + (Option.value pmb.pmb_name.txt ~default:"_") + (module_expr ctxt) pmb.pmb_expr + (item_attributes ctxt) pmb.pmb_attributes + in + begin match decls with + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + (Option.value pmb.pmb_name.txt ~default:"_") + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | pmb :: l2 -> + pp f "@[@[module@ rec@ %s@ =@ %a@]%a@ %a@]" + (Option.value pmb.pmb_name.txt ~default:"_") + (module_expr ctxt) pmb.pmb_expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | _ -> assert false + end + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, (a,b)) = + pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, exported, l) = + let type_decl kwd rf f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else if exported then " =" + else " :=" + in + pp f "@[<2>%s %a%a%a%s%a@]%a" kwd + nonrec_flag rf + (type_params ctxt) x.ptype_params + ident_of_name x.ptype_name.txt + eq + (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [x] -> type_decl "type" rf f x + | x :: xs -> pp f "@[%a@,%a@]" + (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%a:@;%a@;%a@]" + mutable_flag pld.pld_mutable + ident_of_name pld.pld_name.txt + (core_type ctxt) pld.pld_type + (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" + (list type_record_field ~sep:";@\n" ) lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with + | Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else + pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_vars, + pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with + | Ptype_variant xs -> + let variants fmt xs = + if xs = [] then pp fmt " |" else + pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs + in pp f "%t%t%a" intro priv variants xs + | Ptype_abstract -> () + | Ptype_record l -> + pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1,ct2,_) -> + pp f "@[@ constraint@ %a@ =@ %a@]" + (core_type ctxt) ct1 (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params + longident_loc x.ptyext_path + private_flag x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors + (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, vars, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + let pp_vars f vs = + match vs with + | [] -> () + | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l + ) args + (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a%a@;%a" name + pp_vars vars + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") l + (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r + ) + args + (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl(v, l, r) -> + constructor_declaration ctxt f + (x.pext_name.txt, v, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s@;=@;%a%a" x.pext_name.txt + longident_loc li + (attributes ctxt) x.pext_attributes + +and case_list ctxt f l : unit = + let aux f {pc_lhs; pc_guard; pc_rhs} = + pp f "@;| @[<2>%a%a@;->@;%a@]" + (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") + pc_guard (expression (under_pipe ctxt)) pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l,e) = + let simple_name = match e with + | {pexp_desc=Pexp_ident {txt=Lident l;_}; + pexp_attributes=[]} -> Some l + | _ -> None + in match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional str -> + if Some str = simple_name then + pp f "?%a" ident_of_name str + else + pp f "?%a:%a" ident_of_name str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then + pp f "~%a" ident_of_name lbl + else + pp f "~%a:%a" ident_of_name lbl (simple_expr ctxt) e + +and directive_argument f x = + match x.pdira_desc with + | Pdir_string (s) -> pp f "@ %S" s + | Pdir_int (n, None) -> pp f "@ %s" n + | Pdir_int (n, Some m) -> pp f "@ %s%c" n m + | Pdir_ident (li) -> pp f "@ %a" longident li + | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) + +let toplevel_phrase f x = + match x with + | Ptop_def (s) ->pp f "@[%a@]" (list (structure_item reset_ctxt)) s + (* pp_open_hvbox f 0; *) + (* pp_print_list structure_item f s ; *) + (* pp_close_box f (); *) + | Ptop_dir {pdir_name; pdir_arg = None; _} -> + pp f "@[#%s@]" pdir_name.txt + | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> + pp f "@[#%s@ %a@]" pdir_name.txt directive_argument pdir_arg + +let expression f x = + pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()) ; + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + +let top_phrase f x = + pp_print_newline f (); + toplevel_phrase f x; + pp f ";;"; + pp_print_newline f () + +let core_type = core_type reset_ctxt +let pattern = pattern reset_ctxt +let signature = signature reset_ctxt +let structure = structure reset_ctxt +let module_expr = module_expr reset_ctxt +let module_type = module_type reset_ctxt +let class_field = class_field reset_ctxt +let class_type_field = class_type_field reset_ctxt +let class_expr = class_expr reset_ctxt +let class_type = class_type reset_ctxt +let structure_item = structure_item reset_ctxt +let signature_item = signature_item reset_ctxt +let binding = binding reset_ctxt +let payload = payload reset_ctxt diff --git a/upstream/ocaml_503/parsing/pprintast.mli b/upstream/ocaml_503/parsing/pprintast.mli new file mode 100644 index 000000000..b00bfe886 --- /dev/null +++ b/upstream/ocaml_503/parsing/pprintast.mli @@ -0,0 +1,71 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Hongbo Zhang (University of Pennsylvania) *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +(** Pretty-printers for {!Parsetree} + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type space_formatter = (unit, Format.formatter, unit) format + +val longident : Format.formatter -> Longident.t -> unit +val expression : Format.formatter -> Parsetree.expression -> unit +val string_of_expression : Parsetree.expression -> string + +val pattern: Format.formatter -> Parsetree.pattern -> unit + +val core_type: Format.formatter -> Parsetree.core_type -> unit + +val signature: Format.formatter -> Parsetree.signature -> unit +val structure: Format.formatter -> Parsetree.structure -> unit +val string_of_structure: Parsetree.structure -> string + +val module_expr: Format.formatter -> Parsetree.module_expr -> unit + +val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit +val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit + +val class_field: Format.formatter -> Parsetree.class_field -> unit +val class_type_field: Format.formatter -> Parsetree.class_type_field -> unit +val class_expr: Format.formatter -> Parsetree.class_expr -> unit +val class_type: Format.formatter -> Parsetree.class_type -> unit +val module_type: Format.formatter -> Parsetree.module_type -> unit +val structure_item: Format.formatter -> Parsetree.structure_item -> unit +val signature_item: Format.formatter -> Parsetree.signature_item -> unit +val binding: Format.formatter -> Parsetree.value_binding -> unit +val payload: Format.formatter -> Parsetree.payload -> unit + +val tyvar_of_name : string -> string + (** Turn a type variable name into a valid identifier, taking care of the + special treatment required for the single quote character in second + position, or for keywords by escaping them with \#. No-op on "_". *) + +val tyvar: Format.formatter -> string -> unit + (** Print a type variable name as a valid identifier, taking care of the + special treatment required for the single quote character in second + position, or for keywords by escaping them with \#. No-op on "_". *) + +(** {!Format_doc} functions for error messages *) +module Doc:sig + val longident: Longident.t Format_doc.printer + val tyvar: string Format_doc.printer + + (** Returns a format document if the expression reads nicely as the subject + of a sentence in a error message. *) + val nominal_exp : Parsetree.expression -> Format_doc.t option +end diff --git a/upstream/ocaml_503/parsing/printast.ml b/upstream/ocaml_503/parsing/printast.ml new file mode 100644 index 000000000..17f28836a --- /dev/null +++ b/upstream/ocaml_503/parsing/printast.ml @@ -0,0 +1,1023 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Format +open Lexing +open Location +open Parsetree + +let fmt_position with_name f l = + let fname = if with_name then l.pos_fname else "" in + if l.pos_lnum = -1 + then fprintf f "%s[%d]" fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) + +let fmt_location f loc = + if not !Clflags.locations then () + else begin + let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in + fprintf f "(%a..%a)" (fmt_position true) loc.loc_start + (fmt_position p_2nd_name) loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; + end + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x + +let fmt_longident_loc f (x : Longident.t loc) = + fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc + +let fmt_string_loc f (x : string loc) = + fprintf f "\"%s\" %a" x.txt fmt_location x.loc + +let fmt_str_opt_loc f (x : string option loc) = + fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc + +let fmt_char_option f = function + | None -> fprintf f "None" + | Some c -> fprintf f "Some %c" c + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable" + | Mutable -> fprintf f "Mutable" + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual" + | Concrete -> fprintf f "Concrete" + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" + +let fmt_closed_flag f x = + match x with + | Closed -> fprintf f "Closed" + | Open -> fprintf f "Open" + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec" + | Recursive -> fprintf f "Rec" + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up" + | Downto -> fprintf f "Down" + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public" + | Private -> fprintf f "Private" + +let line i f s (*...*) = + fprintf f "%s" (String.make ((2*i) mod 72) ' '); + fprintf f s (*...*) + +let fmt_constant i f x = + line i f "constant %a\n" fmt_location x.pconst_loc; + let i = i+1 in + match x.pconst_desc with + | Pconst_integer (j,m) -> line i f "PConst_int (%s,%a)\n" j fmt_char_option m + | Pconst_char c -> line i f "PConst_char %02x\n" (Char.code c) + | Pconst_string (s, strloc, None) -> + line i f "PConst_string(%S,%a,None)\n" s fmt_location strloc + | Pconst_string (s, strloc, Some delim) -> + line i f "PConst_string (%S,%a,Some %S)\n" s fmt_location strloc delim + | Pconst_float (s,m) -> line i f "PConst_float (%s,%a)\n" s fmt_char_option m + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n" + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n" + +let option i f ppf x = + match x with + | None -> line i ppf "None\n" + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x + +let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li +let string i ppf s = line i ppf "\"%s\"\n" s +let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s +let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional s -> line i ppf "Optional \"%s\"\n" s + | Labelled s -> line i ppf "Labelled \"%s\"\n" s + +let typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ptyp_loc; + attributes i ppf x.ptyp_attributes; + let i = i+1 in + match x.ptyp_desc with + | Ptyp_any -> line i ppf "Ptyp_any\n"; + | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ptyp_arrow (l, ct1, ct2) -> + line i ppf "Ptyp_arrow\n"; + arg_label i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ptyp_tuple l -> + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l; + | Ptyp_constr (li, l) -> + line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Ptyp_variant (l, closed, low) -> + line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ptyp_object (l, c) -> + line i ppf "Ptyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter (fun field -> + match field.pof_desc with + | Otag (l, t) -> + line i ppf "method %s\n" l.txt; + attributes i ppf field.pof_attributes; + core_type (i + 1) ppf t + | Oinherit ct -> + line i ppf "Oinherit\n"; + core_type (i + 1) ppf ct + ) l + | Ptyp_class (li, l) -> + line i ppf "Ptyp_class %a\n" fmt_longident_loc li; + list i core_type ppf l + | Ptyp_alias (ct, s) -> + line i ppf "Ptyp_alias \"%s\"\n" s.txt; + core_type i ppf ct; + | Ptyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" typevars sl; + core_type i ppf ct; + | Ptyp_package (s, l) -> + line i ppf "Ptyp_package %a\n" fmt_longident_loc s; + list i package_with ppf l; + | Ptyp_open (mod_ident, t) -> + line i ppf "Ptyp_open \"%a\"\n" fmt_longident_loc mod_ident; + core_type i ppf t + | Ptyp_extension (s, arg) -> + line i ppf "Ptyp_extension \"%s\"\n" s.txt; + payload i ppf arg + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident_loc s; + core_type i ppf t + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.ppat_loc; + attributes i ppf x.ppat_attributes; + let i = i+1 in + match x.ppat_desc with + | Ppat_any -> line i ppf "Ppat_any\n"; + | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; + | Ppat_alias (p, s) -> + line i ppf "Ppat_alias %a\n" fmt_string_loc s; + pattern i ppf p; + | Ppat_constant (c) -> + line i ppf "Ppat_constant\n"; + fmt_constant i ppf c; + | Ppat_interval (c1, c2) -> + line i ppf "Ppat_interval\n"; + fmt_constant i ppf c1; + fmt_constant i ppf c2; + | Ppat_tuple (l) -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l; + | Ppat_construct (li, po) -> + line i ppf "Ppat_construct %a\n" fmt_longident_loc li; + option i + (fun i ppf (vl, p) -> + list i string_loc ppf vl; + pattern i ppf p) + ppf po + | Ppat_variant (l, po) -> + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po; + | Ppat_record (l, c) -> + line i ppf "Ppat_record %a\n" fmt_closed_flag c; + list i longident_x_pattern ppf l; + | Ppat_array (l) -> + line i ppf "Ppat_array\n"; + list i pattern ppf l; + | Ppat_or (p1, p2) -> + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + | Ppat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; + | Ppat_constraint (p, ct) -> + line i ppf "Ppat_constraint\n"; + pattern i ppf p; + core_type i ppf ct; + | Ppat_type (li) -> + line i ppf "Ppat_type\n"; + longident_loc i ppf li + | Ppat_unpack s -> + line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s; + | Ppat_exception p -> + line i ppf "Ppat_exception\n"; + pattern i ppf p + | Ppat_effect(p1, p2) -> + line i ppf "Ppat_effect\n"; + pattern i ppf p1; + pattern i ppf p2 + | Ppat_open (m,p) -> + line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; + pattern i ppf p + | Ppat_extension (s, arg) -> + line i ppf "Ppat_extension \"%s\"\n" s.txt; + payload i ppf arg + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.pexp_loc; + attributes i ppf x.pexp_attributes; + let i = i+1 in + match x.pexp_desc with + | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; + | Pexp_constant (c) -> + line i ppf "Pexp_constant\n"; + fmt_constant i ppf c; + | Pexp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e; + | Pexp_function (params, c, body) -> + line i ppf "Pexp_function\n"; + list i function_param ppf params; + option i type_constraint ppf c; + function_body i ppf body + | Pexp_apply (e, l) -> + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Pexp_match (e, l) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i case ppf l; + | Pexp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; + list i case ppf l; + | Pexp_tuple (l) -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l; + | Pexp_construct (li, eo) -> + line i ppf "Pexp_construct %a\n" fmt_longident_loc li; + option i expression ppf eo; + | Pexp_variant (l, eo) -> + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo; + | Pexp_record (l, eo) -> + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; + | Pexp_field (e, li) -> + line i ppf "Pexp_field\n"; + expression i ppf e; + longident_loc i ppf li; + | Pexp_setfield (e1, li, e2) -> + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + longident_loc i ppf li; + expression i ppf e2; + | Pexp_array (l) -> + line i ppf "Pexp_array\n"; + list i expression ppf l; + | Pexp_ifthenelse (e1, e2, eo) -> + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Pexp_sequence (e1, e2) -> + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_while (e1, e2) -> + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_for (p, e1, e2, df, e3) -> + line i ppf "Pexp_for %a\n" fmt_direction_flag df; + pattern i ppf p; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Pexp_constraint (e, ct) -> + line i ppf "Pexp_constraint\n"; + expression i ppf e; + core_type i ppf ct; + | Pexp_coerce (e, cto1, cto2) -> + line i ppf "Pexp_coerce\n"; + expression i ppf e; + option i core_type ppf cto1; + core_type i ppf cto2; + | Pexp_send (e, s) -> + line i ppf "Pexp_send \"%s\"\n" s.txt; + expression i ppf e; + | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; + | Pexp_setinstvar (s, e) -> + line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; + expression i ppf e; + | Pexp_override (l) -> + line i ppf "Pexp_override\n"; + list i string_x_expression ppf l; + | Pexp_letmodule (s, me, e) -> + line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s; + module_expr i ppf me; + expression i ppf e; + | Pexp_letexception (cd, e) -> + line i ppf "Pexp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e; + | Pexp_assert (e) -> + line i ppf "Pexp_assert\n"; + expression i ppf e; + | Pexp_lazy (e) -> + line i ppf "Pexp_lazy\n"; + expression i ppf e; + | Pexp_poly (e, cto) -> + line i ppf "Pexp_poly\n"; + expression i ppf e; + option i core_type ppf cto; + | Pexp_object s -> + line i ppf "Pexp_object\n"; + class_structure i ppf s + | Pexp_newtype (s, e) -> + line i ppf "Pexp_newtype \"%s\"\n" s.txt; + expression i ppf e + | Pexp_pack me -> + line i ppf "Pexp_pack\n"; + module_expr i ppf me + | Pexp_open (o, e) -> + line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override; + module_expr i ppf o.popen_expr; + expression i ppf e + | Pexp_letop {let_; ands; body} -> + line i ppf "Pexp_letop\n"; + binding_op i ppf let_; + list i binding_op ppf ands; + expression i ppf body + | Pexp_extension (s, arg) -> + line i ppf "Pexp_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pexp_unreachable -> + line i ppf "Pexp_unreachable" + +and function_param i ppf { pparam_desc = desc; pparam_loc = loc } = + match desc with + | Pparam_val (l, eo, p) -> + line i ppf "Pparam_val %a\n" fmt_location loc; + arg_label (i+1) ppf l; + option (i+1) expression ppf eo; + pattern (i+1) ppf p + | Pparam_newtype ty -> + line i ppf "Pparam_newtype \"%s\" %a\n" ty.txt fmt_location loc + +and function_body i ppf body = + match body with + | Pfunction_body e -> + line i ppf "Pfunction_body\n"; + expression (i+1) ppf e + | Pfunction_cases (cases, loc, attrs) -> + line i ppf "Pfunction_cases %a\n" fmt_location loc; + attributes (i+1) ppf attrs; + list (i+1) case ppf cases + +and type_constraint i ppf constraint_ = + match constraint_ with + | Pconstraint ty -> + line i ppf "Pconstraint\n"; + core_type (i+1) ppf ty + | Pcoerce (ty1, ty2) -> + line i ppf "Pcoerce\n"; + option (i+1) core_type ppf ty1; + core_type (i+1) ppf ty2 + +and value_description i ppf x = + line i ppf "value_description %a %a\n" fmt_string_loc + x.pval_name fmt_location x.pval_loc; + attributes i ppf x.pval_attributes; + core_type (i+1) ppf x.pval_type; + list (i+1) string ppf x.pval_prim + +and type_parameter i ppf (x, _variance) = core_type i ppf x + +and type_declaration i ppf x = + line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name + fmt_location x.ptype_loc; + attributes i ppf x.ptype_attributes; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) type_parameter ppf x.ptype_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.ptype_manifest + +and attribute i ppf k a = + line i ppf "%s \"%s\"\n" k a.attr_name.txt; + payload i ppf a.attr_payload; + +and attributes i ppf l = + let i = i + 1 in + List.iter (fun a -> + line i ppf "attribute \"%s\"\n" a.attr_name.txt; + payload (i + 1) ppf a.attr_payload; + ) l; + +and payload i ppf = function + | PStr x -> structure i ppf x + | PSig x -> signature i ppf x + | PTyp x -> core_type i ppf x + | PPat (x, None) -> pattern i ppf x + | PPat (x, Some g) -> + pattern i ppf x; + line i ppf "\n"; + expression (i + 1) ppf g + + +and type_kind i ppf x = + match x with + | Ptype_abstract -> + line i ppf "Ptype_abstract\n" + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; + list (i+1) constructor_decl ppf l; + | Ptype_record l -> + line i ppf "Ptype_record\n"; + list (i+1) label_decl ppf l; + | Ptype_open -> + line i ppf "Ptype_open\n"; + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.ptyext_attributes; + let i = i+1 in + line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; + line i ppf "ptyext_params =\n"; + list (i+1) type_parameter ppf x.ptyext_params; + line i ppf "ptyext_constructors =\n"; + list (i+1) extension_constructor ppf x.ptyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; + +and type_exception i ppf x = + line i ppf "type_exception\n"; + attributes i ppf x.ptyexn_attributes; + let i = i+1 in + line i ppf "ptyext_constructor =\n"; + let i = i+1 in + extension_constructor i ppf x.ptyexn_constructor + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; + attributes i ppf x.pext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.pext_kind; + +and extension_constructor_kind i ppf x = + match x with + Pext_decl(v, a, r) -> + line i ppf "Pext_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + constructor_arguments (i+1) ppf a; + option (i+1) core_type ppf r; + | Pext_rebind li -> + line i ppf "Pext_rebind\n"; + line (i+1) ppf "%a\n" fmt_longident_loc li; + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.pcty_loc; + attributes i ppf x.pcty_attributes; + let i = i+1 in + match x.pcty_desc with + | Pcty_constr (li, l) -> + line i ppf "Pcty_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Pcty_signature (cs) -> + line i ppf "Pcty_signature\n"; + class_signature i ppf cs; + | Pcty_arrow (l, co, cl) -> + line i ppf "Pcty_arrow\n"; + arg_label i ppf l; + core_type i ppf co; + class_type i ppf cl; + | Pcty_extension (s, arg) -> + line i ppf "Pcty_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pcty_open (o, e) -> + line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override + fmt_longident_loc o.popen_expr; + class_type i ppf e + +and class_signature i ppf cs = + line i ppf "class_signature\n"; + core_type (i+1) ppf cs.pcsig_self; + list (i+1) class_type_field ppf cs.pcsig_fields; + +and class_type_field i ppf x = + line i ppf "class_type_field %a\n" fmt_location x.pctf_loc; + let i = i+1 in + attributes i ppf x.pctf_attributes; + match x.pctf_desc with + | Pctf_inherit (ct) -> + line i ppf "Pctf_inherit\n"; + class_type i ppf ct; + | Pctf_val (s, mf, vf, ct) -> + line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Pctf_method (s, pf, vf, ct) -> + line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Pctf_constraint (ct1, ct2) -> + line i ppf "Pctf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pctf_attribute a -> + attribute i ppf "Pctf_attribute" a + | Pctf_extension (s, arg) -> + line i ppf "Pctf_extension \"%s\"\n" s.txt; + payload i ppf arg + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.pcl_loc; + attributes i ppf x.pcl_attributes; + let i = i+1 in + match x.pcl_desc with + | Pcl_constr (li, l) -> + line i ppf "Pcl_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Pcl_structure (cs) -> + line i ppf "Pcl_structure\n"; + class_structure i ppf cs; + | Pcl_fun (l, eo, p, e) -> + line i ppf "Pcl_fun\n"; + arg_label i ppf l; + option i expression ppf eo; + pattern i ppf p; + class_expr i ppf e; + | Pcl_apply (ce, l) -> + line i ppf "Pcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Pcl_let (rf, l, ce) -> + line i ppf "Pcl_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + class_expr i ppf ce; + | Pcl_constraint (ce, ct) -> + line i ppf "Pcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct; + | Pcl_extension (s, arg) -> + line i ppf "Pcl_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pcl_open (o, e) -> + line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override + fmt_longident_loc o.popen_expr; + class_expr i ppf e + +and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = + line i ppf "class_field %a\n" fmt_location x.pcf_loc; + let i = i + 1 in + attributes i ppf x.pcf_attributes; + match x.pcf_desc with + | Pcf_inherit (ovf, ce, so) -> + line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf; + class_expr (i+1) ppf ce; + option (i+1) string_loc ppf so; + | Pcf_val (s, mf, k) -> + line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; + line (i+1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i+1) ppf k + | Pcf_method (s, pf, k) -> + line i ppf "Pcf_method %a\n" fmt_private_flag pf; + line (i+1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i+1) ppf k + | Pcf_constraint (ct1, ct2) -> + line i ppf "Pcf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pcf_initializer (e) -> + line i ppf "Pcf_initializer\n"; + expression (i+1) ppf e; + | Pcf_attribute a -> + attribute i ppf "Pcf_attribute" a + | Pcf_extension (s, arg) -> + line i ppf "Pcf_extension \"%s\"\n" s.txt; + payload i ppf arg + +and class_field_kind i ppf = function + | Cfk_concrete (o, e) -> + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e + | Cfk_virtual t -> + line i ppf "Virtual\n"; + core_type i ppf t + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.pci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.pmty_loc; + attributes i ppf x.pmty_attributes; + let i = i+1 in + match x.pmty_desc with + | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; + | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; + | Pmty_signature (s) -> + line i ppf "Pmty_signature\n"; + signature i ppf s; + | Pmty_functor (Unit, mt2) -> + line i ppf "Pmty_functor ()\n"; + module_type i ppf mt2; + | Pmty_functor (Named (s, mt1), mt2) -> + line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s; + module_type i ppf mt1; + module_type i ppf mt2; + | Pmty_with (mt, l) -> + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i with_constraint ppf l; + | Pmty_typeof m -> + line i ppf "Pmty_typeof\n"; + module_expr i ppf m; + | Pmty_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and signature i ppf x = list i signature_item ppf x + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.psig_loc; + let i = i+1 in + match x.psig_desc with + | Psig_value vd -> + line i ppf "Psig_value\n"; + value_description i ppf vd; + | Psig_type (rf, l) -> + line i ppf "Psig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Psig_typesubst l -> + line i ppf "Psig_typesubst\n"; + list i type_declaration ppf l; + | Psig_typext te -> + line i ppf "Psig_typext\n"; + type_extension i ppf te + | Psig_exception te -> + line i ppf "Psig_exception\n"; + type_exception i ppf te + | Psig_module pmd -> + line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type i ppf pmd.pmd_type + | Psig_modsubst pms -> + line i ppf "Psig_modsubst %a = %a\n" + fmt_string_loc pms.pms_name + fmt_longident_loc pms.pms_manifest; + attributes i ppf pms.pms_attributes; + | Psig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i module_declaration ppf decls; + | Psig_modtype x -> + line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Psig_modtypesubst x -> + line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Psig_open od -> + line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override + fmt_longident_loc od.popen_expr; + attributes i ppf od.popen_attributes + | Psig_include incl -> + line i ppf "Psig_include\n"; + module_type i ppf incl.pincl_mod; + attributes i ppf incl.pincl_attributes + | Psig_class (l) -> + line i ppf "Psig_class\n"; + list i class_description ppf l; + | Psig_class_type (l) -> + line i ppf "Psig_class_type\n"; + list i class_type_declaration ppf l; + | Psig_extension ((s, arg), attrs) -> + line i ppf "Psig_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Psig_attribute a -> + attribute i ppf "Psig_attribute" a + +and modtype_declaration i ppf = function + | None -> line i ppf "#abstract" + | Some mt -> module_type (i+1) ppf mt + +and with_constraint i ppf x = + match x with + | Pwith_type (lid, td) -> + line i ppf "Pwith_type %a\n" fmt_longident_loc lid; + type_declaration (i+1) ppf td; + | Pwith_typesubst (lid, td) -> + line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; + type_declaration (i+1) ppf td; + | Pwith_module (lid1, lid2) -> + line i ppf "Pwith_module %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2; + | Pwith_modsubst (lid1, lid2) -> + line i ppf "Pwith_modsubst %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2; + | Pwith_modtype (lid1, mty) -> + line i ppf "Pwith_modtype %a\n" + fmt_longident_loc lid1; + module_type (i+1) ppf mty + | Pwith_modtypesubst (lid1, mty) -> + line i ppf "Pwith_modtypesubst %a\n" + fmt_longident_loc lid1; + module_type (i+1) ppf mty + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.pmod_loc; + attributes i ppf x.pmod_attributes; + let i = i+1 in + match x.pmod_desc with + | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li; + | Pmod_structure (s) -> + line i ppf "Pmod_structure\n"; + structure i ppf s; + | Pmod_functor (Unit, me) -> + line i ppf "Pmod_functor ()\n"; + module_expr i ppf me; + | Pmod_functor (Named (s, mt), me) -> + line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s; + module_type i ppf mt; + module_expr i ppf me; + | Pmod_apply (me1, me2) -> + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Pmod_apply_unit me1 -> + line i ppf "Pmod_apply_unit\n"; + module_expr i ppf me1 + | Pmod_constraint (me, mt) -> + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Pmod_unpack (e) -> + line i ppf "Pmod_unpack\n"; + expression i ppf e; + | Pmod_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and structure i ppf x = list i structure_item ppf x + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.pstr_loc; + let i = i+1 in + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + line i ppf "Pstr_eval\n"; + attributes i ppf attrs; + expression i ppf e; + | Pstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + | Pstr_primitive vd -> + line i ppf "Pstr_primitive\n"; + value_description i ppf vd; + | Pstr_type (rf, l) -> + line i ppf "Pstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Pstr_typext te -> + line i ppf "Pstr_typext\n"; + type_extension i ppf te + | Pstr_exception te -> + line i ppf "Pstr_exception\n"; + type_exception i ppf te + | Pstr_module x -> + line i ppf "Pstr_module\n"; + module_binding i ppf x + | Pstr_recmodule bindings -> + line i ppf "Pstr_recmodule\n"; + list i module_binding ppf bindings; + | Pstr_modtype x -> + line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Pstr_open od -> + line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override; + module_expr i ppf od.popen_expr; + attributes i ppf od.popen_attributes + | Pstr_class (l) -> + line i ppf "Pstr_class\n"; + list i class_declaration ppf l; + | Pstr_class_type (l) -> + line i ppf "Pstr_class_type\n"; + list i class_type_declaration ppf l; + | Pstr_include incl -> + line i ppf "Pstr_include"; + attributes i ppf incl.pincl_attributes; + module_expr i ppf incl.pincl_mod + | Pstr_extension ((s, arg), attrs) -> + line i ppf "Pstr_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Pstr_attribute a -> + attribute i ppf "Pstr_attribute" a + +and module_declaration i ppf pmd = + str_opt_loc i ppf pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type (i+1) ppf pmd.pmd_type; + +and module_binding i ppf x = + str_opt_loc i ppf x.pmb_name; + attributes i ppf x.pmb_attributes; + module_expr (i+1) ppf x.pmb_expr + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf " %a\n" fmt_location l; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + +and constructor_decl i ppf + {pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes} = + line i ppf "%a\n" fmt_location pcd_loc; + line (i+1) ppf "%a\n" fmt_string_loc pcd_name; + if pcd_vars <> [] then line (i+1) ppf "pcd_vars =%a\n" typevars pcd_vars; + attributes i ppf pcd_attributes; + constructor_arguments (i+1) ppf pcd_args; + option (i+1) core_type ppf pcd_res + +and constructor_arguments i ppf = function + | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_record l -> list i label_decl ppf l + +and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= + line i ppf "%a\n" fmt_location pld_loc; + attributes i ppf pld_attributes; + line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; + line (i+1) ppf "%a" fmt_string_loc pld_name; + core_type (i+1) ppf pld_type + +and longident_x_pattern i ppf (li, p) = + line i ppf "%a\n" fmt_longident_loc li; + pattern (i+1) ppf p; + +and case i ppf {pc_lhs; pc_guard; pc_rhs} = + line i ppf "\n"; + pattern (i+1) ppf pc_lhs; + begin match pc_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf pc_rhs; + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i+1) ppf x.pvb_attributes; + pattern (i+1) ppf x.pvb_pat; + Option.iter (value_constraint (i+1) ppf) x.pvb_constraint; + expression (i+1) ppf x.pvb_expr + +and value_constraint i ppf x = + let pp_sep ppf () = Format.fprintf ppf "@ "; in + let pp_newtypes = Format.pp_print_list fmt_string_loc ~pp_sep in + match x with + | Pvc_constraint { locally_abstract_univars = []; typ } -> + core_type i ppf typ + | Pvc_constraint { locally_abstract_univars=newtypes; typ} -> + line i ppf " %a.\n" pp_newtypes newtypes; + core_type i ppf typ + | Pvc_coercion { ground; coercion} -> + line i ppf "\n"; + option i core_type ppf ground; + core_type i ppf coercion; + + +and binding_op i ppf x = + line i ppf " %a %a" + fmt_string_loc x.pbop_op fmt_location x.pbop_loc; + pattern (i+1) ppf x.pbop_pat; + expression (i+1) ppf x.pbop_exp; + +and string_x_expression i ppf (s, e) = + line i ppf " %a\n" fmt_string_loc s; + expression (i+1) ppf e; + +and longident_x_expression i ppf (li, e) = + line i ppf "%a\n" fmt_longident_loc li; + expression (i+1) ppf e; + +and label_x_expression i ppf (l,e) = + line i ppf "\n"; + arg_label i ppf l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x.prf_desc with + Rtag (l, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i+1) ppf x.prf_attributes; + list (i+1) core_type ppf ctl + | Rinherit (ct) -> + line i ppf "Rinherit\n"; + core_type (i+1) ppf ct + +let rec toplevel_phrase i ppf x = + match x with + | Ptop_def (s) -> + line i ppf "Ptop_def\n"; + structure (i+1) ppf s; + | Ptop_dir {pdir_name; pdir_arg; _} -> + line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt; + match pdir_arg with + | None -> () + | Some da -> directive_argument i ppf da; + +and directive_argument i ppf x = + match x.pdira_desc with + | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s + | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n + | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m + | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li + | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b) + +let interface ppf x = list 0 signature_item ppf x + +let implementation ppf x = list 0 structure_item ppf x + +let top_phrase ppf x = toplevel_phrase 0 ppf x diff --git a/upstream/ocaml_503/parsing/printast.mli b/upstream/ocaml_503/parsing/printast.mli new file mode 100644 index 000000000..5bc496182 --- /dev/null +++ b/upstream/ocaml_503/parsing/printast.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Raw printer for {!Parsetree} + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Parsetree +open Format + +val interface : formatter -> signature_item list -> unit +val implementation : formatter -> structure_item list -> unit +val top_phrase : formatter -> toplevel_phrase -> unit + +val expression: int -> formatter -> expression -> unit +val structure: int -> formatter -> structure -> unit +val payload: int -> formatter -> payload -> unit diff --git a/upstream/ocaml_503/parsing/syntaxerr.ml b/upstream/ocaml_503/parsing/syntaxerr.ml new file mode 100644 index 000000000..8a326c110 --- /dev/null +++ b/upstream/ocaml_503/parsing/syntaxerr.ml @@ -0,0 +1,52 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Auxiliary type for reporting syntax errors *) + +type invalid_package_type = + | Parameterized_types + | Constrained_types + | Private_types + | Not_with_type + | Neither_identifier_nor_with_type + +type error = + Unclosed of Location.t * string * Location.t * string + | Expecting of Location.t * string + | Not_expecting of Location.t * string + | Applicative_path of Location.t + | Variable_in_scope of Location.t * string + | Other of Location.t + | Ill_formed_ast of Location.t * string + | Invalid_package_type of Location.t * invalid_package_type + | Removed_string_set of Location.t + +exception Error of error +exception Escape_error + +let location_of_error = function + | Unclosed(l,_,_,_) + | Applicative_path l + | Variable_in_scope(l,_) + | Other l + | Not_expecting (l, _) + | Ill_formed_ast (l, _) + | Invalid_package_type (l, _) + | Expecting (l, _) + | Removed_string_set l -> l + + +let ill_formed_ast loc s = + raise (Error (Ill_formed_ast (loc, s))) diff --git a/upstream/ocaml_503/parsing/syntaxerr.mli b/upstream/ocaml_503/parsing/syntaxerr.mli new file mode 100644 index 000000000..a84bc6664 --- /dev/null +++ b/upstream/ocaml_503/parsing/syntaxerr.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Auxiliary type for reporting syntax errors + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type invalid_package_type = + | Parameterized_types + | Constrained_types + | Private_types + | Not_with_type + | Neither_identifier_nor_with_type + +type error = + Unclosed of Location.t * string * Location.t * string + | Expecting of Location.t * string + | Not_expecting of Location.t * string + | Applicative_path of Location.t + | Variable_in_scope of Location.t * string + | Other of Location.t + | Ill_formed_ast of Location.t * string + | Invalid_package_type of Location.t * invalid_package_type + | Removed_string_set of Location.t + +exception Error of error +exception Escape_error + +val location_of_error: error -> Location.t +val ill_formed_ast: Location.t -> string -> 'a diff --git a/upstream/ocaml_503/parsing/unit_info.ml b/upstream/ocaml_503/parsing/unit_info.ml new file mode 100644 index 000000000..66ad51b7c --- /dev/null +++ b/upstream/ocaml_503/parsing/unit_info.ml @@ -0,0 +1,141 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type intf_or_impl = Intf | Impl +type modname = string +type filename = string +type file_prefix = string + +type error = Invalid_encoding of string +exception Error of error + +type t = { + source_file: filename; + prefix: file_prefix; + modname: modname; + kind: intf_or_impl; +} + +let source_file (x: t) = x.source_file +let modname (x: t) = x.modname +let kind (x: t) = x.kind +let prefix (x: t) = x.prefix + +let basename_chop_extensions basename = + match String.index basename '.' with + | dot_pos -> String.sub basename 0 dot_pos + | exception Not_found -> basename + +let strict_modulize s = + match Misc.Utf8_lexeme.capitalize s with + | Ok x -> x + | Error _ -> raise (Error (Invalid_encoding s)) + +let modulize s = match Misc.Utf8_lexeme.capitalize s with Ok x | Error x -> x + +(* We re-export the [Misc] definition, and ignore encoding errors under the + assumption that we should focus our effort on not *producing* badly encoded + module names *) +let normalize x = match Misc.normalized_unit_filename x with + | Ok x | Error x -> x + +let stem source_file = + source_file |> Filename.basename |> basename_chop_extensions + +let strict_modname_from_source source_file = + source_file |> stem |> strict_modulize + +let lax_modname_from_source source_file = + source_file |> stem |> modulize + +(* Check validity of module name *) +let is_unit_name name = Misc.Utf8_lexeme.is_valid_identifier name + +let check_unit_name file = + if not (is_unit_name (modname file)) then + Location.prerr_warning (Location.in_file (source_file file)) + (Warnings.Bad_module_name (modname file)) + +let make ?(check_modname=true) ~source_file kind prefix = + let modname = strict_modname_from_source prefix in + let p = { modname; prefix; source_file; kind } in + if check_modname then check_unit_name p; + p + +module Artifact = struct + type t = + { + source_file: filename option; + filename: filename; + modname: modname; + } + let source_file x = x.source_file + let filename x = x.filename + let modname x = x.modname + let prefix x = Filename.remove_extension (filename x) + + let from_filename filename = + let modname = lax_modname_from_source filename in + { modname; filename; source_file = None } + +end + +let mk_artifact ext u = + { + Artifact.filename = u.prefix ^ ext; + modname = u.modname; + source_file = Some u.source_file; + } + +let companion_artifact ext x = + { x with Artifact.filename = Artifact.prefix x ^ ext } + +let cmi f = mk_artifact ".cmi" f +let cmo f = mk_artifact ".cmo" f +let cmx f = mk_artifact ".cmx" f +let obj f = mk_artifact Config.ext_obj f +let cmt f = mk_artifact ".cmt" f +let cmti f = mk_artifact ".cmti" f +let annot f = mk_artifact ".annot" f + +let companion_obj f = companion_artifact Config.ext_obj f +let companion_cmt f = companion_artifact ".cmt" f + +let companion_cmi f = + let prefix = Misc.chop_extensions f.Artifact.filename in + { f with Artifact.filename = prefix ^ ".cmi"} + +let mli_from_artifact f = Artifact.prefix f ^ !Config.interface_suffix +let mli_from_source u = + let prefix = Filename.remove_extension (source_file u) in + prefix ^ !Config.interface_suffix + +let is_cmi f = Filename.check_suffix (Artifact.filename f) ".cmi" + +let find_normalized_cmi f = + let filename = modname f ^ ".cmi" in + let filename = Load_path.find_normalized filename in + { Artifact.filename; modname = modname f; source_file = Some f.source_file } + +let report_error = function + | Invalid_encoding name -> + Location.errorf "Invalid encoding of output name: %s." name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (report_error err) + | _ -> None + ) diff --git a/upstream/ocaml_503/parsing/unit_info.mli b/upstream/ocaml_503/parsing/unit_info.mli new file mode 100644 index 000000000..4117d243c --- /dev/null +++ b/upstream/ocaml_503/parsing/unit_info.mli @@ -0,0 +1,173 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module centralize the handling of compilation files and their metadata. + + Maybe more importantly, this module provides functions for deriving module + names from strings or filenames. +*) + +(** {1:modname_from_strings Module name convention and computation} *) + +type intf_or_impl = Intf | Impl +type modname = string +type filename = string +type file_prefix = string + +type error = Invalid_encoding of filename +exception Error of error + +(** [modulize s] capitalizes the first letter of [s]. *) +val modulize: string -> modname + +(** [normalize s] uncapitalizes the first letter of [s]. *) +val normalize: string -> string + +(** [lax_modname_from_source filename] is [modulize stem] where [stem] is the + basename of the filename [filename] stripped from all its extensions. + For instance, [lax_modname_from_source "/pa.th/x.ml.pp"] is ["X"]. *) +val lax_modname_from_source: filename -> modname + +(** Same as {!lax_modname_from_source} but raises an {!error.Invalid_encoding} + error on filename with invalid utf8 encoding. *) +val strict_modname_from_source: filename -> modname + +(** {2:module_name_validation Module name validation function}*) + +(** [is_unit_name name] is true only if [name] can be used as a + valid module name. *) +val is_unit_name : modname -> bool + + +(** {1:unit_info Metadata for compilation unit} *) + +type t +(** Metadata for a compilation unit: + - the module name associated to the unit + - the filename prefix (dirname + basename with all extensions stripped) + for compilation artifacts + - the input source file + For instance, when calling [ocamlopt dir/x.mli -o target/y.cmi], + - the input source file is [dir/x.mli] + - the module name is [Y] + - the prefix is [target/y] +*) + +(** [source_file u] is the source file of [u]. *) +val source_file: t -> filename + +(** [prefix u] is the filename prefix of the unit. *) +val prefix: t -> file_prefix + +(** [modname u] or [artifact_modname a] is the module name of the unit + or compilation artifact.*) +val modname: t -> modname + +(** [kind u] is the kind (interface or implementation) of the unit. *) +val kind: t -> intf_or_impl + +(** [check_unit_name u] prints a warning if the derived module name [modname u] + should not be used as a module name as specified + by {!is_unit_name}[ ~strict:true]. *) +val check_unit_name : t -> unit + +(** [make ~check ~source_file kind prefix] associates both the + [source_file] and the module name {!lax_modname_from_source}[ target_prefix] + to the prefix filesystem path [prefix]. + + If [check_modname=true], this function emits a warning if the derived module + name is not valid according to {!check_unit_name}. +*) +val make: + ?check_modname:bool -> source_file:filename -> + intf_or_impl -> file_prefix -> t + +(** {1:artifact_function Build artifacts }*) +module Artifact: sig + type t +(** Metadata for a single compilation artifact: + - the module name associated to the artifact + - the filesystem path + - the input source file if it exists +*) + + (** [source_file a] is the source file of [a] if it exists. *) + val source_file: t -> filename option + + (** [prefix a] is the filename prefix of the compilation artifact. *) + val prefix: t -> file_prefix + + (** [filename u] is the filesystem path for a compilation artifact. *) + val filename: t -> filename + + (** [modname a] is the module name of the compilation artifact.*) + val modname: t -> modname + + (** [from_filename filename] reconstructs the module name + [lax_modname_from_source filename] associated to the artifact + [filename]. *) + val from_filename: filename -> t + +end + +(** {1:info_build_artifacts Derived build artifact metadata} *) + +(** Those functions derive a specific [artifact] metadata from an [unit] + metadata.*) +val cmi: t -> Artifact.t +val cmo: t -> Artifact.t +val cmx: t -> Artifact.t +val obj: t -> Artifact.t +val cmt: t -> Artifact.t +val cmti: t -> Artifact.t +val annot: t -> Artifact.t + +(** The functions below change the type of an artifact by updating the + extension of its filename. + Those functions purposefully do not cover all artifact kinds because we want + to track which artifacts are assumed to be bundled together. *) +val companion_obj: Artifact.t -> Artifact.t +val companion_cmt: Artifact.t -> Artifact.t + +val companion_cmi: Artifact.t -> Artifact.t +(** Beware that [companion_cmi a] strips all extensions from the + filename of [a] before adding the [".cmi"] suffix contrarily to + the other functions which only remove the rightmost extension. + In other words, the companion cmi of a file [something.d.cmo] is + [something.cmi] and not [something.d.cmi]. +*) + +(** {1:ml_mli_cmi_interaction Mli and cmi derived from implementation files } *) + +(** The compilation of module implementation changes in presence of mli and cmi + files, the function belows help to handle this. *) + +(** [mli_from_source u] is the interface source filename associated to the unit + [u]. The actual suffix depends on {!Config.interface_suffix}. +*) +val mli_from_source: t -> filename + +(** [mli_from_artifact t] is the name of the interface source file derived from + the artifact [t]. This variant is necessary when handling artifacts derived + from an unknown source files (e.g. packed modules). *) +val mli_from_artifact: Artifact.t -> filename + +(** Check if the artifact is a cmi *) +val is_cmi: Artifact.t -> bool + +(** [find_normalized_cmi u] finds in the load_path a file matching the module + name [modname u]. + @raise Not_found if no such cmi exists *) +val find_normalized_cmi: t -> Artifact.t diff --git a/upstream/ocaml_503/typing/annot.mli b/upstream/ocaml_503/typing/annot.mli new file mode 100644 index 000000000..bbaade5b0 --- /dev/null +++ b/upstream/ocaml_503/typing/annot.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Data types for annotations (Stypes.ml) *) + +type call = Tail | Stack | Inline + +type ident = + | Iref_internal of Location.t (* defining occurrence *) + | Iref_external + | Idef of Location.t (* scope *) diff --git a/upstream/ocaml_503/typing/btype.ml b/upstream/ocaml_503/typing/btype.ml new file mode 100644 index 000000000..be88d9d44 --- /dev/null +++ b/upstream/ocaml_503/typing/btype.ml @@ -0,0 +1,789 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Basic operations on core types *) + +open Asttypes +open Types + +open Local_store + +(**** Sets, maps and hashtables of types ****) + +let wrap_repr f ty = f (Transient_expr.repr ty) +let wrap_type_expr f tty = f (Transient_expr.type_expr tty) + +module TransientTypeSet = Set.Make(TransientTypeOps) +module TypeSet = struct + include TransientTypeSet + let add = wrap_repr add + let mem = wrap_repr mem + let singleton = wrap_repr singleton + let exists p = TransientTypeSet.exists (wrap_type_expr p) + let elements set = + List.map Transient_expr.type_expr (TransientTypeSet.elements set) +end +module TransientTypeMap = Map.Make(TransientTypeOps) +module TypeMap = struct + include TransientTypeMap + let add ty = wrap_repr add ty + let find ty = wrap_repr find ty + let singleton ty = wrap_repr singleton ty + let fold f = TransientTypeMap.fold (wrap_type_expr f) +end +module TypeHash = struct + include TransientTypeHash + let mem hash = wrap_repr (mem hash) + let add hash = wrap_repr (add hash) + let remove hash = wrap_repr (remove hash) + let find hash = wrap_repr (find hash) + let find_opt hash = wrap_repr (find_opt hash) + let iter f = TransientTypeHash.iter (wrap_type_expr f) +end +module TransientTypePairs = + Hashtbl.Make (struct + type t = transient_expr * transient_expr + let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') + let hash (t, t') = t.id + 93 * t'.id + end) +module TypePairs = struct + module H = TransientTypePairs + open Transient_expr + + type t = { + set : unit H.t; + mutable elems : (transient_expr * transient_expr) list; + (* elems preserves the (reversed) insertion order of elements *) + } + + let create n = + { elems = []; set = H.create n } + + let clear t = + t.elems <- []; + H.clear t.set + + let repr2 (t1, t2) = (repr t1, repr t2) + + let add t p = + let p = repr2 p in + if H.mem t.set p then () else begin + H.add t.set p (); + t.elems <- p :: t.elems + end + + let mem t p = H.mem t.set (repr2 p) + + let iter f t = + (* iterate in insertion order, not Hashtbl.iter order *) + List.rev t.elems + |> List.iter (fun (t1,t2) -> + f (type_expr t1, type_expr t2)) +end + +(**** Type level management ****) + +let generic_level = Ident.highest_scope +let lowest_level = Ident.lowest_scope + +(**** leveled type pool ****) +(* This defines a stack of pools of type nodes indexed by the level + we will try to generalize them in [Ctype.with_local_level_gen]. + [pool_of_level] returns the pool in which types at level [level] + should be kept, which is the topmost pool whose level is lower or + equal to [level]. + [Ctype.with_local_level_gen] shall call [with_new_pool] to create + a new pool at a given level. On return it shall process all nodes + that were added to the pool. + Remark: the only function adding to a pool is [add_to_pool], and + the only function returning the contents of a pool is [with_new_pool], + so that the initial pool can be added to, but never read from. *) + +type pool = {level: int; mutable pool: transient_expr list; next: pool} +(* To avoid an indirection we choose to add a dummy level at the end of + the list. It will never be accessed, as [pool_of_level] is always called + with [level >= 0]. *) +let rec dummy = {level = max_int; pool = []; next = dummy} +let pool_stack = s_table (fun () -> {level = 0; pool = []; next = dummy}) () + +(* Lookup in the stack is linear, but the depth is the number of nested + generalization points (e.g. lhs of let-definitions), which in ML is known + to be generally low. In most cases we are allocating in the topmost pool. + In [Ctype.with_local_gen], we move non-generalizable type nodes from the + topmost pool to one deeper in the stack, so that for each type node the + accumulated depth of lookups over its life is bounded by the depth of + the stack when it was allocated. + In case this linear search turns out to be costly, we could switch to + binary search, exploiting the fact that the levels of pools in the stack + are expected to grow. *) +let rec pool_of_level level pool = + if level >= pool.level then pool else pool_of_level level pool.next + +(* Create a new pool at given level, and use it locally. *) +let with_new_pool ~level f = + let pool = {level; pool = []; next = !pool_stack} in + let r = + Misc.protect_refs [ R(pool_stack, pool) ] f + in + (r, pool.pool) + +let add_to_pool ~level ty = + if level >= generic_level || level <= lowest_level then () else + let pool = pool_of_level level !pool_stack in + pool.pool <- ty :: pool.pool + +(**** Some type creators ****) + +let newty3 ~level ~scope desc = + let ty = proto_newty3 ~level ~scope desc in + add_to_pool ~level ty; + Transient_expr.type_expr ty + +let newty2 ~level desc = + newty3 ~level ~scope:Ident.lowest_scope desc + +let newgenty desc = newty2 ~level:generic_level desc +let newgenvar ?name () = newgenty (Tvar name) +let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) + +(**** Check some types ****) + +let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false +let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false +let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false +let is_poly_Tpoly ty = + match get_desc ty with Tpoly (_, _ :: _) -> true | _ -> false +let type_kind_is_abstract decl = + match decl.type_kind with Type_abstract _ -> true | _ -> false +let type_origin decl = + match decl.type_kind with + | Type_abstract origin -> origin + | Type_variant _ | Type_record _ | Type_open -> Definition +let label_is_poly lbl = is_poly_Tpoly lbl.lbl_arg + +let dummy_method = "*dummy method*" + +(**** Representative of a type ****) + +let merge_fixed_explanation fixed1 fixed2 = + match fixed1, fixed2 with + | Some Univar _ as x, _ | _, (Some Univar _ as x) -> x + | Some Fixed_private as x, _ | _, (Some Fixed_private as x) -> x + | Some Reified _ as x, _ | _, (Some Reified _ as x) -> x + | Some Rigid as x, _ | _, (Some Rigid as x) -> x + | None, None -> None + + +let fixed_explanation row = + match row_fixed row with + | Some _ as x -> x + | None -> + let ty = row_more row in + match get_desc ty with + | Tvar _ | Tnil -> None + | Tunivar _ -> Some (Univar ty) + | Tconstr (p,_,_) -> Some (Reified p) + | _ -> assert false + +let is_fixed row = match row_fixed row with + | None -> false + | Some _ -> true + +let has_fixed_explanation row = fixed_explanation row <> None + +let static_row row = + row_closed row && + List.for_all + (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true) + (row_fields row) + +let hash_variant s = + let accu = ref 0 in + for i = 0 to String.length s - 1 do + accu := 223 * !accu + Char.code s.[i] + done; + (* reduce to 31 bits *) + accu := !accu land (1 lsl 31 - 1); + (* make it signed for 64 bits architectures *) + if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu + +let proxy ty = + match get_desc ty with + | Tvariant row when not (static_row row) -> + row_more row + | Tobject (ty, _) -> + let rec proxy_obj ty = + match get_desc ty with + Tfield (_, _, _, ty) -> proxy_obj ty + | Tvar _ | Tunivar _ | Tconstr _ -> ty + | Tnil -> ty + | _ -> assert false + in proxy_obj ty + | _ -> ty + +(**** Utilities for fixed row private types ****) + +let row_of_type t = + match get_desc t with + Tobject(t,_) -> + let rec get_row t = + match get_desc t with + Tfield(_,_,_,t) -> get_row t + | _ -> t + in get_row t + | Tvariant row -> + row_more row + | _ -> + t + +let has_constr_row t = + not (is_Tconstr t) && is_Tconstr (row_of_type t) + +let is_row_name s = + let l = String.length s in + (* PR#10661: when l=4 and s is "#row", this is not a row name + but the valid #-type name of a class named "row". *) + l > 4 && String.sub s (l-4) 4 = "#row" + +let is_constr_row ~allow_ident t = + match get_desc t with + Tconstr (Path.Pident id, _, _) when allow_ident -> + is_row_name (Ident.name id) + | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s + | _ -> false + +(* TODO: where should this really be *) +(* Set row_name in Env, cf. GPR#1204/1329 *) +let set_static_row_name decl path = + match decl.type_manifest with + None -> () + | Some ty -> + match get_desc ty with + Tvariant row when static_row row -> + let row = + set_row_name row (Some (path, decl.type_params)) in + set_type_desc ty (Tvariant row) + | _ -> () + + (**********************************) + (* Utilities for type traversal *) + (**********************************) + +let fold_row f init row = + let result = + List.fold_left + (fun init (_, fi) -> + match row_field_repr fi with + | Rpresent(Some ty) -> f init ty + | Reither(_, tl, _) -> List.fold_left f init tl + | _ -> init) + init + (row_fields row) + in + match get_desc (row_more row) with + | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> + begin match + Option.map (fun (_,l) -> List.fold_left f result l) (row_name row) + with + | None -> result + | Some result -> result + end + | _ -> assert false + +let iter_row f row = + fold_row (fun () v -> f v) () row + +let fold_type_expr f init ty = + match get_desc ty with + Tvar _ -> init + | Tarrow (_, ty1, ty2, _) -> + let result = f init ty1 in + f result ty2 + | Ttuple l -> List.fold_left f init l + | Tconstr (_, l, _) -> List.fold_left f init l + | Tobject(ty, {contents = Some (_, p)}) -> + let result = f init ty in + List.fold_left f result p + | Tobject (ty, _) -> f init ty + | Tvariant row -> + let result = fold_row f init row in + f result (row_more row) + | Tfield (_, _, ty1, ty2) -> + let result = f init ty1 in + f result ty2 + | Tnil -> init + | Tlink _ + | Tsubst _ -> assert false + | Tunivar _ -> init + | Tpoly (ty, tyl) -> + let result = f init ty in + List.fold_left f result tyl + | Tpackage (_, fl) -> + List.fold_left (fun result (_n, ty) -> f result ty) init fl + +let iter_type_expr f ty = + fold_type_expr (fun () v -> f v) () ty + +let rec iter_abbrev f = function + Mnil -> () + | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem + | Mlink rem -> iter_abbrev f !rem + +let iter_type_expr_cstr_args f = function + | Cstr_tuple tl -> List.iter f tl + | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls + +let map_type_expr_cstr_args f = function + | Cstr_tuple tl -> Cstr_tuple (List.map f tl) + | Cstr_record lbls -> + Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls) + +let iter_type_expr_kind f = function + | Type_abstract _ -> () + | Type_variant (cstrs, _) -> + List.iter + (fun cd -> + iter_type_expr_cstr_args f cd.cd_args; + Option.iter f cd.cd_res + ) + cstrs + | Type_record(lbls, _) -> + List.iter (fun d -> f d.ld_type) lbls + | Type_open -> + () + + (**********************************) + (* Utilities for marking *) + (**********************************) + +let rec mark_type mark ty = + if try_mark_node mark ty then iter_type_expr (mark_type mark) ty + +let mark_type_params mark ty = + iter_type_expr (mark_type mark) ty + + (**********************************) + (* (Object-oriented) iterator *) + (**********************************) + +type 'a type_iterators = + { it_signature: 'a type_iterators -> signature -> unit; + it_signature_item: 'a type_iterators -> signature_item -> unit; + it_value_description: 'a type_iterators -> value_description -> unit; + it_type_declaration: 'a type_iterators -> type_declaration -> unit; + it_extension_constructor: + 'a type_iterators -> extension_constructor -> unit; + it_module_declaration: 'a type_iterators -> module_declaration -> unit; + it_modtype_declaration: 'a type_iterators -> modtype_declaration -> unit; + it_class_declaration: 'a type_iterators -> class_declaration -> unit; + it_class_type_declaration: + 'a type_iterators -> class_type_declaration -> unit; + it_functor_param: 'a type_iterators -> functor_parameter -> unit; + it_module_type: 'a type_iterators -> module_type -> unit; + it_class_type: 'a type_iterators -> class_type -> unit; + it_type_kind: 'a type_iterators -> type_decl_kind -> unit; + it_do_type_expr: 'a type_iterators -> 'a; + it_type_expr: 'a type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; } + +type type_iterators_full = (type_expr -> unit) type_iterators +type type_iterators_without_type_expr = (unit -> unit) type_iterators + +let type_iterators_without_type_expr = + let it_signature it = + List.iter (it.it_signature_item it) + and it_signature_item it = function + Sig_value (_, vd, _) -> it.it_value_description it vd + | Sig_type (_, td, _, _) -> it.it_type_declaration it td + | Sig_typext (_, td, _, _) -> it.it_extension_constructor it td + | Sig_module (_, _, md, _, _) -> it.it_module_declaration it md + | Sig_modtype (_, mtd, _) -> it.it_modtype_declaration it mtd + | Sig_class (_, cd, _, _) -> it.it_class_declaration it cd + | Sig_class_type (_, ctd, _, _) -> it.it_class_type_declaration it ctd + and it_value_description it vd = + it.it_type_expr it vd.val_type + and it_type_declaration it td = + List.iter (it.it_type_expr it) td.type_params; + Option.iter (it.it_type_expr it) td.type_manifest; + it.it_type_kind it td.type_kind + and it_extension_constructor it td = + it.it_path td.ext_type_path; + List.iter (it.it_type_expr it) td.ext_type_params; + iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args; + Option.iter (it.it_type_expr it) td.ext_ret_type + and it_module_declaration it md = + it.it_module_type it md.md_type + and it_modtype_declaration it mtd = + Option.iter (it.it_module_type it) mtd.mtd_type + and it_class_declaration it cd = + List.iter (it.it_type_expr it) cd.cty_params; + it.it_class_type it cd.cty_type; + Option.iter (it.it_type_expr it) cd.cty_new; + it.it_path cd.cty_path + and it_class_type_declaration it ctd = + List.iter (it.it_type_expr it) ctd.clty_params; + it.it_class_type it ctd.clty_type; + it.it_path ctd.clty_path + and it_functor_param it = function + | Unit -> () + | Named (_, mt) -> it.it_module_type it mt + and it_module_type it = function + Mty_ident p + | Mty_alias p -> it.it_path p + | Mty_signature sg -> it.it_signature it sg + | Mty_functor (p, mt) -> + it.it_functor_param it p; + it.it_module_type it mt + and it_class_type it = function + Cty_constr (p, tyl, cty) -> + it.it_path p; + List.iter (it.it_type_expr it) tyl; + it.it_class_type it cty + | Cty_signature cs -> + it.it_type_expr it cs.csig_self; + it.it_type_expr it cs.csig_self_row; + Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars; + Meths.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_meths + | Cty_arrow (_, ty, cty) -> + it.it_type_expr it ty; + it.it_class_type it cty + and it_type_kind it kind = + iter_type_expr_kind (it.it_type_expr it) kind + and it_path _p = () + in + { it_path; it_type_expr = (fun _ _ -> ()); it_do_type_expr = (fun _ _ -> ()); + it_type_kind; it_class_type; it_functor_param; it_module_type; + it_signature; it_class_type_declaration; it_class_declaration; + it_modtype_declaration; it_module_declaration; it_extension_constructor; + it_type_declaration; it_value_description; it_signature_item; } + +let type_iterators mark = + let it_type_expr it ty = + if try_mark_node mark ty then it.it_do_type_expr it ty + and it_do_type_expr it ty = + iter_type_expr (it.it_type_expr it) ty; + match get_desc ty with + Tconstr (p, _, _) + | Tobject (_, {contents=Some (p, _)}) + | Tpackage (p, _) -> + it.it_path p + | Tvariant row -> + Option.iter (fun (p,_) -> it.it_path p) (row_name row) + | _ -> () + in + {type_iterators_without_type_expr with it_type_expr; it_do_type_expr} + + (**********************************) + (* Utilities for copying *) + (**********************************) + +let copy_row f fixed row keep more = + let Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} = + row_repr row in + let fields = List.map + (fun (l, fi) -> l, + match row_field_repr fi with + | Rpresent oty -> rf_present (Option.map f oty) + | Reither(c, tl, m) -> + let use_ext_of = if keep then Some fi else None in + let m = if is_fixed row then fixed else m in + let tl = List.map f tl in + rf_either tl ?use_ext_of ~no_arg:c ~matched:m + | Rabsent -> rf_absent) + orig_fields in + let name = + match orig_name with + | None -> None + | Some (path, tl) -> Some (path, List.map f tl) in + let fixed = if fixed then orig_fixed else None in + create_row ~fields ~more ~fixed ~closed ~name + +let copy_commu c = if is_commu_ok c then commu_ok else commu_var () + +let rec copy_type_desc ?(keep_names=false) f = function + Tvar _ as ty -> if keep_names then ty else Tvar None + | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c) + | Ttuple l -> Ttuple (List.map f l) + | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) + | Tobject(ty, {contents = Some (p, tl)}) + -> Tobject (f ty, ref (Some(p, List.map f tl))) + | Tobject (ty, _) -> Tobject (f ty, ref None) + | Tvariant _ -> assert false (* too ambiguous *) + | Tfield (p, k, ty1, ty2) -> + Tfield (p, field_kind_internal_repr k, f ty1, f ty2) + (* the kind is kept shared, with indirections removed for performance *) + | Tnil -> Tnil + | Tlink ty -> copy_type_desc f (get_desc ty) + | Tsubst _ -> assert false + | Tunivar _ as ty -> ty (* always keep the name *) + | Tpoly (ty, tyl) -> + let tyl = List.map f tyl in + Tpoly (f ty, tyl) + | Tpackage (p, fl) -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl) + +(* TODO: rename to [module Copy_scope] *) +module For_copy : sig + type copy_scope + + val redirect_desc: copy_scope -> type_expr -> type_desc -> unit + + val with_scope: (copy_scope -> 'a) -> 'a +end = struct + type copy_scope = { + mutable saved_desc : (transient_expr * type_desc) list; + (* Save association of generic nodes with their description. *) + } + + let redirect_desc copy_scope ty desc = + let ty = Transient_expr.repr ty in + copy_scope.saved_desc <- (ty, ty.desc) :: copy_scope.saved_desc; + Transient_expr.set_desc ty desc + + (* Restore type descriptions. *) + let cleanup { saved_desc; _ } = + List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc + + let with_scope f = + let scope = { saved_desc = [] } in + let res = f scope in + cleanup scope; + res +end + + (*******************************************) + (* Memorization of abbreviation expansion *) + (*******************************************) + +(* Search whether the expansion has been memorized. *) + +let lte_public p1 p2 = (* Private <= Public *) + match p1, p2 with + | Private, _ | _, Public -> true + | Public, Private -> false + +let rec find_expans priv p1 = function + Mnil -> None + | Mcons (priv', p2, _ty0, ty, _) + when lte_public priv priv' && Path.same p1 p2 -> Some ty + | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem + | Mlink {contents = rem} -> find_expans priv p1 rem + +(* debug: check for cycles in abbreviation. only works with -principal +let rec check_expans visited ty = + let ty = repr ty in + assert (not (List.memq ty visited)); + match ty.desc with + Tconstr (path, args, abbrev) -> + begin match find_expans path !abbrev with + Some ty' -> check_expans (ty :: visited) ty' + | None -> () + end + | _ -> () +*) + +let memo = s_ref [] + (* Contains the list of saved abbreviation expansions. *) + +let cleanup_abbrev () = + (* Remove all memorized abbreviation expansions. *) + List.iter (fun abbr -> abbr := Mnil) !memo; + memo := [] + +let memorize_abbrev mem priv path v v' = + (* Memorize the expansion of an abbreviation. *) + mem := Mcons (priv, path, v, v', !mem); + (* check_expans [] v; *) + memo := mem :: !memo + +let rec forget_abbrev_rec mem path = + match mem with + Mnil -> + mem + | Mcons (_, path', _, _, rem) when Path.same path path' -> + rem + | Mcons (priv, path', v, v', rem) -> + Mcons (priv, path', v, v', forget_abbrev_rec rem path) + | Mlink mem' -> + mem' := forget_abbrev_rec !mem' path; + raise Exit + +let forget_abbrev mem path = + try mem := forget_abbrev_rec !mem path with Exit -> () + +(* debug: check for invalid abbreviations +let rec check_abbrev_rec = function + Mnil -> true + | Mcons (_, ty1, ty2, rem) -> + repr ty1 != repr ty2 + | Mlink mem' -> + check_abbrev_rec !mem' + +let check_memorized_abbrevs () = + List.for_all (fun mem -> check_abbrev_rec !mem) !memo +*) + +(* Re-export backtrack *) + +let snapshot = snapshot +let backtrack = backtrack ~cleanup_abbrev + + (**********************************) + (* Utilities for labels *) + (**********************************) + +let is_optional = function Optional _ -> true | _ -> false + +let label_name = function + Nolabel -> "" + | Labelled s + | Optional s -> s + +let prefixed_label_name = function + Nolabel -> "" + | Labelled s -> "~" ^ s + | Optional s -> "?" ^ s + +let rec extract_label_aux hd l = function + | [] -> None + | (l',t as p) :: ls -> + if label_name l' = l then + Some (l', t, hd <> [], List.rev_append hd ls) + else + extract_label_aux (p::hd) l ls + +let extract_label l ls = extract_label_aux [] l ls + + (*******************************) + (* Operations on class types *) + (*******************************) + +let rec signature_of_class_type = + function + Cty_constr (_, _, cty) -> signature_of_class_type cty + | Cty_signature sign -> sign + | Cty_arrow (_, _, cty) -> signature_of_class_type cty + +let rec class_body cty = + match cty with + Cty_constr _ -> + cty (* Only class bodies can be abbreviated *) + | Cty_signature _ -> + cty + | Cty_arrow (_, _, cty) -> + class_body cty + +(* Fully expand the head of a class type *) +let rec scrape_class_type = + function + Cty_constr (_, _, cty) -> scrape_class_type cty + | cty -> cty + +let rec class_type_arity = + function + Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty + +let rec abbreviate_class_type path params cty = + match cty with + Cty_constr (_, _, _) | Cty_signature _ -> + Cty_constr (path, params, cty) + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, ty, abbreviate_class_type path params cty) + +let self_type cty = + (signature_of_class_type cty).csig_self + +let self_type_row cty = + (signature_of_class_type cty).csig_self_row + +(* Return the methods of a class signature *) +let methods sign = + Meths.fold + (fun name _ l -> name :: l) + sign.csig_meths [] + +(* Return the virtual methods of a class signature *) +let virtual_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_meths [] + +(* Return the concrete methods of a class signature *) +let concrete_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> MethSet.add name s) + sign.csig_meths MethSet.empty + +(* Return the public methods of a class signature *) +let public_methods sign = + Meths.fold + (fun name (priv, _vr, _ty) l -> + match priv with + | Mprivate _ -> l + | Mpublic -> name :: l) + sign.csig_meths [] + +(* Return the instance variables of a class signature *) +let instance_vars sign = + Vars.fold + (fun name _ l -> name :: l) + sign.csig_vars [] + +(* Return the virtual instance variables of a class signature *) +let virtual_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_vars [] + +(* Return the concrete instance variables of a class signature *) +let concrete_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> VarSet.add name s) + sign.csig_vars VarSet.empty + +let method_type label sign = + match Meths.find label sign.csig_meths with + | (_, _, ty) -> ty + | exception Not_found -> assert false + +let instance_variable_type label sign = + match Vars.find label sign.csig_vars with + | (_, _, ty) -> ty + | exception Not_found -> assert false + + + (**********) + (* Misc *) + (**********) + +(**** Type information getter ****) + +let cstr_type_path cstr = + match get_desc cstr.cstr_res with + | Tconstr (p, _, _) -> p + | _ -> assert false diff --git a/upstream/ocaml_503/typing/btype.mli b/upstream/ocaml_503/typing/btype.mli new file mode 100644 index 000000000..f8fd3ad3e --- /dev/null +++ b/upstream/ocaml_503/typing/btype.mli @@ -0,0 +1,311 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Basic operations on core types *) + +open Asttypes +open Types + +(**** Sets, maps and hashtables of types ****) + +module TypeSet : sig + include Set.S with type elt = transient_expr + val add: type_expr -> t -> t + val mem: type_expr -> t -> bool + val singleton: type_expr -> t + val exists: (type_expr -> bool) -> t -> bool + val elements: t -> type_expr list +end +module TransientTypeMap : Map.S with type key = transient_expr +module TypeMap : sig + include Map.S with type key = transient_expr + and type 'a t = 'a TransientTypeMap.t + val add: type_expr -> 'a -> 'a t -> 'a t + val find: type_expr -> 'a t -> 'a + val singleton: type_expr -> 'a -> 'a t + val fold: (type_expr -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end +module TypeHash : sig + include Hashtbl.S with type key = transient_expr + val mem: 'a t -> type_expr -> bool + val add: 'a t -> type_expr -> 'a -> unit + val remove: 'a t -> type_expr -> unit + val find: 'a t -> type_expr -> 'a + val find_opt: 'a t -> type_expr -> 'a option + val iter: (type_expr -> 'a -> unit) -> 'a t -> unit +end +module TypePairs : sig + type t + val create: int -> t + val clear: t -> unit + val add: t -> type_expr * type_expr -> unit + val mem: t -> type_expr * type_expr -> bool + val iter: (type_expr * type_expr -> unit) -> t -> unit +end + +(**** Levels ****) + +val generic_level: int + (* level of polymorphic variables; = Ident.highest_scope *) +val lowest_level: int + (* lowest level for type nodes; = Ident.lowest_scope *) + +val with_new_pool: level:int -> (unit -> 'a) -> 'a * transient_expr list + (* [with_new_pool ~level f] executes [f] and returns the nodes + that were created at level [level] and above *) +val add_to_pool: level:int -> transient_expr -> unit + (* Add a type node to the pool associated to the level (which should + be the level of the type node). + Do nothing if [level = generic_level] or [level = lowest_level]. *) + +val newty3: level:int -> scope:int -> type_desc -> type_expr + (* Create a type with a fresh id *) +val newty2: level:int -> type_desc -> type_expr + (* Create a type with a fresh id and no scope *) + +val newgenty: type_desc -> type_expr + (* Create a generic type *) +val newgenvar: ?name:string -> unit -> type_expr + (* Return a fresh generic variable *) +val newgenstub: scope:int -> type_expr + (* Return a fresh generic node, to be instantiated + by [Transient_expr.set_stub_desc] *) + +(**** Types ****) + +val is_Tvar: type_expr -> bool +val is_Tunivar: type_expr -> bool +val is_Tconstr: type_expr -> bool +val is_poly_Tpoly: type_expr -> bool +val dummy_method: label +val type_kind_is_abstract: type_declaration -> bool +val type_origin: type_declaration -> type_origin +val label_is_poly: label_description -> bool + +(**** polymorphic variants ****) + +val is_fixed: row_desc -> bool +(* Return whether the row is directly marked as fixed or not *) + +val has_fixed_explanation: row_desc -> bool +(* Return whether the row should be treated as fixed or not. + In particular, [is_fixed row] implies [has_fixed_explanation row]. +*) + +val fixed_explanation: row_desc -> fixed_explanation option +(* Return the potential explanation for the fixed row *) + +val merge_fixed_explanation: + fixed_explanation option -> fixed_explanation option + -> fixed_explanation option +(* Merge two explanations for a fixed row *) + +val static_row: row_desc -> bool + (* Return whether the row is static or not *) +val hash_variant: label -> int + (* Hash function for variant tags *) + +val proxy: type_expr -> type_expr + (* Return the proxy representative of the type: either itself + or a row variable *) + +(**** Utilities for private abbreviations with fixed rows ****) +val row_of_type: type_expr -> type_expr +val has_constr_row: type_expr -> bool +val is_row_name: string -> bool +val is_constr_row: allow_ident:bool -> type_expr -> bool + +(* Set the polymorphic variant row_name field *) +val set_static_row_name: type_declaration -> Path.t -> unit + +(**** Utilities for type traversal ****) + +val iter_type_expr: (type_expr -> unit) -> type_expr -> unit + (* Iteration on types *) +val fold_type_expr: ('a -> type_expr -> 'a) -> 'a -> type_expr -> 'a +val iter_row: (type_expr -> unit) -> row_desc -> unit + (* Iteration on types in a row *) +val fold_row: ('a -> type_expr -> 'a) -> 'a -> row_desc -> 'a +val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit + (* Iteration on types in an abbreviation list *) +val iter_type_expr_kind: (type_expr -> unit) -> (type_decl_kind -> unit) + +val iter_type_expr_cstr_args: (type_expr -> unit) -> + (constructor_arguments -> unit) +val map_type_expr_cstr_args: (type_expr -> type_expr) -> + (constructor_arguments -> constructor_arguments) + +(**** Utilities for type marking ****) + +val mark_type: type_mark -> type_expr -> unit + (* Mark a type recursively *) +val mark_type_params: type_mark -> type_expr -> unit + (* Mark the sons of a type node recursively *) + +(**** (Object-oriented) iterator ****) + +type 'a type_iterators = + { it_signature: 'a type_iterators -> signature -> unit; + it_signature_item: 'a type_iterators -> signature_item -> unit; + it_value_description: 'a type_iterators -> value_description -> unit; + it_type_declaration: 'a type_iterators -> type_declaration -> unit; + it_extension_constructor: + 'a type_iterators -> extension_constructor -> unit; + it_module_declaration: 'a type_iterators -> module_declaration -> unit; + it_modtype_declaration: 'a type_iterators -> modtype_declaration -> unit; + it_class_declaration: 'a type_iterators -> class_declaration -> unit; + it_class_type_declaration: + 'a type_iterators -> class_type_declaration -> unit; + it_functor_param: 'a type_iterators -> functor_parameter -> unit; + it_module_type: 'a type_iterators -> module_type -> unit; + it_class_type: 'a type_iterators -> class_type -> unit; + it_type_kind: 'a type_iterators -> type_decl_kind -> unit; + it_do_type_expr: 'a type_iterators -> 'a; + it_type_expr: 'a type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; } + +type type_iterators_full = (type_expr -> unit) type_iterators +type type_iterators_without_type_expr = (unit -> unit) type_iterators + +val type_iterators: type_mark -> type_iterators_full + (* Iteration on arbitrary type information, including [type_expr]. + [it_type_expr] calls [mark_node] to avoid loops. *) + +val type_iterators_without_type_expr: type_iterators_without_type_expr + (* Iteration on arbitrary type information. + Cannot recurse on [type_expr]. *) + +(**** Utilities for copying ****) + +val copy_type_desc: + ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc + (* Copy on types *) +val copy_row: + (type_expr -> type_expr) -> + bool -> row_desc -> bool -> type_expr -> row_desc + +module For_copy : sig + + type copy_scope + (* The private state that the primitives below are mutating, it should + remain scoped within a single [with_scope] call. + + While it is possible to circumvent that discipline in various + ways, you should NOT do that. *) + + val redirect_desc: copy_scope -> type_expr -> type_desc -> unit + (* Temporarily change a type description *) + + val with_scope: (copy_scope -> 'a) -> 'a + (* [with_scope f] calls [f] and restores saved type descriptions + before returning its result. *) +end + +(**** Memorization of abbreviation expansion ****) + +val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option + (* Look up a memorized abbreviation *) +val cleanup_abbrev: unit -> unit + (* Flush the cache of abbreviation expansions. + When some types are saved (using [output_value]), this + function MUST be called just before. *) +val memorize_abbrev: + abbrev_memo ref -> + private_flag -> Path.t -> type_expr -> type_expr -> unit + (* Add an expansion in the cache *) +val forget_abbrev: + abbrev_memo ref -> Path.t -> unit + (* Remove an abbreviation from the cache *) + +(**** Backtracking ****) + +val snapshot: unit -> snapshot +val backtrack: snapshot -> unit + (* Backtrack to a given snapshot. Only possible if you have + not already backtracked to a previous snapshot. + Calls [cleanup_abbrev] internally *) + +(**** Utilities for labels ****) + +val is_optional : arg_label -> bool +val label_name : arg_label -> label + +(* Returns the label name with first character '?' or '~' as appropriate. *) +val prefixed_label_name : arg_label -> label + +val extract_label : + label -> (arg_label * 'a) list -> + (arg_label * 'a * bool * (arg_label * 'a) list) option +(* actual label, + value, + whether (label, value) was at the head of the list, + list without the extracted (label, value) *) + +(**** Utilities for class types ****) + +(* Get the class signature within a class type *) +val signature_of_class_type : class_type -> class_signature + +(* Get the body of a class type (i.e. without parameters) *) +val class_body : class_type -> class_type + +(* Fully expand the head of a class type *) +val scrape_class_type : class_type -> class_type + +(* Return the number of parameters of a class type *) +val class_type_arity : class_type -> int + +(* Given a path and type parameters, add an abbreviation to a class type *) +val abbreviate_class_type : + Path.t -> type_expr list -> class_type -> class_type + +(* Get the self type of a class *) +val self_type : class_type -> type_expr + +(* Get the row variable of the self type of a class *) +val self_type_row : class_type -> type_expr + +(* Return the methods of a class signature *) +val methods : class_signature -> string list + +(* Return the virtual methods of a class signature *) +val virtual_methods : class_signature -> string list + +(* Return the concrete methods of a class signature *) +val concrete_methods : class_signature -> MethSet.t + +(* Return the public methods of a class signature *) +val public_methods : class_signature -> string list + +(* Return the instance variables of a class signature *) +val instance_vars : class_signature -> string list + +(* Return the virtual instance variables of a class signature *) +val virtual_instance_vars : class_signature -> string list + +(* Return the concrete instance variables of a class signature *) +val concrete_instance_vars : class_signature -> VarSet.t + +(* Return the type of a method. + @raises [Assert_failure] if the class has no such method. *) +val method_type : label -> class_signature -> type_expr + +(* Return the type of an instance variable. + @raises [Assert_failure] if the class has no such method. *) +val instance_variable_type : label -> class_signature -> type_expr + +(**** Type information getter ****) + +val cstr_type_path : constructor_description -> Path.t diff --git a/upstream/ocaml_503/typing/cmt2annot.ml b/upstream/ocaml_503/typing/cmt2annot.ml new file mode 100644 index 000000000..698cccab9 --- /dev/null +++ b/upstream/ocaml_503/typing/cmt2annot.ml @@ -0,0 +1,192 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Generate an .annot file from a .cmt file. *) + +open Asttypes +open Typedtree +open Tast_iterator + +let variables_iterator scope = + let super = default_iterator in + let pat sub (type k) (p : k general_pattern) = + begin match p.pat_desc with + | Tpat_var (id, _, _) | Tpat_alias (_, id, _, _) -> + Stypes.record (Stypes.An_ident (p.pat_loc, + Ident.name id, + Annot.Idef scope)) + | _ -> () + end; + super.pat sub p + in + {super with pat} + +let bind_variables scope = + let iter = variables_iterator scope in + fun p -> iter.pat iter p + +let bind_bindings scope bindings = + let o = bind_variables scope in + List.iter (fun x -> o x.vb_pat) bindings + +let bind_cases l = + List.iter + (fun {c_lhs; c_guard; c_rhs} -> + let loc = + let open Location in + match c_guard with + | None -> c_rhs.exp_loc + | Some g -> {c_rhs.exp_loc with loc_start=g.exp_loc.loc_start} + in + bind_variables loc c_lhs + ) + l + +let bind_function_param loc fp = + match fp.fp_kind with + | Tparam_pat pat -> bind_variables loc pat + | Tparam_optional_default (pat, _) -> bind_variables loc pat + +let record_module_binding scope mb = + Stypes.record (Stypes.An_ident + (mb.mb_name.loc, + Option.value mb.mb_name.txt ~default:"_", + Annot.Idef scope)) + +let rec iterator ~scope rebuild_env = + let super = default_iterator in + let class_expr sub node = + Stypes.record (Stypes.Ti_class node); + super.class_expr sub node + + and module_expr _sub node = + Stypes.record (Stypes.Ti_mod node); + super.module_expr (iterator ~scope:node.mod_loc rebuild_env) node + + and expr sub exp = + begin match exp.exp_desc with + | Texp_ident (path, _, _) -> + let full_name = Path.name ~paren:Oprint.parenthesized_ident path in + let env = + if rebuild_env then + Env.env_of_only_summary Envaux.env_from_summary exp.exp_env + else + exp.exp_env + in + let annot = + try + let desc = Env.find_value path env in + let dloc = desc.Types.val_loc in + if dloc.Location.loc_ghost then Annot.Iref_external + else Annot.Iref_internal dloc + with Not_found -> + Annot.Iref_external + in + Stypes.record + (Stypes.An_ident (exp.exp_loc, full_name , annot)) + | Texp_let (Recursive, bindings, _) -> + bind_bindings exp.exp_loc bindings + | Texp_let (Nonrecursive, bindings, body) -> + bind_bindings body.exp_loc bindings + | Texp_match (_, f1, f2, _) -> + bind_cases f1; + bind_cases f2 + | Texp_try (_, f1, f2) -> + bind_cases f1; + bind_cases f2 + | Texp_function (params, _) -> + List.iter (bind_function_param exp.exp_loc) params + | Texp_letmodule (_, modname, _, _, body ) -> + Stypes.record (Stypes.An_ident + (modname.loc,Option.value ~default:"_" modname.txt, + Annot.Idef body.exp_loc)) + | _ -> () + end; + Stypes.record (Stypes.Ti_expr exp); + super.expr sub exp + + and pat sub (type k) (p : k general_pattern) = + Stypes.record (Stypes.Ti_pat (classify_pattern p, p)); + super.pat sub p + in + + let structure_item_rem sub str rem = + let open Location in + let loc = str.str_loc in + begin match str.str_desc with + | Tstr_value (rec_flag, bindings) -> + let doit loc_start = bind_bindings {scope with loc_start} bindings in + begin match rec_flag, rem with + | Recursive, _ -> doit loc.loc_start + | Nonrecursive, [] -> doit loc.loc_end + | Nonrecursive, {str_loc = loc2} :: _ -> doit loc2.loc_start + end + | Tstr_module mb -> + record_module_binding + { scope with Location.loc_start = loc.loc_end } mb + | Tstr_recmodule mbs -> + List.iter (record_module_binding + { scope with Location.loc_start = loc.loc_start }) mbs + | _ -> + () + end; + Stypes.record_phrase loc; + super.structure_item sub str + in + let structure_item sub s = + (* This will be used for Partial_structure_item. + We don't have here the location of the "next" item, + this will give a slightly different scope for the non-recursive + binding case. *) + structure_item_rem sub s [] + in + let structure sub l = + let rec loop = function + | str :: rem -> structure_item_rem sub str rem; loop rem + | [] -> () + in + loop l.str_items + in + {super with class_expr; module_expr; expr; pat; structure_item; structure} + +let binary_part iter x = + let open Cmt_format in + match x with + | Partial_structure x -> iter.structure iter x + | Partial_structure_item x -> iter.structure_item iter x + | Partial_expression x -> iter.expr iter x + | Partial_pattern (_, x) -> iter.pat iter x + | Partial_class_expr x -> iter.class_expr iter x + | Partial_signature x -> iter.signature iter x + | Partial_signature_item x -> iter.signature_item iter x + | Partial_module_type x -> iter.module_type iter x + +let gen_annot target_filename ~sourcefile ~use_summaries annots = + let open Cmt_format in + let scope = + match sourcefile with + | None -> Location.none + | Some s -> Location.in_file s + in + let iter = iterator ~scope use_summaries in + match annots with + | Implementation typedtree -> + iter.structure iter typedtree; + Stypes.dump target_filename + | Partial_implementation parts -> + Array.iter (binary_part iter) parts; + Stypes.dump target_filename + | Interface _ | Packed _ | Partial_interface _ -> + () diff --git a/upstream/ocaml_503/typing/cmt2annot.mli b/upstream/ocaml_503/typing/cmt2annot.mli new file mode 100644 index 000000000..978e00d36 --- /dev/null +++ b/upstream/ocaml_503/typing/cmt2annot.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Sebastien Hinderer, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2022 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Generate an .annot file from a .cmt file. *) + +val gen_annot : + string option -> + sourcefile:string option -> + use_summaries:bool -> Cmt_format.binary_annots -> + unit + +val iterator : scope:Location.t -> bool -> Tast_iterator.iterator + +val binary_part : Tast_iterator.iterator -> Cmt_format.binary_part -> unit diff --git a/upstream/ocaml_503/typing/ctype.ml b/upstream/ocaml_503/typing/ctype.ml new file mode 100644 index 000000000..7319a363a --- /dev/null +++ b/upstream/ocaml_503/typing/ctype.ml @@ -0,0 +1,5661 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Operations on core types *) + +open Misc +open Asttypes +open Types +open Btype +open Errortrace + +open Local_store + +(* + General notes + ============= + - As much sharing as possible should be kept : it makes types + smaller and better abbreviated. + When necessary, some sharing can be lost. Types will still be + printed correctly (+++ TO DO...), and abbreviations defined by a + class do not depend on sharing thanks to constrained + abbreviations. (Of course, even if some sharing is lost, typing + will still be correct.) + - All nodes of a type have a level : that way, one knows whether a + node need to be duplicated or not when instantiating a type. + - Levels of a type are decreasing (generic level being considered + as greatest). + - The level of a type constructor is superior to the binding + time of its path. + - Recursive types without limitation should be handled (even if + there is still an occur check). This avoid treating specially the + case for objects, for instance. Furthermore, the occur check + policy can then be easily changed. +*) + +(**** Errors ****) + +(* There are two classes of errortrace-related exceptions: *traces* and + *errors*. The former, whose names end with [_trace], contain + [Errortrace.trace]s, representing traces that are currently being built; they + are local to this file. All the internal functions that implement + unification, type equality, and moregen raise trace exceptions. Once we are + done, in the top level functions such as [unify], [equal], and [moregen], we + catch the trace exceptions and transform them into the analogous error + exception. This indicates that we are done building the trace, and expect + the error to flow out of unification, type equality, or moregen into + surrounding code (with some few exceptions when these top-level functions are + used as building blocks elsewhere.) Only the error exceptions are exposed in + [ctype.mli]; the trace exceptions are an implementation detail. Any trace + exception that escapes from a function in this file is a bug. *) + +exception Unify_trace of unification trace +exception Equality_trace of comparison trace +exception Moregen_trace of comparison trace + +exception Unify of unification_error +exception Equality of equality_error +exception Moregen of moregen_error +exception Subtype of Subtype.error + +exception Escape of type_expr escape + +(* For local use: throw the appropriate exception. Can be passed into local + functions as a parameter *) +type _ trace_exn = +| Unify : unification trace_exn +| Moregen : comparison trace_exn +| Equality : comparison trace_exn + +let raise_trace_for + (type variant) + (tr_exn : variant trace_exn) + (tr : variant trace) : 'a = + match tr_exn with + | Unify -> raise (Unify_trace tr) + | Equality -> raise (Equality_trace tr) + | Moregen -> raise (Moregen_trace tr) + +(* Uses of this function are a bit suspicious, as we usually want to maintain + trace information; sometimes it makes sense, however, since we're maintaining + the trace at an outer exception handler. *) +let raise_unexplained_for tr_exn = + raise_trace_for tr_exn [] + +let raise_for tr_exn e = + raise_trace_for tr_exn [e] + +(* Thrown from [moregen_kind] *) +exception Public_method_to_private_method + +let escape kind = {kind; context = None} +let escape_exn kind = Escape (escape kind) +let scope_escape_exn ty = escape_exn (Equation ty) +let raise_escape_exn kind = raise (escape_exn kind) +let raise_scope_escape_exn ty = raise (scope_escape_exn ty) + +exception Tags of label * label + +let () = + let open Format_doc in + Location.register_error_of_exn + (function + | Tags (l, l') -> + let pp_tag ppf s = fprintf ppf "`%s" s in + let inline_tag = Misc.Style.as_inline_code pp_tag in + Some + Location. + (errorf ~loc:(in_file !input_name) + "In this program,@ variant constructors@ %a and %a@ \ + have the same hash value.@ Change one of them." + inline_tag l inline_tag l' + ) + | _ -> None + ) + +exception Cannot_expand + +exception Cannot_apply + +exception Cannot_subst + +exception Cannot_unify_universal_variables + +exception Matches_failure of Env.t * unification_error + +exception Incompatible + +(**** Control tracing of GADT instances *) + +let trace_gadt_instances = ref false +let check_trace_gadt_instances env = + not !trace_gadt_instances && Env.has_local_constraints env && + (trace_gadt_instances := true; cleanup_abbrev (); true) + +let reset_trace_gadt_instances b = + if b then trace_gadt_instances := false + +let wrap_trace_gadt_instances env f x = + let b = check_trace_gadt_instances env in + let y = f x in + reset_trace_gadt_instances b; + y + +(**** Abbreviations without parameters ****) +(* Shall reset after generalizing *) + +let simple_abbrevs = ref Mnil + +let proper_abbrevs tl abbrev = + if tl <> [] || !trace_gadt_instances || !Clflags.principal + then abbrev + else simple_abbrevs + +(**** Type level management ****) + +let current_level = s_ref 0 +let nongen_level = s_ref 0 +let global_level = s_ref 0 +let saved_level = s_ref [] + +let get_current_level () = !current_level +let init_def level = current_level := level; nongen_level := level +let begin_def () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + incr current_level; nongen_level := !current_level +let begin_class_def () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + incr current_level +let raise_nongen_level () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + nongen_level := !current_level +let end_def () = + let (cl, nl) = List.hd !saved_level in + saved_level := List.tl !saved_level; + current_level := cl; nongen_level := nl +let create_scope () = + let level = !current_level + 1 in + init_def level; + level + +let wrap_end_def f = Misc.try_finally f ~always:end_def +let wrap_end_def_new_pool f = + wrap_end_def (fun _ -> with_new_pool ~level:!current_level f) + +(* [with_local_level_gen] handles both the scoping structure of levels + and automatic generalization through pools (cf. btype.ml) *) +let with_local_level_gen ~begin_def ~structure ?before_generalize f = + begin_def (); + let level = !current_level in + let result, pool = wrap_end_def_new_pool f in + Option.iter (fun g -> g result) before_generalize; + simple_abbrevs := Mnil; + (* Nodes in [pool] were either created by the above call to [f], + or they were created before, generalized, and then added to + the pool by [update_level]. + In the latter case, their level was already kept for backtracking + by a call to [set_level] inside [update_level]. + Since backtracking can only go back to a snapshot taken before [f] was + called, this means that either they did not exists in that snapshot, + or that they original level is already stored, so that there is no need + to register levels for backtracking when we change them with + [Transient_expr.set_level] here *) + List.iter begin fun ty -> + (* Already generic nodes are not tracked *) + if ty.level = generic_level then () else + match ty.desc with + | Tvar _ when structure -> + (* In structure mode, we do do not generalize type variables, + so we need to lower their level, and move them to an outer pool. + The goal of this mode is to allow unsharing inner nodes + without introducing polymorphism *) + if ty.level >= level then Transient_expr.set_level ty !current_level; + add_to_pool ~level:ty.level ty + | Tlink _ -> () + (* If a node is no longer used as representative, no need + to track it anymore *) + | _ -> + if ty.level < level then + (* If a node was introduced locally, but its level was lowered + through unification, keeping that node as representative, + then we need to move it to an outer pool. *) + add_to_pool ~level:ty.level ty + else begin + (* Generalize all remaining nodes *) + Transient_expr.set_level ty generic_level; + if structure then match ty.desc with + Tconstr (_, _, abbrev) -> + (* In structure mode, we drop abbreviations, as the goal of + this mode is to reduce sharing *) + abbrev := Mnil + | _ -> () + end + end pool; + result + +let with_local_level_generalize_structure f = + with_local_level_gen ~begin_def ~structure:true f +let with_local_level_generalize ?before_generalize f = + with_local_level_gen ~begin_def ~structure:false ?before_generalize f +let with_local_level_generalize_if cond ?before_generalize f = + if cond then with_local_level_generalize ?before_generalize f else f () +let with_local_level_generalize_structure_if cond f = + if cond then with_local_level_generalize_structure f else f () +let with_local_level_generalize_structure_if_principal f = + if !Clflags.principal then with_local_level_generalize_structure f else f () +let with_local_level_generalize_for_class f = + with_local_level_gen ~begin_def:begin_class_def ~structure:false f + +let with_local_level ?post f = + begin_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result +let with_local_level_if cond f ~post = + if cond then with_local_level f ~post else f () +let with_local_level_iter f ~post = + begin_def (); + let (result, l) = wrap_end_def f in + List.iter post l; + result +let with_local_level_iter_if cond f ~post = + if cond then with_local_level_iter f ~post else fst (f ()) +let with_local_level_if_principal f ~post = + with_local_level_if !Clflags.principal f ~post +let with_local_level_iter_if_principal f ~post = + with_local_level_iter_if !Clflags.principal f ~post +let with_level ~level f = + begin_def (); init_def level; + wrap_end_def f +let with_level_if cond ~level f = + if cond then with_level ~level f else f () + +let with_local_level_for_class ?post f = + begin_class_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result + +let with_raised_nongen_level f = + raise_nongen_level (); + wrap_end_def f + + +let reset_global_level () = + global_level := !current_level +let increase_global_level () = + let gl = !global_level in + global_level := !current_level; + gl +let restore_global_level gl = + global_level := gl + +(**** Some type creators ****) + +(* Re-export generic type creators *) + +let newty desc = newty2 ~level:!current_level desc +let new_scoped_ty scope desc = newty3 ~level:!current_level ~scope desc + +let newvar ?name () = newty2 ~level:!current_level (Tvar name) +let newvar2 ?name level = newty2 ~level:level (Tvar name) +let new_global_var ?name () = newty2 ~level:!global_level (Tvar name) +let newstub ~scope = newty3 ~level:!current_level ~scope (Tvar None) + +let newobj fields = newty (Tobject (fields, ref None)) + +let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) + +let none = newty (Ttuple []) (* Clearly ill-formed type *) + +(**** information for [Typecore.unify_pat_*] ****) + +module Pattern_env : sig + type t = private + { mutable env : Env.t; + equations_scope : int; + allow_recursive_equations : bool; } + val make: Env.t -> equations_scope:int -> allow_recursive_equations:bool -> t + val copy: ?equations_scope:int -> t -> t + val set_env: t -> Env.t -> unit +end = struct + type t = + { mutable env : Env.t; + equations_scope : int; + allow_recursive_equations : bool; } + let make env ~equations_scope ~allow_recursive_equations = + { env; + equations_scope; + allow_recursive_equations; } + let copy ?equations_scope penv = + let equations_scope = + match equations_scope with None -> penv.equations_scope | Some s -> s in + { penv with equations_scope } + let set_env penv env = penv.env <- env +end + +(**** unification mode ****) + +type equations_generation = + | Forbidden + | Allowed of { equated_types : TypePairs.t } + +type unification_environment = + | Expression of + { env : Env.t; + in_subst : bool; } + (* normal unification mode *) + | Pattern of + { penv : Pattern_env.t; + equations_generation : equations_generation; + assume_injective : bool; + unify_eq_set : TypePairs.t; } + (* GADT constraint unification mode: + only used for type indices of GADT constructors + during pattern matching. + This allows adding local constraints. *) + +let get_env = function + | Expression {env} -> env + | Pattern {penv} -> penv.env + +let set_env uenv env = + match uenv with + | Expression _ -> invalid_arg "Ctype.set_env" + | Pattern {penv} -> Pattern_env.set_env penv env + +let in_pattern_mode = function + | Expression _ -> false + | Pattern _ -> true + +let get_equations_scope = function + | Expression _ -> invalid_arg "Ctype.get_equations_scope" + | Pattern r -> r.penv.equations_scope + +let order_type_pair t1 t2 = + if get_id t1 <= get_id t2 then (t1, t2) else (t2, t1) + +let add_type_equality uenv t1 t2 = + match uenv with + | Expression _ -> invalid_arg "Ctype.add_type_equality" + | Pattern r -> TypePairs.add r.unify_eq_set (order_type_pair t1 t2) + +let unify_eq uenv t1 t2 = + eq_type t1 t2 || + match uenv with + | Expression _ -> false + | Pattern r -> TypePairs.mem r.unify_eq_set (order_type_pair t1 t2) + +(* unification during type constructor expansion: + This mode disables the propagation of the level and scope of + the row variable to the whole type during the unification. + (see unify_{row, fields} and PR #11771) *) +let in_subst_mode = function + | Expression {in_subst} -> in_subst + | Pattern _ -> false + +let can_generate_equations = function + | Expression _ | Pattern { equations_generation = Forbidden } -> false + | Pattern { equations_generation = Allowed _ } -> true + +(* Can only be called when generate_equations is true *) +let record_equation uenv t1 t2 = + match uenv with + | Expression _ | Pattern { equations_generation = Forbidden } -> + invalid_arg "Ctype.record_equation" + | Pattern { equations_generation = Allowed { equated_types } } -> + TypePairs.add equated_types (t1, t2) + +let can_assume_injective = function + | Expression _ -> false + | Pattern { assume_injective } -> assume_injective + +let in_counterexample uenv = + match uenv with + | Expression _ -> false + | Pattern { penv } -> penv.allow_recursive_equations + +let allow_recursive_equations uenv = + !Clflags.recursive_types || in_counterexample uenv + +(* Though without_* functions can be in a direct style, + CPS clarifies the structure of the code better. *) +let without_assume_injective uenv f = + match uenv with + | Expression _ as uenv -> f uenv + | Pattern r -> f (Pattern { r with assume_injective = false }) + +let without_generating_equations uenv f = + match uenv with + | Expression _ as uenv -> f uenv + | Pattern r -> f (Pattern { r with equations_generation = Forbidden }) + +(*** Checks for type definitions ***) + +let rec in_current_module = function + | Path.Pident _ -> true + | Path.Pdot _ | Path.Papply _ -> false + | Path.Pextra_ty (p, _) -> in_current_module p + +let in_pervasives p = + in_current_module p && + try ignore (Env.find_type p Env.initial); true + with Not_found -> false + +let is_datatype decl= + match decl.type_kind with + Type_record _ | Type_variant _ | Type_open -> true + | Type_abstract _ -> false + + + (**********************************************) + (* Miscellaneous operations on object types *) + (**********************************************) + +(* Note: + We need to maintain some invariants: + * cty_self must be a Tobject + * ... +*) + +(**** Object field manipulation. ****) + +let object_fields ty = + match get_desc ty with + Tobject (fields, _) -> fields + | _ -> assert false + +let flatten_fields ty = + let rec flatten l ty = + match get_desc ty with + Tfield(s, k, ty1, ty2) -> + flatten ((s, k, ty1)::l) ty2 + | _ -> + (l, ty) + in + let (l, r) = flatten [] ty in + (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) + +let build_fields level = + List.fold_right + (fun (s, k, ty1) ty2 -> newty2 ~level (Tfield(s, k, ty1, ty2))) + +let associate_fields fields1 fields2 = + let rec associate p s s' = + function + (l, []) -> + (List.rev p, (List.rev s) @ l, List.rev s') + | ([], l') -> + (List.rev p, List.rev s, (List.rev s') @ l') + | ((n, k, t)::r, (n', k', t')::r') when n = n' -> + associate ((n, k, t, k', t')::p) s s' (r, r') + | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' -> + associate p ((n, k, t)::s) s' (r, l') + | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) -> + associate p s ((n', k', t')::s') (l, r') + in + associate [] [] [] (fields1, fields2) + +(**** Check whether an object is open ****) + +(* +++ The abbreviation should eventually be expanded *) +let rec object_row ty = + match get_desc ty with + Tobject (t, _) -> object_row t + | Tfield(_, _, _, t) -> object_row t + | _ -> ty + +let opened_object ty = + match get_desc (object_row ty) with + | Tvar _ | Tunivar _ | Tconstr _ -> true + | _ -> false + +let concrete_object ty = + match get_desc (object_row ty) with + | Tvar _ -> false + | _ -> true + +(**** Row variable of an object type ****) + +let rec fields_row_variable ty = + match get_desc ty with + | Tfield (_, _, _, ty) -> fields_row_variable ty + | Tvar _ -> ty + | _ -> assert false + +(**** Object name manipulation ****) +(* +++ Bientot obsolete *) + +let set_object_name id params ty = + match get_desc ty with + | Tobject (fi, nm) -> + let rv = fields_row_variable fi in + set_name nm (Some (Path.Pident id, rv::params)) + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.set_object_name" + +let remove_object_name ty = + match get_desc ty with + Tobject (_, nm) -> set_name nm None + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.remove_object_name" + + (*******************************************) + (* Miscellaneous operations on row types *) + (*******************************************) + +let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q) + +let rec merge_rf r1 r2 pairs fi1 fi2 = + match fi1, fi2 with + (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> + if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else + if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else + merge_rf r1 (p2::r2) pairs fi1 fi2' + | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) + | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) + +let merge_row_fields fi1 fi2 = + match fi1, fi2 with + [], _ | _, [] -> (fi1, fi2, []) + | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) + | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, []) + | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) + +let rec filter_row_fields erase = function + [] -> [] + | (_l,f as p)::fi -> + let fi = filter_row_fields erase fi in + match row_field_repr f with + Rabsent -> fi + | Reither(_,_,false) when erase -> + link_row_field_ext ~inside:f rf_absent; fi + | _ -> p :: fi + + (**************************************) + (* Check genericity of type schemes *) + (**************************************) + +type variable_kind = Row_variable | Type_variable +exception Non_closed of type_expr * variable_kind + +(* [free_vars] collects the variables of the input type expression. It + is used for several different things in the type-checker, with the + following bells and whistles: + - If [env] is Some typing environment, types in the environment + are expanded to check whether the apparently-free variable would vanish + during expansion. + - We collect both type variables and row variables, paired with + a [variable_kind] to distinguish them. + - We do not count "virtual" free variables -- free variables stored in + the abbreviation of an object type that has been expanded (we store + the abbreviations for use when displaying the type). + + [free_vars] returns a [(variable * bool) list], while + [free_variables] below drops the type/row information + and only returns a [variable list]. + *) +let free_vars ?env mark ty = + let rec fv ~kind acc ty = + if not (try_mark_node mark ty) then acc + else match get_desc ty, env with + | Tvar _, _ -> + (ty, kind) :: acc + | Tconstr (path, tl, _), Some env -> + let acc = + match Env.find_type_expansion path env with + | exception Not_found -> acc + | (_, body, _) -> + if get_level body = generic_level then acc + else (ty, kind) :: acc + in + List.fold_left (fv ~kind:Type_variable) acc tl + | Tobject (ty, _), _ -> + (* ignoring the second parameter of [Tobject] amounts to not + counting "virtual free variables". *) + fv ~kind:Row_variable acc ty + | Tfield (_, _, ty1, ty2), _ -> + let acc = fv ~kind:Type_variable acc ty1 in + fv ~kind:Row_variable acc ty2 + | Tvariant row, _ -> + let acc = fold_row (fv ~kind:Type_variable) acc row in + if static_row row then acc + else fv ~kind:Row_variable acc (row_more row) + | _ -> + fold_type_expr (fv ~kind) acc ty + in fv ~kind:Type_variable [] ty + +let free_variables ?env ty = + with_type_mark (fun mark -> List.map fst (free_vars ?env mark ty)) + +let closed_type mark ty = + match free_vars mark ty with + [] -> () + | (v, real) :: _ -> raise (Non_closed (v, real)) + +let closed_parameterized_type params ty = + with_type_mark begin fun mark -> + List.iter (mark_type mark) params; + try closed_type mark ty; true with Non_closed _ -> false + end + +let closed_type_decl decl = + with_type_mark begin fun mark -> try + List.iter (mark_type mark) decl.type_params; + begin match decl.type_kind with + Type_abstract _ -> + () + | Type_variant (v, _rep) -> + List.iter + (fun {cd_args; cd_res; _} -> + match cd_res with + | Some _ -> () + | None -> + match cd_args with + | Cstr_tuple l -> List.iter (closed_type mark) l + | Cstr_record l -> + List.iter (fun l -> closed_type mark l.ld_type) l + ) + v + | Type_record(r, _rep) -> + List.iter (fun l -> closed_type mark l.ld_type) r + | Type_open -> () + end; + begin match decl.type_manifest with + None -> () + | Some ty -> closed_type mark ty + end; + None + with Non_closed (ty, _) -> + Some ty + end + +let closed_extension_constructor ext = + with_type_mark begin fun mark -> try + List.iter (mark_type mark) ext.ext_type_params; + begin match ext.ext_ret_type with + | Some _ -> () + | None -> iter_type_expr_cstr_args (closed_type mark) ext.ext_args + end; + None + with Non_closed (ty, _) -> + Some ty + end + +type closed_class_failure = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} +exception CCFailure of closed_class_failure + +let closed_class params sign = + with_type_mark begin fun mark -> + List.iter (mark_type mark) params; + ignore (try_mark_node mark sign.csig_self_row); + try + Meths.iter + (fun lab (priv, _, ty) -> + if priv = Mpublic then begin + try closed_type mark ty with Non_closed (ty0, variable_kind) -> + raise (CCFailure { + free_variable = (ty0, variable_kind); + meth = lab; + meth_ty = ty; + }) + end) + sign.csig_meths; + None + with CCFailure reason -> + Some reason + end + + (**********************) + (* Type duplication *) + (**********************) + + +(* Duplicate a type, preserving only type variables *) +let duplicate_type ty = + Subst.type_expr Subst.identity ty + +(* Same, for class types *) +let duplicate_class_type ty = + Subst.class_type Subst.identity ty + + + (*****************************) + (* Type level manipulation *) + (*****************************) + + +(* + Build a copy of a type in which nodes reachable through a path composed + only of Tarrow, Tpoly, Ttuple, Tpackage and Tconstr, and whose level + was no lower than [!current_level], are at [generic_level]. + This is different from [with_local_level_gen], which generalizes in place, + and only nodes with a level higher than [!current_level]. + This is used for typing classes, to indicate which types have been + inferred in the first pass, and can be considered as "known" during the + second pass. + *) + +let rec copy_spine copy_scope ty = + match get_desc ty with + | Tsubst (ty, _) -> ty + | Tvar _ + | Tfield _ + | Tnil + | Tvariant _ + | Tobject _ + | Tlink _ + | Tunivar _ -> ty + | (Tarrow _ | Tpoly _ | Ttuple _ | Tpackage _ | Tconstr _) as desc -> + let level = get_level ty in + if level < !current_level || level = generic_level then ty else + let t = newgenstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let copy_rec = copy_spine copy_scope in + let desc' = match desc with + | Tarrow (lbl, ty1, ty2, _) -> + Tarrow (lbl, copy_rec ty1, copy_rec ty2, commu_ok) + | Tpoly (ty', tvl) -> + Tpoly (copy_rec ty', tvl) + | Ttuple tyl -> + Ttuple (List.map copy_rec tyl) + | Tpackage (path, fl) -> + let fl = List.map (fun (n, ty) -> n, copy_rec ty) fl in + Tpackage (path, fl) + | Tconstr (path, tyl, _) -> + Tconstr (path, List.map copy_rec tyl, ref Mnil) + | _ -> assert false + in + Transient_expr.set_stub_desc t desc'; + t + +let copy_spine ty = + For_copy.with_scope (fun copy_scope -> copy_spine copy_scope ty) + +let forward_try_expand_safe = (* Forward declaration *) + ref (fun _env _ty -> assert false) + +(* + Lower the levels of a type (assume [level] is not + [generic_level]). +*) + +let rec normalize_package_path env p = + let t = + try (Env.find_modtype p env).mtd_type + with Not_found -> None + in + match t with + | Some (Mty_ident p) -> normalize_package_path env p + | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None -> + match p with + Path.Pdot (p1, s) -> + (* For module aliases *) + let p1' = Env.normalize_module_path None env p1 in + if Path.same p1 p1' then p else + normalize_package_path env (Path.Pdot (p1', s)) + | _ -> p + +let rec check_scope_escape mark env level ty = + let orig_level = get_level ty in + if try_mark_node mark ty then begin + if level < get_scope ty then + raise_scope_escape_exn ty; + begin match get_desc ty with + | Tconstr (p, _, _) when level < Path.scope p -> + begin match !forward_try_expand_safe env ty with + | ty' -> + check_scope_escape mark env level ty' + | exception Cannot_expand -> + raise_escape_exn (Constructor p) + end + | Tpackage (p, fl) when level < Path.scope p -> + let p' = normalize_package_path env p in + if Path.same p p' then raise_escape_exn (Module_type p); + check_scope_escape mark env level + (newty2 ~level:orig_level (Tpackage (p', fl))) + | _ -> + iter_type_expr (check_scope_escape mark env level) ty + end; + end + +let check_scope_escape env level ty = + with_type_mark begin fun mark -> try + check_scope_escape mark env level ty + with Escape e -> + raise (Escape { e with context = Some ty }) + end + +let rec update_scope scope ty = + if get_scope ty < scope then begin + if get_level ty < scope then raise_scope_escape_exn ty; + set_scope ty scope; + (* Only recurse in principal mode as this is not necessary for soundness *) + if !Clflags.principal then iter_type_expr (update_scope scope) ty + end + +let update_scope_for tr_exn scope ty = + try + update_scope scope ty + with Escape e -> raise_for tr_exn (Escape e) + +(* Note: the level of a type constructor must be greater than its binding + time. That way, a type constructor cannot escape the scope of its + definition, as would be the case in + let x = ref [] + module M = struct type t let _ = (x : t list ref) end + (without this constraint, the type system would actually be unsound.) +*) + +let rec update_level env level expand ty = + let ty_level = get_level ty in + if ty_level > level then begin + if level < get_scope ty then raise_scope_escape_exn ty; + let set_level () = + set_level ty level; + if ty_level = generic_level then + add_to_pool ~level (Transient_expr.repr ty) + in + match get_desc ty with + Tconstr(p, _tl, _abbrev) when level < Path.scope p -> + (* Try first to replace an abbreviation by its expansion. *) + begin try + let ty' = !forward_try_expand_safe env ty in + link_type ty ty'; + update_level env level expand ty' + with Cannot_expand -> + raise_escape_exn (Constructor p) + end + | Tconstr(p, (_ :: _ as tl), _) -> + let variance = + try (Env.find_type p env).type_variance + with Not_found -> List.map (fun _ -> Variance.unknown) tl in + let needs_expand = + expand || + List.exists2 + (fun var ty -> var = Variance.null && get_level ty > level) + variance tl + in + begin try + if not needs_expand then raise Cannot_expand; + let ty' = !forward_try_expand_safe env ty in + link_type ty ty'; + update_level env level expand ty' + with Cannot_expand -> + set_level (); + iter_type_expr (update_level env level expand) ty + end + | Tpackage (p, fl) when level < Path.scope p -> + let p' = normalize_package_path env p in + if Path.same p p' then raise_escape_exn (Module_type p); + set_type_desc ty (Tpackage (p', fl)); + update_level env level expand ty + | Tobject (_, ({contents=Some(p, _tl)} as nm)) + when level < Path.scope p -> + set_name nm None; + update_level env level expand ty + | Tvariant row -> + begin match row_name row with + | Some (p, _tl) when level < Path.scope p -> + set_type_desc ty (Tvariant (set_row_name row None)) + | _ -> () + end; + set_level (); + iter_type_expr (update_level env level expand) ty + | Tfield(lab, _, ty1, _) + when lab = dummy_method && level < get_scope ty1 -> + raise_escape_exn Self + | _ -> + set_level (); + (* XXX what about abbreviations in Tconstr ? *) + iter_type_expr (update_level env level expand) ty + end + +(* First try without expanding, then expand everything, + to avoid combinatorial blow-up *) +let update_level env level ty = + if get_level ty > level then begin + let snap = snapshot () in + try + update_level env level false ty + with Escape _ -> + backtrack snap; + update_level env level true ty + end + +let update_level_for tr_exn env level ty = + try + update_level env level ty + with Escape e -> raise_for tr_exn (Escape e) + +(* Lower level of type variables inside contravariant branches *) + +let rec lower_contravariant env var_level visited contra ty = + let must_visit = + get_level ty > var_level && + match Hashtbl.find visited (get_id ty) with + | done_contra -> contra && not done_contra + | exception Not_found -> true + in + if must_visit then begin + Hashtbl.add visited (get_id ty) contra; + let lower_rec = lower_contravariant env var_level visited in + match get_desc ty with + Tvar _ -> if contra then set_level ty var_level + | Tconstr (_, [], _) -> () + | Tconstr (path, tyl, _abbrev) -> + let variance, maybe_expand = + try + let typ = Env.find_type path env in + typ.type_variance, + type_kind_is_abstract typ + with Not_found -> + (* See testsuite/tests/typing-missing-cmi-2 for an example *) + List.map (fun _ -> Variance.unknown) tyl, + false + in + if List.for_all ((=) Variance.null) variance then () else + let not_expanded () = + List.iter2 + (fun v t -> + if v = Variance.null then () else + if Variance.(mem May_weak v) + then lower_rec true t + else lower_rec contra t) + variance tyl in + if maybe_expand then (* we expand cautiously to avoid missing cmis *) + match !forward_try_expand_safe env ty with + | ty -> lower_rec contra ty + | exception Cannot_expand -> not_expanded () + else not_expanded () + | Tpackage (_, fl) -> + List.iter (fun (_n, ty) -> lower_rec true ty) fl + | Tarrow (_, t1, t2, _) -> + lower_rec true t1; + lower_rec contra t2 + | _ -> + iter_type_expr (lower_rec contra) ty + end + +let lower_variables_only env level ty = + simple_abbrevs := Mnil; + lower_contravariant env level (Hashtbl.create 7) true ty + +let lower_contravariant env ty = + simple_abbrevs := Mnil; + lower_contravariant env !nongen_level (Hashtbl.create 7) false ty + +let rec generalize_class_type gen = + function + Cty_constr (_, params, cty) -> + List.iter gen params; + generalize_class_type gen cty + | Cty_signature csig -> + gen csig.csig_self; + gen csig.csig_self_row; + Vars.iter (fun _ (_, _, ty) -> gen ty) csig.csig_vars; + Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths + | Cty_arrow (_, ty, cty) -> + gen ty; + generalize_class_type gen cty + +(* Only generalize the type ty0 in ty *) +let limited_generalize ty0 ~inside:ty = + let graph = TypeHash.create 17 in + let roots = ref [] in + + let rec inverse pty ty = + match TypeHash.find_opt graph ty with + | Some parents -> parents := pty @ !parents + | None -> + let level = get_level ty in + if level > !current_level then begin + TypeHash.add graph ty (ref pty); + (* XXX: why generic_level needs to be a root *) + if (level = generic_level) || eq_type ty ty0 then + roots := ty :: !roots; + iter_type_expr (inverse [ty]) ty + end + in + + let rec generalize_parents ~is_root ty = + if is_root || get_level ty <> generic_level then begin + set_level ty generic_level; + List.iter (generalize_parents ~is_root:false) !(TypeHash.find graph ty); + (* Special case for rows: must generalize the row variable *) + match get_desc ty with + Tvariant row -> + let more = row_more row in + let lv = get_level more in + if (TypeHash.mem graph more || lv > !current_level) + && lv <> generic_level then set_level more generic_level + | _ -> () + end + in + + inverse [] ty; + List.iter (generalize_parents ~is_root:true) !roots; + TypeHash.iter + (fun ty _ -> + if get_level ty <> generic_level then set_level ty !current_level) + graph + +let limited_generalize_class_type rv ~inside:cty = + generalize_class_type (fun inside -> limited_generalize rv ~inside) cty + +(* Compute statically the free univars of all nodes in a type *) +(* This avoids doing it repeatedly during instantiation *) + +type inv_type_expr = + { inv_type : type_expr; + mutable inv_parents : inv_type_expr list } + +let rec inv_type hash pty ty = + try + let inv = TypeHash.find hash ty in + inv.inv_parents <- pty @ inv.inv_parents + with Not_found -> + let inv = { inv_type = ty; inv_parents = pty } in + TypeHash.add hash ty inv; + iter_type_expr (inv_type hash [inv]) ty + +let compute_univars ty = + let inverted = TypeHash.create 17 in + inv_type inverted [] ty; + let node_univars = TypeHash.create 17 in + let rec add_univar univ inv = + match get_desc inv.inv_type with + Tpoly (_ty, tl) when List.memq (get_id univ) (List.map get_id tl) -> () + | _ -> + try + let univs = TypeHash.find node_univars inv.inv_type in + if not (TypeSet.mem univ !univs) then begin + univs := TypeSet.add univ !univs; + List.iter (add_univar univ) inv.inv_parents + end + with Not_found -> + TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ)); + List.iter (add_univar univ) inv.inv_parents + in + TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) + inverted; + fun ty -> + try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty + + +let fully_generic ty = + with_type_mark begin fun mark -> + let rec aux ty = + if try_mark_node mark ty then + if get_level ty = generic_level then iter_type_expr aux ty + else raise Exit + in + try aux ty; true with Exit -> false + end + + + (*******************) + (* Instantiation *) + (*******************) + + +let rec find_repr p1 = + function + Mnil -> + None + | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> + Some ty + | Mcons (_, _, _, _, rem) -> + find_repr p1 rem + | Mlink {contents = rem} -> + find_repr p1 rem + +(* + Generic nodes are duplicated, while non-generic nodes are left + as-is. + + During instantiation, the result of copying a generic node is + "cached" in-place by temporarily mutating the node description by + a stub [Tsubst (newvar ())] using [For_copy.redirect_desc]. The + scope of this mutation is determined by the [copy_scope] parameter, + and the [For_copy.with_scope] helper is in charge of creating a new + scope and performing the necessary book-keeping -- in particular + reverting the in-place updates after the instantiation is done. *) + +let abbreviations = ref (ref Mnil) + (* Abbreviation memorized. *) + +(* partial: we may not wish to copy the non generic types + before we call type_pat *) +let rec copy ?partial ?keep_names copy_scope ty = + let copy = copy ?partial ?keep_names copy_scope in + match get_desc ty with + Tsubst (ty, _) -> ty + | desc -> + let level = get_level ty in + if level <> generic_level && partial = None then ty else + (* We only forget types that are non generic and do not contain + free univars *) + let forget = + if level = generic_level then generic_level else + match partial with + None -> assert false + | Some (free_univars, keep) -> + if TypeSet.is_empty (free_univars ty) then + if keep then level else !current_level + else generic_level + in + if forget <> generic_level then newty2 ~level:forget (Tvar None) else + let t = newstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let desc' = + match desc with + | Tconstr (p, tl, _) -> + let abbrevs = proper_abbrevs tl !abbreviations in + begin match find_repr p !abbrevs with + Some ty when not (eq_type ty t) -> + Tlink ty + | _ -> + (* + One must allocate a new reference, so that abbrevia- + tions belonging to different branches of a type are + independent. + Moreover, a reference containing a [Mcons] must be + shared, so that the memorized expansion of an abbrevi- + ation can be released by changing the content of just + one reference. + *) + Tconstr (p, List.map copy tl, + ref (match !(!abbreviations) with + Mcons _ -> Mlink !abbreviations + | abbrev -> abbrev)) + end + | Tvariant row -> + let more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + (* If the row variable is not generic, we must keep it *) + let keep = get_level more <> generic_level && partial = None in + let more' = + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) + | Tconstr _ | Tnil -> + copy more + | Tvar _ | Tunivar _ -> + if keep then more else newty mored + | _ -> assert false + in + let row = + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~fixed:(Some (Reified x)) + | _ -> row + in + (* Open row if partial for pattern and contains Reither *) + let more', row = + match partial with + Some (free_univars, false) -> + let not_reither (_, f) = + match row_field_repr f with + Reither _ -> false + | _ -> true + in + let fields = row_fields row in + if row_closed row && not (is_fixed row) + && TypeSet.is_empty (free_univars ty) + && not (List.for_all not_reither fields) then + let more' = newvar () in + (more', + create_row ~fields:(List.filter not_reither fields) + ~more:more' ~closed:false ~fixed:None ~name:None) + else (more', row) + | _ -> (more', row) + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst(more', Some t)); + (* Return a new copy *) + Tvariant (copy_row copy true row keep more') + end + | Tobject (ty1, _) when partial <> None -> + Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc + in + Transient_expr.set_stub_desc t desc'; + t + +(**** Variants of instantiations ****) + +let instance ?partial sch = + let partial = + match partial with + None -> None + | Some keep -> Some (compute_univars sch, keep) + in + For_copy.with_scope (fun copy_scope -> + copy ?partial copy_scope sch) + +let generic_instance sch = + with_level ~level:generic_level (fun () -> instance sch) + +let instance_list schl = + For_copy.with_scope (fun copy_scope -> + List.map (fun t -> copy copy_scope t) schl) + +(* Create unique names to new type constructors. + Used for existential types and local constraints. *) +let get_new_abstract_name env s = + let name index = + if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else + Printf.sprintf "%s%d" s index + in + let check index = + match Env.find_type_by_name (Longident.Lident (name index)) env with + | _ -> false + | exception Not_found -> true + in + let index = Misc.find_first_mono check in + name index + +let new_local_type ?(loc = Location.none) ?manifest_and_scope origin = + let manifest, expansion_scope = + match manifest_and_scope with + None -> None, Btype.lowest_level + | Some (ty, scope) -> Some ty, scope + in + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract origin; + type_private = Public; + type_manifest = manifest; + type_variance = []; + type_separability = []; + type_is_newtype = true; + type_expansion_scope = expansion_scope; + type_loc = loc; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + +let existential_name name_counter ty = + let name = + match get_desc ty with + | Tvar (Some name) -> name + | _ -> + let name = Misc.letter_of_int !name_counter in + incr name_counter; + name + in + "$" ^ name + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of Pattern_env.t + +let instance_constructor existential_treatment cstr = + For_copy.with_scope (fun copy_scope -> + let name_counter = ref 0 in + let copy_existential = + match existential_treatment with + | Keep_existentials_flexible -> copy copy_scope + | Make_existentials_abstract penv -> + fun existential -> + let env = penv.env in + let fresh_constr_scope = penv.equations_scope in + let decl = new_local_type (Existential cstr.cstr_name) in + let name = existential_name name_counter existential in + let (id, new_env) = + Env.enter_type (get_new_abstract_name env name) decl env + ~scope:fresh_constr_scope in + Pattern_env.set_env penv new_env; + let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in + let tv = copy copy_scope existential in + assert (is_Tvar tv); + link_type tv to_unify; + tv + in + let ty_ex = List.map copy_existential cstr.cstr_existentials in + let ty_res = copy copy_scope cstr.cstr_res in + let ty_args = List.map (copy copy_scope) cstr.cstr_args in + (ty_args, ty_res, ty_ex) + ) + +let instance_parameterized_type ?keep_names sch_args sch = + For_copy.with_scope (fun copy_scope -> + let ty_args = List.map (fun t -> copy ?keep_names copy_scope t) sch_args in + let ty = copy copy_scope sch in + (ty_args, ty) + ) + +let map_kind f = function + | Type_abstract r -> Type_abstract r + | Type_open -> Type_open + | Type_variant (cl, rep) -> + Type_variant ( + List.map + (fun c -> + {c with + cd_args = map_type_expr_cstr_args f c.cd_args; + cd_res = Option.map f c.cd_res + }) + cl, rep) + | Type_record (fl, rr) -> + Type_record ( + List.map + (fun l -> + {l with ld_type = f l.ld_type} + ) fl, rr) + + +let instance_declaration decl = + For_copy.with_scope (fun copy_scope -> + {decl with type_params = List.map (copy copy_scope) decl.type_params; + type_manifest = Option.map (copy copy_scope) decl.type_manifest; + type_kind = map_kind (copy copy_scope) decl.type_kind; + } + ) + +let generic_instance_declaration decl = + with_level ~level:generic_level (fun () -> instance_declaration decl) + +let instance_class params cty = + let rec copy_class_type copy_scope = function + | Cty_constr (path, tyl, cty) -> + let tyl' = List.map (copy copy_scope) tyl in + let cty' = copy_class_type copy_scope cty in + Cty_constr (path, tyl', cty') + | Cty_signature sign -> + Cty_signature + {csig_self = copy copy_scope sign.csig_self; + csig_self_row = copy copy_scope sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, ty) -> (m, v, copy copy_scope ty)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, ty) -> (p, v, copy copy_scope ty)) + sign.csig_meths} + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, copy copy_scope ty, copy_class_type copy_scope cty) + in + For_copy.with_scope (fun copy_scope -> + let params' = List.map (copy copy_scope) params in + let cty' = copy_class_type copy_scope cty in + (params', cty') + ) + +(**** Instantiation for types with free universal variables ****) + +(* [copy_sep] is used to instantiate first-class polymorphic types. + * It first makes a separate copy of the type as a graph, omitting nodes + that have no free univars. + * In this first pass, [visited] is used as a mapping for previously visited + nodes, and must already contain all the free univars in [ty]. + * The remaining (univar-closed) parts of the type are then instantiated + with [copy] using a common [copy_scope]. + The reason to work in two passes lies in recursive types such as: + [let h (x : < m : 'a. < n : 'a; p : 'b > > as 'b) = x#m] + The type of [x#m] should be: + [ < n : 'c; p : < m : 'a. < n : 'a; p : 'b > > as 'b > ] + I.e., the universal type variable ['a] is both instantiated as a fresh + type variable ['c] when outside of its binder, and kept as universal + when under its binder. + Assumption: in the first call to [copy_sep], all the free univars should + be bound by the same [Tpoly] node. This guarantees that they are only + bound when under this [Tpoly] node, which has no free univars, and as + such is not part of the separate copy. In turn, this allows the separate + copy to keep the sharing of the original type without breaking its + binding structure. + *) +let copy_sep ~copy_scope ~fixed ~(visited : type_expr TypeHash.t) sch = + let free = compute_univars sch in + let delayed_copies = ref [] in + let add_delayed_copy t ty = + delayed_copies := + (fun () -> Transient_expr.set_stub_desc t (Tlink (copy copy_scope ty))) :: + !delayed_copies + in + let rec copy_rec ~may_share (ty : type_expr) = + let univars = free ty in + if is_Tvar ty || may_share && TypeSet.is_empty univars then + if get_level ty <> generic_level then ty else + let t = newstub ~scope:(get_scope ty) in + add_delayed_copy t ty; + t + else try + TypeHash.find visited ty + with Not_found -> begin + let t = newstub ~scope:(get_scope ty) in + TypeHash.add visited ty t; + let desc' = + match get_desc ty with + | Tvariant row -> + let more = row_more row in + (* We shall really check the level on the row variable *) + let keep = is_Tvar more && get_level more <> generic_level in + (* In that case we should keep the original, but we still + call copy to correct the levels *) + if keep then (add_delayed_copy t ty; Tvar None) else + let more' = copy_rec ~may_share:false more in + let fixed' = fixed && (is_Tvar more || is_Tunivar more) in + let row = + copy_row (copy_rec ~may_share:true) fixed' row keep more' in + Tvariant row + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared, see Btype.copy_type_desc *) + Tfield (p, field_kind_internal_repr k, + copy_rec ~may_share:true ty1, + copy_rec ~may_share:false ty2) + | desc -> copy_type_desc (copy_rec ~may_share:true) desc + in + Transient_expr.set_stub_desc t desc'; + t + end + in + let ty = copy_rec ~may_share:true sch in + List.iter (fun force -> force ()) !delayed_copies; + ty + +let instance_poly' copy_scope ~keep_names ~fixed univars sch = + (* In order to compute univars below, [sch] should not contain [Tsubst] *) + let copy_var ty = + match get_desc ty with + Tunivar name -> if keep_names then newty (Tvar name) else newvar () + | _ -> assert false + in + let vars = List.map copy_var univars in + let visited = TypeHash.create 17 in + List.iter2 (TypeHash.add visited) univars vars; + let ty = copy_sep ~copy_scope ~fixed ~visited sch in + vars, ty + +let instance_poly ?(keep_names=false) ~fixed univars sch = + For_copy.with_scope (fun copy_scope -> + instance_poly' copy_scope ~keep_names ~fixed univars sch + ) + +let instance_label ~fixed lbl = + For_copy.with_scope (fun copy_scope -> + let vars, ty_arg = + match get_desc lbl.lbl_arg with + Tpoly (ty, tl) -> + instance_poly' copy_scope ~keep_names:false ~fixed tl ty + | _ -> + [], copy copy_scope lbl.lbl_arg + in + (* call [copy] after [instance_poly] to avoid introducing [Tsubst] *) + let ty_res = copy copy_scope lbl.lbl_res in + (vars, ty_arg, ty_res) + ) + +(**** Instantiation with parameter substitution ****) + +(* NB: since this is [unify_var], it raises [Unify], not [Unify_trace] *) +let unify_var' = (* Forward declaration *) + ref (fun _env _ty1 _ty2 -> assert false) + +let subst env level priv abbrev oty params args body = + if List.length params <> List.length args then raise Cannot_subst; + with_level ~level begin fun () -> + let body0 = newvar () in (* Stub *) + let undo_abbrev = + match oty with + | None -> fun () -> () (* No abbreviation added *) + | Some ty -> + match get_desc ty with + Tconstr (path, tl, _) -> + let abbrev = proper_abbrevs tl abbrev in + memorize_abbrev abbrev priv path ty body0; + fun () -> forget_abbrev abbrev path + | _ -> assert false + in + abbreviations := abbrev; + let (params', body') = instance_parameterized_type params body in + abbreviations := ref Mnil; + let uenv = Expression {env; in_subst = true} in + try + !unify_var' uenv body0 body'; + List.iter2 (!unify_var' uenv) params' args; + body' + with Unify _ -> + undo_abbrev (); + raise Cannot_subst + end + +(* + Default to generic level. Usually, only the shape of the type matters, not + whether it is generic or not. [generic_level] might be somewhat slower, but + it ensures invariants on types are enforced (decreasing levels), and we don't + care about efficiency here. +*) +let apply ?(use_current_level = false) env params body args = + simple_abbrevs := Mnil; + let level = if use_current_level then !current_level else generic_level in + try + subst env level Public (ref Mnil) None params args body + with + Cannot_subst -> raise Cannot_apply + + (****************************) + (* Abbreviation expansion *) + (****************************) + +(* + If the environment has changed, memorized expansions might not + be correct anymore, and so we flush the cache. The test used + checks whether any of types, modules, or local constraints have + been changed. +*) +let previous_env = ref Env.empty +(*let string_of_kind = function Public -> "public" | Private -> "private"*) +let check_abbrev_env env = + if not (Env.same_type_declarations env !previous_env) then begin + (* prerr_endline "cleanup expansion cache"; *) + cleanup_abbrev (); + previous_env := env + end + + +(* Expand an abbreviation. The expansion is memorized. *) +(* + Assume the level is greater than the path binding time of the + expanded abbreviation. +*) +(* + An abbreviation expansion will fail in either of these cases: + 1. The type constructor does not correspond to a manifest type. + 2. The type constructor is defined in an external file, and this + file is not in the path (missing -I options). + 3. The type constructor is not in the "local" environment. This can + happens when a non-generic type variable has been instantiated + afterwards to the not yet defined type constructor. (Actually, + this cannot happen at the moment due to the strong constraints + between type levels and constructor binding time.) + 4. The expansion requires the expansion of another abbreviation, + and this other expansion fails. +*) +let expand_abbrev_gen kind find_type_expansion env ty = + let path, args, abbrev = match get_desc ty with + | Tconstr (path,args,abbrev) -> path, args, abbrev + | _ -> assert false + in + check_abbrev_env env; + let level = get_level ty in + let scope = get_scope ty in + let lookup_abbrev = proper_abbrevs args abbrev in + let expansion = + (* first look for an existing expansion *) + match find_expans kind path !lookup_abbrev with + | None -> None + | Some ty' -> try + (* prerr_endline + ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) + if level <> generic_level then update_level env level ty'; + update_scope scope ty'; + Some ty' + with Escape _ -> + (* in case of Escape, discard the stale expansion and re-expand *) + forget_abbrev lookup_abbrev path; + None + in + begin match expansion with + | Some ty' -> ty' + | None -> + (* attempt to (re-)expand *) + match find_type_expansion path env with + | exception Not_found -> + (* another way to expand is to normalize the path itself *) + let path' = Env.normalize_type_path None env path in + if Path.same path path' then raise Cannot_expand + else newty2 ~level (Tconstr (path', args, abbrev)) + | (params, body, lv) -> + (* prerr_endline + ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) + let ty' = + try + subst env level kind abbrev (Some ty) params args body + with Cannot_subst -> raise_escape_exn Constraint + in + (* For gadts, remember type as non exportable *) + (* The ambiguous level registered for ty' should be the highest *) + (* if !trace_gadt_instances then begin *) + let scope = Int.max lv (get_scope ty) in + update_scope scope ty; + update_scope scope ty'; + ty' + end + +(* Expand respecting privacy *) +let expand_abbrev env ty = + expand_abbrev_gen Public Env.find_type_expansion env ty + +(* Expand once the head of a type *) +let expand_head_once env ty = + try + expand_abbrev env ty + with Cannot_expand | Escape _ -> assert false + +(* Check whether a type can be expanded *) +let safe_abbrev env ty = + let snap = Btype.snapshot () in + try ignore (expand_abbrev env ty); true with + Cannot_expand -> + Btype.backtrack snap; + false + | Escape _ -> + Btype.backtrack snap; + cleanup_abbrev (); + false + +(* Expand the head of a type once. + Raise Cannot_expand if the type cannot be expanded. + May raise Escape, if a recursion was hidden in the type. *) +let try_expand_once env ty = + match get_desc ty with + Tconstr _ -> expand_abbrev env ty + | _ -> raise Cannot_expand + +(* This one only raises Cannot_expand *) +let try_expand_safe env ty = + let snap = Btype.snapshot () in + try try_expand_once env ty + with Escape _ -> + Btype.backtrack snap; cleanup_abbrev (); raise Cannot_expand + +(* Fully expand the head of a type. *) +let rec try_expand_head + (try_once : Env.t -> type_expr -> type_expr) env ty = + let ty' = try_once env ty in + try try_expand_head try_once env ty' + with Cannot_expand -> ty' + +(* Unsafe full expansion, may raise [Unify [Escape _]]. *) +let expand_head_unif env ty = + try + try_expand_head try_expand_once env ty + with + | Cannot_expand -> ty + | Escape e -> raise_for Unify (Escape e) + +(* Safe version of expand_head, never fails *) +let expand_head env ty = + try try_expand_head try_expand_safe env ty + with Cannot_expand -> ty + +let _ = forward_try_expand_safe := try_expand_safe + + +(* Expand until we find a non-abstract type declaration, + use try_expand_safe to avoid raising "Unify _" when + called on recursive types + *) + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + | Has_no_typedecl + | May_have_typedecl + +let rec extract_concrete_typedecl env ty = + match get_desc ty with + Tconstr (p, _, _) -> + begin match Env.find_type p env with + | exception Not_found -> May_have_typedecl + | decl -> + if not (type_kind_is_abstract decl) then Typedecl(p, p, decl) + else begin + match try_expand_safe env ty with + | exception Cannot_expand -> May_have_typedecl + | ty -> + match extract_concrete_typedecl env ty with + | Typedecl(_, p', decl) -> Typedecl(p, p', decl) + | Has_no_typedecl -> Has_no_typedecl + | May_have_typedecl -> May_have_typedecl + end + end + | Tpoly(ty, _) -> extract_concrete_typedecl env ty + | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil + | Tvariant _ | Tpackage _ -> Has_no_typedecl + | Tvar _ | Tunivar _ -> May_have_typedecl + | Tlink _ | Tsubst _ -> assert false + +(* Implementing function [expand_head_opt], the compiler's own version of + [expand_head] used for type-based optimisations. + [expand_head_opt] uses [Env.find_type_expansion_opt] to access the + manifest type information of private abstract data types which is + normally hidden to the type-checker out of the implementation module of + the private abbreviation. *) + +let expand_abbrev_opt env ty = + expand_abbrev_gen Private Env.find_type_expansion_opt env ty + +let safe_abbrev_opt env ty = + let snap = Btype.snapshot () in + try ignore (expand_abbrev_opt env ty); true + with Cannot_expand | Escape _ -> + Btype.backtrack snap; + false + +let try_expand_once_opt env ty = + match get_desc ty with + Tconstr _ -> expand_abbrev_opt env ty + | _ -> raise Cannot_expand + +let try_expand_safe_opt env ty = + let snap = Btype.snapshot () in + try try_expand_once_opt env ty + with Escape _ -> + Btype.backtrack snap; raise Cannot_expand + +let expand_head_opt env ty = + try try_expand_head try_expand_safe_opt env ty with Cannot_expand -> ty + +(* Recursively expand the head of a type. + Also expand #-types. + + Error printing relies on [full_expand] returning exactly its input (i.e., a + physically equal type) when nothing changes. *) +let full_expand ~may_forget_scope env ty = + let ty = + if may_forget_scope then + try expand_head_unif env ty with Unify_trace _ -> + (* #10277: forget scopes when printing trace *) + with_level ~level:(get_level ty) begin fun () -> + (* The same as [expand_head], except in the failing case we return the + *original* type, not [duplicate_type ty].*) + try try_expand_head try_expand_safe env (duplicate_type ty) with + | Cannot_expand -> ty + end + else expand_head env ty + in + match get_desc ty with + Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar v -> + newty2 ~level:(get_level ty) (Tobject (fi, ref None)) + | _ -> + ty + +(* + Check whether the abbreviation expands to a well-defined type. + During the typing of a class, abbreviations for correspondings + types expand to non-generic types. +*) +let generic_abbrev env path = + try + let (_, body, _) = Env.find_type_expansion path env in + get_level body = generic_level + with + Not_found -> + false + +let generic_private_abbrev env path = + try + match Env.find_type path env with + {type_kind = Type_abstract _; + type_private = Private; + type_manifest = Some body} -> + get_level body = generic_level + | _ -> false + with Not_found -> false + +let is_contractive env p = + try + let decl = Env.find_type p env in + in_pervasives p && decl.type_manifest = None || is_datatype decl + with Not_found -> false + + + (*****************) + (* Occur check *) + (*****************) + + +exception Occur + +let rec occur_rec env allow_recursive visited ty0 ty = + if eq_type ty ty0 then raise Occur; + match get_desc ty with + Tconstr(p, _tl, _abbrev) -> + if allow_recursive && is_contractive env p then () else + begin try + if TypeSet.mem ty visited then raise Occur; + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty + with Occur -> try + let ty' = try_expand_head try_expand_safe env ty in + (* This call used to be inlined, but there seems no reason for it. + Message was referring to change in rev. 1.58 of the CVS repo. *) + occur_rec env allow_recursive visited ty0 ty' + with Cannot_expand -> + raise Occur + end + | Tobject _ | Tvariant _ -> + () + | _ -> + if allow_recursive || TypeSet.mem ty visited then () else begin + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty + end + +let type_changed = ref false (* trace possible changes to the studied type *) + +let merge r b = if b then r := true + +let occur uenv ty0 ty = + let env = get_env uenv in + let allow_recursive = allow_recursive_equations uenv in + let old = !type_changed in + try + while + type_changed := false; + if not (eq_type ty0 ty) then + occur_rec env allow_recursive TypeSet.empty ty0 ty; + !type_changed + do () (* prerr_endline "changed" *) done; + merge type_changed old + with exn -> + merge type_changed old; + raise exn + +let occur_for tr_exn uenv t1 t2 = + try + occur uenv t1 t2 + with Occur -> raise_for tr_exn (Rec_occur(t1, t2)) + +let occur_in env ty0 t = + try occur (Expression {env; in_subst = false}) ty0 t; false with Occur -> true + +(* Check that a local constraint is well-founded *) +(* PR#6405: not needed since we allow recursion and work on normalized types *) +(* PR#6992: we actually need it for contractiveness *) +(* This is a simplified version of occur, only for the rectypes case *) + +let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty = + (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*) + if not (List.memq (get_id ty) visited) then begin + match get_desc ty with + Tconstr(p', args, _abbrev) -> + if Path.same p p' then raise Occur; + if allow_rec && not strict && is_contractive env p' then () else + let visited = get_id ty :: visited in + begin try + (* try expanding, since [p] could be hidden *) + local_non_recursive_abbrev ~allow_rec strict visited env p + (try_expand_head try_expand_safe_opt env ty) + with Cannot_expand -> + let params = + try (Env.find_type p' env).type_params + with Not_found -> args + in + List.iter2 + (fun tv ty -> + let strict = strict || not (is_Tvar tv) in + local_non_recursive_abbrev ~allow_rec strict visited env p ty) + params args + end + | Tobject _ | Tvariant _ when not strict -> + () + | _ -> + if strict || not allow_rec then (* PR#7374 *) + let visited = get_id ty :: visited in + iter_type_expr + (local_non_recursive_abbrev ~allow_rec true visited env p) ty + end + +let local_non_recursive_abbrev uenv p ty = + let env = get_env uenv in + let allow_rec = allow_recursive_equations uenv in + try (* PR#7397: need to check trace_gadt_instances *) + wrap_trace_gadt_instances env + (local_non_recursive_abbrev ~allow_rec false [] env p) ty; + true + with Occur -> false + + + (*****************************) + (* Polymorphic Unification *) + (*****************************) + +(* Polymorphic unification is hard in the presence of recursive types. A + correctness argument for the approach below can be made by reference to + "Numbering matters: first-order canonical forms for second-order recursive + types" (ICFP'04) by Gauthier & Pottier. That work describes putting numbers + on nodes; we do not do that here, but instead make a decision about whether + to abort or continue based on the comparison of the numbers if we calculated + them. A different approach would actually store the relevant numbers in the + [Tpoly] nodes. (The algorithm here actually pre-dates that paper, which was + developed independently. But reading and understanding the paper will help + guide intuition for reading this algorithm nonetheless.) *) + +(* Since we cannot duplicate universal variables, unification must + be done at meta-level, using bindings in univar_pairs *) +let rec unify_univar t1 t2 = function + (cl1, cl2) :: rem -> + let find_univ t cl = + List.find_map (fun (t', r) -> + if eq_type t t' then Some r else None + ) cl + in + begin match find_univ t1 cl1, find_univ t2 cl2 with + Some {contents=Some t'2}, Some _ when eq_type t2 t'2 -> + () + | Some({contents=None} as r1), Some({contents=None} as r2) -> + set_univar r1 t2; set_univar r2 t1 + | None, None -> + unify_univar t1 t2 rem + | _ -> + raise Cannot_unify_universal_variables + end + | [] -> + Misc.fatal_error "Ctype.unify_univar: univar not in scope" + +(* The same as [unify_univar], but raises the appropriate exception instead of + [Cannot_unify_universal_variables] *) +let unify_univar_for tr_exn t1 t2 univar_pairs = + try unify_univar t1 t2 univar_pairs + with Cannot_unify_universal_variables -> raise_unexplained_for tr_exn + +(* Test the occurrence of free univars in a type *) +(* That's way too expensive. Must do some kind of caching *) +(* If [inj_only=true], only check injective positions *) +let occur_univar ?(inj_only=false) env ty = + let visited = ref TypeMap.empty in + with_type_mark begin fun mark -> + let rec occur_rec bound ty = + if not_marked_node mark ty then + if TypeSet.is_empty bound then + (ignore (try_mark_node mark ty); occur_desc bound ty) + else try + let bound' = TypeMap.find ty !visited in + if not (TypeSet.subset bound' bound) then begin + visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; + occur_desc bound ty + end + with Not_found -> + visited := TypeMap.add ty bound !visited; + occur_desc bound ty + and occur_desc bound ty = + match get_desc ty with + Tunivar _ -> + if not (TypeSet.mem ty bound) then + raise_escape_exn (Univ ty) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add tyl bound in + occur_rec bound ty + | Tconstr (_, [], _) -> () + | Tconstr (p, tl, _) -> + begin try + let td = Env.find_type p env in + List.iter2 + (fun t v -> + (* The null variance only occurs in type abbreviations and + corresponds to type variables that do not occur in the + definition (expansion would erase them completely). + The type-checker consistently ignores type expressions + in this position. Physical expansion, as done in `occur`, + would be costly here, since we need to check inside + object and variant types too. *) + if Variance.(if inj_only then mem Inj v else not (eq v null)) + then occur_rec bound t) + tl td.type_variance + with Not_found -> + if not inj_only then List.iter (occur_rec bound) tl + end + | _ -> iter_type_expr (occur_rec bound) ty + in + occur_rec TypeSet.empty ty + end + +let has_free_univars env ty = + try occur_univar ~inj_only:false env ty; false with Escape _ -> true +let has_injective_univars env ty = + try occur_univar ~inj_only:true env ty; false with Escape _ -> true + +let occur_univar_for tr_exn env ty = + try + occur_univar env ty + with Escape e -> raise_for tr_exn (Escape e) + +(* Grouping univars by families according to their binders *) +let add_univars = + List.fold_left (fun s (t,_) -> TypeSet.add t s) + +let get_univar_family univar_pairs univars = + if univars = [] then TypeSet.empty else + let insert s = function + cl1, (_::_ as cl2) -> + if List.exists (fun (t1,_) -> TypeSet.mem t1 s) cl1 then + add_univars s cl2 + else s + | _ -> s + in + let s = List.fold_right TypeSet.add univars TypeSet.empty in + List.fold_left insert s univar_pairs + +(* Whether a family of univars escapes from a type *) +let univars_escape env univar_pairs vl ty = + let family = get_univar_family univar_pairs vl in + with_type_mark begin fun mark -> + let rec occur t = + if try_mark_node mark t then begin + match get_desc t with + Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem t family) tl then () + else occur t + | Tunivar _ -> if TypeSet.mem t family then raise_escape_exn (Univ t) + | Tconstr (_, [], _) -> () + | Tconstr (p, tl, _) -> + begin try + let td = Env.find_type p env in + List.iter2 + (* see occur_univar *) + (fun t v -> if not Variance.(eq v null) then occur t) + tl td.type_variance + with Not_found -> + List.iter occur tl + end + | _ -> + iter_type_expr occur t + end + in + occur ty + end + +let univar_pairs = ref [] + +let with_univar_pairs pairs f = + let old = !univar_pairs in + univar_pairs := pairs; + Misc.try_finally f + ~always:(fun () -> univar_pairs := old) + +(* Wrapper checking that no variable escapes and updating univar_pairs *) +let enter_poly env t1 tl1 t2 tl2 f = + let old_univars = !univar_pairs in + let known_univars = + List.fold_left (fun s (cl,_) -> add_univars s cl) + TypeSet.empty old_univars + in + if List.exists (fun t -> TypeSet.mem t known_univars) tl1 then + univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2))); + if List.exists (fun t -> TypeSet.mem t known_univars) tl2 then + univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1))); + let cl1 = List.map (fun t -> t, ref None) tl1 + and cl2 = List.map (fun t -> t, ref None) tl2 in + with_univar_pairs + ((cl1,cl2) :: (cl2,cl1) :: old_univars) + (fun () -> f t1 t2) + +let enter_poly_for tr_exn env t1 tl1 t2 tl2 f = + try + enter_poly env t1 tl1 t2 tl2 f + with Escape e -> raise_for tr_exn (Escape e) + +(**** Instantiate a generic type into a poly type ***) + +let polyfy env ty vars = + let subst_univar copy_scope ty = + match get_desc ty with + | Tvar name when get_level ty = generic_level -> + let t = newty (Tunivar name) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + Some t + | _ -> None + in + (* need to expand twice? cf. Ctype.unify2 *) + let vars = List.map (expand_head env) vars in + let vars = List.map (expand_head env) vars in + For_copy.with_scope (fun copy_scope -> + let vars' = List.filter_map (subst_univar copy_scope) vars in + let ty = copy copy_scope ty in + let ty = newty2 ~level:(get_level ty) (Tpoly(ty, vars')) in + let complete = List.length vars = List.length vars' in + ty, complete + ) + +(* assumption: [ty] is fully generalized. *) +let reify_univars env ty = + let vars = free_variables ty in + let ty, _ = polyfy env ty vars in + ty + + (*****************) + (* Unification *) + (*****************) + + + +let rec has_cached_expansion p abbrev = + match abbrev with + Mnil -> false + | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem + | Mlink rem -> has_cached_expansion p !rem + +(**** Transform error trace ****) +(* +++ Move it to some other place ? *) +(* That's hard to do because it relies on the expansion machinery in Ctype, + but still might be nice. *) + +let expand_type env ty = + { ty = ty; + expanded = full_expand ~may_forget_scope:true env ty } + +let expand_any_trace map env trace = + map (expand_type env) trace + +let expand_trace env trace = + expand_any_trace Errortrace.map env trace + +let expand_subtype_trace env trace = + expand_any_trace Subtype.map env trace + +let expand_to_unification_error env trace = + unification_error ~trace:(expand_trace env trace) + +let expand_to_equality_error env trace subst = + equality_error ~trace:(expand_trace env trace) ~subst + +let expand_to_moregen_error env trace = + moregen_error ~trace:(expand_trace env trace) + +(* [expand_trace] and the [expand_to_*_error] functions take care of most of the + expansion in this file, but we occasionally need to build [Errortrace.error]s + in other ways/elsewhere, so we expose some machinery for doing so +*) + +(* Equivalent to [expand_trace env [Diff {got; expected}]] for a single + element *) +let expanded_diff env ~got ~expected = + Diff (map_diff (expand_type env) {got; expected}) + +(* Diff while transforming a [type_expr] into an [expanded_type] without + expanding *) +let unexpanded_diff ~got ~expected = + Diff (map_diff trivial_expansion {got; expected}) + +(**** Unification ****) + +(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) +let deep_occur t0 ty = + with_type_mark begin fun mark -> + let rec occur_rec ty = + if get_level ty >= get_level t0 && try_mark_node mark ty then begin + if eq_type ty t0 then raise Occur; + iter_type_expr occur_rec ty + end + in + try + occur_rec ty; false + with Occur -> + true + end + + +(* A local constraint can be added only if the rhs + of the constraint does not contain any Tvars. + They need to be removed using this function. + This function is called only in [Pattern] mode. *) +let reify uenv t = + let fresh_constr_scope = get_equations_scope uenv in + let create_fresh_constr lev name = + let name = match name with Some s -> "$'"^s | _ -> "$" in + let decl = new_local_type Definition in + let env = get_env uenv in + let new_name = + (* unique names are needed only for error messages *) + if in_counterexample uenv then name else get_new_abstract_name env name + in + let (id, new_env) = + Env.enter_type new_name decl env ~scope:fresh_constr_scope in + let path = Path.Pident id in + let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in + set_env uenv new_env; + path, t + in + let visited = ref TypeSet.empty in + let rec iterator ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + Tvar o -> + let level = get_level ty in + let path, t = create_fresh_constr level o in + link_type ty t; + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | Tvariant r -> + if not (static_row r) then begin + if is_fixed r then iterator (row_more r) else + let m = row_more r in + match get_desc m with + Tvar o -> + let level = get_level m in + let path, t = create_fresh_constr level o in + let row = + let fixed = Some (Reified path) in + create_row ~fields:[] ~more:t ~fixed + ~name:(row_name r) ~closed:(row_closed r) in + link_type m (newty2 ~level (Tvariant row)); + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | _ -> assert false + end; + iter_row iterator r + | _ -> + iter_type_expr iterator ty + end + in + iterator t + +let find_expansion_scope env path = + match Env.find_type path env with + | { type_manifest = None ; _ } | exception Not_found -> generic_level + | decl -> decl.type_expansion_scope + +let non_aliasable p decl = + (* in_pervasives p || (subsumed by in_current_module) *) + in_current_module p && not decl.type_is_newtype + +let is_instantiable env p = + try + let decl = Env.find_type p env in + type_kind_is_abstract decl && + decl.type_private = Public && + decl.type_arity = 0 && + decl.type_manifest = None && + not (non_aliasable p decl) + with Not_found -> false + + +let compatible_paths p1 p2 = + let open Predef in + Path.same p1 p2 || + Path.same p1 path_bytes && Path.same p2 path_string || + Path.same p1 path_string && Path.same p2 path_bytes + +(* Two labels are considered compatible under certain conditions. + - they are the same + - in classic mode, only optional labels are relavant + - in pattern mode, we act as if we were in classic mode. If not, interactions + with GADTs from files compiled in classic mode would be unsound. +*) +let compatible_labels ~in_pattern_mode l1 l2 = + l1 = l2 + || (!Clflags.classic || in_pattern_mode) + && not (is_optional l1 || is_optional l2) + +let eq_labels error_mode ~in_pattern_mode l1 l2 = + if not (compatible_labels ~in_pattern_mode l1 l2) then + raise_for error_mode (Function_label_mismatch {got=l1; expected=l2}) + +(* Check for datatypes carefully; see PR#6348 *) +let rec expands_to_datatype env ty = + match get_desc ty with + Tconstr (p, _, _) -> + begin try + is_datatype (Env.find_type p env) || + expands_to_datatype env (try_expand_safe env ty) + with Not_found | Cannot_expand -> false + end + | _ -> false + +(* [mcomp] tests if two types are "compatible" -- i.e., if they could ever + unify. (This is distinct from [eqtype], which checks if two types *are* + exactly the same.) This is used to decide whether GADT cases are + unreachable. It is broadly part of unification. *) + +(* mcomp type_pairs subst env t1 t2 does not raise an + exception if it is possible that t1 and t2 are actually + equal, assuming the types in type_pairs are equal and + that the mapping subst holds. + Assumes that both t1 and t2 do not contain any tvars + and that both their objects and variants are closed + *) + +let rec mcomp type_pairs env t1 t2 = + if eq_type t1 t2 then () else + match (get_desc t1, get_desc t2) with + | (Tvar _, _) + | (_, Tvar _) -> + () + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> + () + | _ -> + let t1' = expand_head_opt env t1 in + let t2' = expand_head_opt env t2 in + (* Expansion may have changed the representative of the types... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + | (Tvar _, _) + | (_, Tvar _) -> + () + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) + when compatible_labels ~in_pattern_mode:true l1 l2 -> + mcomp type_pairs env t1 t2; + mcomp type_pairs env u1 u2; + | (Ttuple tl1, Ttuple tl2) -> + mcomp_list type_pairs env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> + mcomp_type_decl type_pairs env p1 p2 tl1 tl2 + | (Tconstr (_, [], _), _) when has_injective_univars env t2' -> + raise_unexplained_for Unify + | (_, Tconstr (_, [], _)) when has_injective_univars env t1' -> + raise_unexplained_for Unify + | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> + begin try + let decl = Env.find_type p env in + if non_aliasable p decl || is_datatype decl then + raise Incompatible + with Not_found -> () + end + (* + | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 -> + mcomp_list type_pairs env tl1 tl2 + *) + | (Tpackage _, Tpackage _) -> () + | (Tvariant row1, Tvariant row2) -> + mcomp_row type_pairs env row1 row2 + | (Tobject (fi1, _), Tobject (fi2, _)) -> + mcomp_fields type_pairs env fi1 fi2 + | (Tfield _, Tfield _) -> (* Actually unused *) + mcomp_fields type_pairs env t1' t2' + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + mcomp type_pairs env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + (try + enter_poly env + t1 tl1 t2 tl2 (mcomp type_pairs env) + with Escape _ -> raise Incompatible) + | (Tunivar _, Tunivar _) -> + (try unify_univar t1' t2' !univar_pairs + with Cannot_unify_universal_variables -> raise Incompatible) + | (_, _) -> + raise Incompatible + end + +and mcomp_list type_pairs env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise Incompatible; + List.iter2 (mcomp type_pairs env) tl1 tl2 + +and mcomp_fields type_pairs env ty1 ty2 = + if not (concrete_object ty1 && concrete_object ty2) then assert false; + let (fields2, rest2) = flatten_fields ty2 in + let (fields1, rest1) = flatten_fields ty1 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let has_present = + List.exists (fun (_, k, _) -> field_kind_repr k = Fpublic) in + mcomp type_pairs env rest1 rest2; + if has_present miss1 && get_desc (object_row ty2) = Tnil + || has_present miss2 && get_desc (object_row ty1) = Tnil + then raise Incompatible; + List.iter + (function (_n, k1, t1, k2, t2) -> + mcomp_kind k1 k2; + mcomp type_pairs env t1 t2) + pairs + +and mcomp_kind k1 k2 = + let k1 = field_kind_repr k1 in + let k2 = field_kind_repr k2 in + match k1, k2 with + (Fpublic, Fabsent) + | (Fabsent, Fpublic) -> raise Incompatible + | _ -> () + +and mcomp_row type_pairs env row1 row2 = + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + let cannot_erase (_,f) = + match row_field_repr f with + Rpresent _ -> true + | Rabsent | Reither _ -> false + in + if row_closed row1 && List.exists cannot_erase r2 + || row_closed row2 && List.exists cannot_erase r1 then raise Incompatible; + List.iter + (fun (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _) | Rabsent) + | Rpresent (Some _), (Rpresent None | Reither (true, _, _) | Rabsent) + | (Reither (_, _::_, _) | Rabsent), Rpresent None + | (Reither (true, _, _) | Rabsent), Rpresent (Some _) -> + raise Incompatible + | Rpresent(Some t1), Rpresent(Some t2) -> + mcomp type_pairs env t1 t2 + | Rpresent(Some t1), Reither(false, tl2, _) -> + List.iter (mcomp type_pairs env t1) tl2 + | Reither(false, tl1, _), Rpresent(Some t2) -> + List.iter (mcomp type_pairs env t2) tl1 + | _ -> ()) + pairs + +and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = + try + let decl = Env.find_type p1 env in + let decl' = Env.find_type p2 env in + if compatible_paths p1 p2 then begin + let inj = + try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance + with Not_found -> List.map (fun _ -> false) tl1 + in + List.iter2 + (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2) + inj (List.combine tl1 tl2) + end else if non_aliasable p1 decl && non_aliasable p2 decl' then + raise Incompatible + else + match decl.type_kind, decl'.type_kind with + | Type_record (lst,r), Type_record (lst',r') when r = r' -> + mcomp_list type_pairs env tl1 tl2; + mcomp_record_description type_pairs env lst lst' + | Type_variant (v1,r), Type_variant (v2,r') when r = r' -> + mcomp_list type_pairs env tl1 tl2; + mcomp_variant_description type_pairs env v1 v2 + | Type_open, Type_open -> + mcomp_list type_pairs env tl1 tl2 + | Type_abstract _, Type_abstract _ -> () + | Type_abstract _, _ when not (non_aliasable p1 decl)-> () + | _, Type_abstract _ when not (non_aliasable p2 decl') -> () + | _ -> raise Incompatible + with Not_found -> () + +and mcomp_type_option type_pairs env t t' = + match t, t' with + None, None -> () + | Some t, Some t' -> mcomp type_pairs env t t' + | _ -> raise Incompatible + +and mcomp_variant_description type_pairs env xs ys = + let rec iter = fun x y -> + match x, y with + | c1 :: xs, c2 :: ys -> + mcomp_type_option type_pairs env c1.cd_res c2.cd_res; + begin match c1.cd_args, c2.cd_args with + | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2 + | Cstr_record l1, Cstr_record l2 -> + mcomp_record_description type_pairs env l1 l2 + | _ -> raise Incompatible + end; + if Ident.name c1.cd_id = Ident.name c2.cd_id + then iter xs ys + else raise Incompatible + | [],[] -> () + | _ -> raise Incompatible + in + iter xs ys + +and mcomp_record_description type_pairs env = + let rec iter x y = + match x, y with + | l1 :: xs, l2 :: ys -> + mcomp type_pairs env l1.ld_type l2.ld_type; + if Ident.name l1.ld_id = Ident.name l2.ld_id && + l1.ld_mutable = l2.ld_mutable + then iter xs ys + else raise Incompatible + | [], [] -> () + | _ -> raise Incompatible + in + iter + +let mcomp env t1 t2 = + mcomp (TypePairs.create 4) env t1 t2 + +let mcomp_for tr_exn env t1 t2 = + try + mcomp env t1 t2 + with Incompatible -> raise_unexplained_for tr_exn + +(* Real unification *) + +let find_lowest_level ty = + let lowest = ref generic_level in + with_type_mark begin fun mark -> + let rec find ty = + if try_mark_node mark ty then begin + let level = get_level ty in + if level < !lowest then lowest := level; + iter_type_expr find ty + end + in find ty + end; + !lowest + +(* This function can be called only in [Pattern] mode. *) +let add_gadt_equation uenv source destination = + (* Format.eprintf "@[add_gadt_equation %s %a@]@." + (Path.name source) !Btype.print_raw destination; *) + let env = get_env uenv in + if has_free_univars env destination then + occur_univar ~inj_only:true env destination + else if local_non_recursive_abbrev uenv source destination then begin + let destination = duplicate_type destination in + let expansion_scope = + Int.max (Path.scope source) (get_equations_scope uenv) + in + let type_origin = + match Env.find_type source env with + | decl -> type_origin decl + | exception Not_found -> assert false + in + let decl = + new_local_type + ~manifest_and_scope:(destination, expansion_scope) + type_origin + in + set_env uenv (Env.add_local_constraint source decl env); + cleanup_abbrev () + end + +let eq_package_path env p1 p2 = + Path.same p1 p2 || + Path.same (normalize_package_path env p1) (normalize_package_path env p2) + +let nondep_type' = ref (fun _ _ _ -> assert false) +let package_subtype = ref (fun _ _ _ _ _ -> assert false) + +exception Nondep_cannot_erase of Ident.t + +let rec concat_longident lid1 = + let open Longident in + function + Lident s -> Ldot (lid1, s) + | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s) + | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid) + +let nondep_instance env level id ty = + let ty = !nondep_type' env [id] ty in + if level = generic_level then duplicate_type ty else + with_level ~level (fun () -> instance ty) + +(* Find the type paths nl1 in the module type mty2, and add them to the + list (nl2, tl2). raise Not_found if impossible *) +let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = + (* This is morally WRONG: we're adding a (dummy) module without a scope in the + environment. However no operation which cares about levels/scopes is going + to happen while this module exists. + The only operations that happen are: + - Env.find_type_by_name + - nondep_instance + None of which check the scope. + + It'd be nice if we avoided creating such temporary dummy modules and broken + environments though. *) + let id2 = Ident.create_local "Pkg" in + let env' = Env.add_module id2 Mp_present mty2 env in + let rec complete fl1 fl2 = + match fl1, fl2 with + [], _ -> fl2 + | (n, _) :: nl, (n2, _ as nt2) :: ntl' when n >= n2 -> + nt2 :: complete (if n = n2 then nl else fl1) ntl' + | (n, _) :: nl, _ -> + let lid = concat_longident (Longident.Lident "Pkg") n in + match Env.find_type_by_name lid env' with + | (_, {type_arity = 0; type_kind = Type_abstract _; + type_private = Public; type_manifest = Some t2}) -> + begin match nondep_instance env' lv2 id2 t2 with + | t -> (n, t) :: complete nl fl2 + | exception Nondep_cannot_erase _ -> + if allow_absent then + complete nl fl2 + else + raise Exit + end + | (_, {type_arity = 0; type_kind = Type_abstract _; + type_private = Public; type_manifest = None}) + when allow_absent -> + complete nl fl2 + | _ -> raise Exit + | exception Not_found when allow_absent-> + complete nl fl2 + in + match complete fl1 fl2 with + | res -> res + | exception Exit -> raise Not_found + +(* raise Not_found rather than Unify if the module types are incompatible *) +let unify_package env unify_list lv1 p1 fl1 lv2 p2 fl2 = + let ntl2 = complete_type_list env fl1 lv2 (Mty_ident p2) fl2 + and ntl1 = complete_type_list env fl2 lv1 (Mty_ident p1) fl1 in + unify_list (List.map snd ntl1) (List.map snd ntl2); + if eq_package_path env p1 p2 then Ok () + else Result.bind + (!package_subtype env p1 fl1 p2 fl2) + (fun () -> !package_subtype env p2 fl2 p1 fl1) + +(* force unification in Reither when one side has a non-conjunctive type *) +(* Code smell: this could also be put in unification_environment. + Only modified by expand_head_rigid, but the corresponding unification + environment is built in subst. *) +let rigid_variants = ref false + +let unify1_var uenv t1 t2 = + assert (is_Tvar t1); + occur_for Unify uenv t1 t2; + let env = get_env uenv in + match occur_univar_for Unify env t2 with + | () -> + begin + try + update_level env (get_level t1) t2; + update_scope (get_scope t1) t2; + with Escape e -> + raise_for Unify (Escape e) + end; + link_type t1 t2; + true + | exception Unify_trace _ when in_pattern_mode uenv -> + false + +(* Called from unify3 *) +let unify3_var uenv t1' t2 t2' = + occur_for Unify uenv t1' t2; + match occur_univar_for Unify (get_env uenv) t2 with + | () -> link_type t1' t2 + | exception Unify_trace _ when in_pattern_mode uenv -> + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then begin + occur_univar ~inj_only:true (get_env uenv) t2'; + record_equation uenv t1' t2'; + end + +(* + 1. When unifying two non-abbreviated types, one type is made a link + to the other. When unifying an abbreviated type with a + non-abbreviated type, the non-abbreviated type is made a link to + the other one. When unifying to abbreviated types, these two + types are kept distincts, but they are made to (temporally) + expand to the same type. + 2. Abbreviations with at least one parameter are systematically + expanded. The overhead does not seem too high, and that way + abbreviations where some parameters does not appear in the + expansion, such as ['a t = int], are correctly handled. In + particular, for this example, unifying ['a t] with ['b t] keeps + ['a] and ['b] distincts. (Is it really important ?) + 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield + ['a t as 'a]. Indeed, the type variable would otherwise be lost. + This problem occurs for abbreviations expanding to a type + variable, but also to many other constrained abbreviations (for + instance, [(< x : 'a > -> unit) t = ]). The solution is + that, if an abbreviation is unified with some subpart of its + parameters, then the parameter actually does not get + abbreviated. It would be possible to check whether some + information is indeed lost, but it probably does not worth it. +*) + +let rec unify uenv t1 t2 = + (* First step: special cases (optimizations) *) + if unify_eq uenv t1 t2 then () else + let reset_tracing = check_trace_gadt_instances (get_env uenv) in + + try + type_changed := true; + begin match (get_desc t1, get_desc t2) with + (Tvar _, Tconstr _) when deep_occur t1 t2 -> + unify2 uenv t1 t2 + | (Tconstr _, Tvar _) when deep_occur t2 t1 -> + unify2 uenv t1 t2 + | (Tvar _, _) -> + if unify1_var uenv t1 t2 then () else unify2 uenv t1 t2 + | (_, Tvar _) -> + if unify1_var uenv t2 t1 then () else unify2 uenv t1 t2 + | (Tunivar _, Tunivar _) -> + unify_univar_for Unify t1 t2 !univar_pairs; + update_level_for Unify (get_env uenv) (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) + when Path.same p1 p2 + (* This optimization assumes that t1 does not expand to t2 + (and conversely), so we fall back to the general case + when any of the types has a cached expansion. *) + && not (has_cached_expansion p1 !a1 + || has_cached_expansion p2 !a2) -> + update_level_for Unify (get_env uenv) (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + | (Tconstr _, Tconstr _) when Env.has_local_constraints (get_env uenv) -> + unify2_rec uenv t1 t1 t2 t2 + | _ -> + unify2 uenv t1 t2 + end; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise_trace_for Unify (Diff {got = t1; expected = t2} :: trace) + +and unify2 uenv t1 t2 = unify2_expand uenv t1 t1 t2 t2 + +and unify2_rec uenv t10 t1 t20 t2 = + if unify_eq uenv t1 t2 then () else + try match (get_desc t1, get_desc t2) with + | (Tconstr (p1, tl1, a1), Tconstr (p2, tl2, a2)) -> + if Path.same p1 p2 && tl1 = [] && tl2 = [] + && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) + then begin + update_level_for Unify (get_env uenv) (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + end else + let env = get_env uenv in + if find_expansion_scope env p1 > find_expansion_scope env p2 + then unify2_rec uenv t10 t1 t20 (try_expand_safe env t2) + else unify2_rec uenv t10 (try_expand_safe env t1) t20 t2 + | _ -> + raise Cannot_expand + with Cannot_expand -> + unify2_expand uenv t10 t1 t20 t2 + +and unify2_expand uenv t1 t1' t2 t2' = + (* Second step: expansion of abbreviations *) + (* Expansion may change the representative of the types. *) + let env = get_env uenv in + ignore (expand_head_unif env t1'); + ignore (expand_head_unif env t2'); + let t1' = expand_head_unif env t1' in + let t2' = expand_head_unif env t2' in + let lv = Int.min (get_level t1') (get_level t2') in + let scope = Int.max (get_scope t1') (get_scope t2') in + update_level_for Unify env lv t2; + update_level_for Unify env lv t1; + update_scope_for Unify scope t2; + update_scope_for Unify scope t1; + if unify_eq uenv t1' t2' then () else + + let t1, t2 = + if !Clflags.principal + && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then + (* Expand abbreviations hiding a lower level *) + (* Should also do it for parameterized types, after unification... *) + (match get_desc t1 with Tconstr (_, [], _) -> t1' | _ -> t1), + (match get_desc t2 with Tconstr (_, [], _) -> t2' | _ -> t2) + else (t1, t2) + in + if unify_eq uenv t1 t1' || not (unify_eq uenv t2 t2') then + unify3 uenv t1 t1' t2 t2' + else + try unify3 uenv t2 t2' t1 t1' with Unify_trace trace -> + raise_trace_for Unify (swap_trace trace) + +and unify3 uenv t1 t1' t2 t2' = + (* Third step: truly unification *) + (* Assumes either [t1 == t1'] or [t2 != t2'] *) + let tt1' = Transient_expr.repr t1' in + let d1 = tt1'.desc and d2 = get_desc t2' in + let create_recursion = + (not (eq_type t2 t2')) && (deep_occur t1' t2) in + + begin match (d1, d2) with (* handle vars and univars specially *) + (Tunivar _, Tunivar _) -> + unify_univar_for Unify t1' t2' !univar_pairs; + link_type t1' t2' + | (Tvar _, _) -> + unify3_var uenv t1' t2 t2' + | (_, Tvar _) -> + unify3_var uenv t2' t1 t1' + | (Tfield _, Tfield _) -> (* special case for GADTs *) + unify_fields uenv t1' t2' + | _ -> + if in_pattern_mode uenv then + add_type_equality uenv t1' t2' + else begin + occur_for Unify uenv t1' t2; + link_type t1' t2 + end; + try + begin match (d1, d2) with + (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) -> + eq_labels Unify ~in_pattern_mode:(in_pattern_mode uenv) l1 l2; + unify uenv t1 t2; unify uenv u1 u2; + begin match is_commu_ok c1, is_commu_ok c2 with + | false, true -> set_commu_ok c1 + | true, false -> set_commu_ok c2 + | false, false -> link_commu ~inside:c1 c2 + | true, true -> () + end + | (Ttuple tl1, Ttuple tl2) -> + unify_list uenv tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> + if not (can_generate_equations uenv) then + unify_list uenv tl1 tl2 + else if can_assume_injective uenv then + without_assume_injective uenv (fun uenv -> unify_list uenv tl1 tl2) + else if in_current_module p1 (* || in_pervasives p1 *) + || List.exists (expands_to_datatype (get_env uenv)) [t1'; t1; t2] + then + unify_list uenv tl1 tl2 + else + let inj = + try List.map Variance.(mem Inj) + (Env.find_type p1 (get_env uenv)).type_variance + with Not_found -> List.map (fun _ -> false) tl1 + in + List.iter2 + (fun i (t1, t2) -> + if i then unify uenv t1 t2 else + without_generating_equations uenv + begin fun uenv -> + let snap = snapshot () in + try unify uenv t1 t2 with Unify_trace _ -> + backtrack snap; + reify uenv t1; + reify uenv t2 + end) + inj (List.combine tl1 tl2) + | (Tconstr (path,[],_), + Tconstr (path',[],_)) + when let env = get_env uenv in + is_instantiable env path && is_instantiable env path' + && can_generate_equations uenv -> + let source, destination = + if Path.scope path > Path.scope path' + then path , t2' + else path', t1' + in + record_equation uenv t1' t2'; + add_gadt_equation uenv source destination + | (Tconstr (path,[],_), _) + when is_instantiable (get_env uenv) path + && can_generate_equations uenv -> + reify uenv t2'; + record_equation uenv t1' t2'; + add_gadt_equation uenv path t2' + | (_, Tconstr (path,[],_)) + when is_instantiable (get_env uenv) path + && can_generate_equations uenv -> + reify uenv t1'; + record_equation uenv t1' t2'; + add_gadt_equation uenv path t1' + | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when in_pattern_mode uenv -> + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then ( + mcomp_for Unify (get_env uenv) t1' t2'; + record_equation uenv t1' t2' + ) + | (Tobject (fi1, nm1), Tobject (fi2, _)) -> + unify_fields uenv fi1 fi2; + (* Type [t2'] may have been instantiated by [unify_fields] *) + (* XXX One should do some kind of unification... *) + begin match get_desc t2' with + Tobject (_, {contents = Some (_, va::_)}) when + (match get_desc va with + Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () + | Tobject (_, nm2) -> set_name nm2 !nm1 + | _ -> () + end + | (Tvariant row1, Tvariant row2) -> + if not (in_pattern_mode uenv) then + unify_row uenv row1 row2 + else begin + let snap = snapshot () in + try unify_row uenv row1 row2 + with Unify_trace _ -> + backtrack snap; + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then ( + mcomp_for Unify (get_env uenv) t1' t2'; + record_equation uenv t1' t2' + ) + end + | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> + begin match field_kind_repr kind with + Fprivate when f <> dummy_method -> + link_kind ~inside:kind field_absent; + if d2 = Tnil then unify uenv rem t2' + else unify uenv (newgenty Tnil) rem + | _ -> + if f = dummy_method then + raise_for Unify (Obj Self_cannot_be_closed) + else if d1 = Tnil then + raise_for Unify (Obj (Missing_field(First, f))) + else + raise_for Unify (Obj (Missing_field(Second, f))) + end + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + unify uenv t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly_for Unify (get_env uenv) t1 tl1 t2 tl2 + (unify uenv) + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin match + unify_package (get_env uenv) (unify_list uenv) + (get_level t1) p1 fl1 (get_level t2) p2 fl2 + with + | Ok () -> () + | Error fm_err -> + if not (in_pattern_mode uenv) then + raise_for Unify (Errortrace.First_class_module fm_err); + List.iter (fun (_n, ty) -> reify uenv ty) (fl1 @ fl2); + | exception Not_found -> + if not (in_pattern_mode uenv) then raise_unexplained_for Unify; + List.iter (fun (_n, ty) -> reify uenv ty) (fl1 @ fl2); + (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) + end + | (Tnil, Tconstr _ ) -> + raise_for Unify (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Unify (Obj (Abstract_row First)) + | (_, _) -> raise_unexplained_for Unify + end; + (* XXX Commentaires + changer "create_recursion" + ||| Comments + change "create_recursion" *) + if create_recursion then + match get_desc t2 with + Tconstr (p, tl, abbrev) -> + forget_abbrev abbrev p; + let t2'' = expand_head_unif (get_env uenv) t2 in + if not (closed_parameterized_type tl t2'') then + link_type t2 t2' + | _ -> + () (* t2 has already been expanded by update_level *) + with Unify_trace trace -> + Transient_expr.set_desc tt1' d1; + raise_trace_for Unify trace + end + +and unify_list env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise_unexplained_for Unify; + List.iter2 (unify env) tl1 tl2 + +(* Build a fresh row variable for unification *) +and make_rowvar level use1 rest1 use2 rest2 = + let set_name ty name = + match get_desc ty with + Tvar None -> set_type_desc ty (Tvar name) + | _ -> () + in + let name = + match get_desc rest1, get_desc rest2 with + Tvar (Some _ as name1), Tvar (Some _ as name2) -> + if get_level rest1 <= get_level rest2 then name1 else name2 + | Tvar (Some _ as name), _ -> + if use2 then set_name rest2 name; name + | _, Tvar (Some _ as name) -> + if use1 then set_name rest2 name; name + | _ -> None + in + if use1 then rest1 else + if use2 then rest2 else newty2 ~level (Tvar name) + +and unify_fields uenv ty1 ty2 = (* Optimization *) + let (fields1, rest1) = flatten_fields ty1 + and (fields2, rest2) = flatten_fields ty2 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let l1 = get_level ty1 and l2 = get_level ty2 in + let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in + let tr1 = Transient_expr.repr rest1 and tr2 = Transient_expr.repr rest2 in + let d1 = tr1.desc and d2 = tr2.desc in + try + unify uenv (build_fields l1 miss1 va) rest2; + unify uenv rest1 (build_fields l2 miss2 va); + List.iter + (fun (name, k1, t1, k2, t2) -> + unify_kind k1 k2; + try + if !trace_gadt_instances && not (in_subst_mode uenv) then begin + (* in_subst_mode: see PR#11771 *) + update_level_for Unify (get_env uenv) (get_level va) t1; + update_scope_for Unify (get_scope va) t1 + end; + unify uenv t1 t2 + with Unify_trace trace -> + raise_trace_for Unify + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + with exn -> + Transient_expr.set_desc tr1 d1; + Transient_expr.set_desc tr2 d2; + raise exn + +and unify_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fprivate) -> link_kind ~inside:k2 k1 + | (Fpublic, Fpublic) -> () + | _ -> assert false + +and unify_row uenv row1 row2 = + let Row {fields = row1_fields; more = rm1; + closed = row1_closed; name = row1_name} = row_repr row1 in + let Row {fields = row2_fields; more = rm2; + closed = row2_closed; name = row2_name} = row_repr row2 in + if unify_eq uenv rm1 rm2 then () else + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in + if r1 <> [] && r2 <> [] then begin + let ht = Hashtbl.create (List.length r1) in + List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1; + List.iter + (fun (l,_) -> + try raise (Tags(l, Hashtbl.find ht (hash_variant l))) + with Not_found -> ()) + r2 + end; + let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in + let more = match fixed1, fixed2 with + | Some _, Some _ -> if get_level rm2 < get_level rm1 then rm2 else rm1 + | Some _, None -> rm1 + | None, Some _ -> rm2 + | None, None -> + newty2 ~level:(Int.min (get_level rm1) (get_level rm2)) (Tvar None) + in + let fixed = merge_fixed_explanation fixed1 fixed2 + and closed = row1_closed || row2_closed in + let keep switch = + List.for_all + (fun (_,f1,f2) -> + let f1, f2 = switch f1 f2 in + row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent) + pairs + in + let empty fields = + List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in + (* Check whether we are going to build an empty type *) + if closed && (empty r1 || row2_closed) && (empty r2 || row1_closed) + && List.for_all + (fun (_,f1,f2) -> + row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent) + pairs + then raise_for Unify (Variant No_intersection); + let name = + if row1_name <> None && (row1_closed || empty r2) && + (not row2_closed || keep (fun f1 f2 -> f1, f2) && empty r1) + then row1_name + else if row2_name <> None && (row2_closed || empty r1) && + (not row1_closed || keep (fun f1 f2 -> f2, f1) && empty r2) + then row2_name + else None + in + let set_more pos row rest = + let rest = + if closed then + filter_row_fields (row_closed row) rest + else rest in + begin match fixed_explanation row with + | None -> + if rest <> [] && row_closed row then + raise_for Unify (Variant (No_tags(pos,rest))) + | Some fixed -> + if closed && not (row_closed row) then + raise_for Unify (Variant (Fixed_row(pos,Cannot_be_closed,fixed))) + else if rest <> [] then + let case = Cannot_add_tags (List.map fst rest) in + raise_for Unify (Variant (Fixed_row(pos,case,fixed))) + end; + (* The following test is not principal... should rather use Tnil *) + let rm = row_more row in + (*if !trace_gadt_instances && rm.desc = Tnil then () else*) + if !trace_gadt_instances && not (in_subst_mode uenv) then + (* in_subst_mode: see PR#11771 *) + update_level_for Unify (get_env uenv) (get_level rm) + (newgenty (Tvariant row)); + if has_fixed_explanation row then + if eq_type more rm then () else + if is_Tvar rm then link_type rm more else unify uenv rm more + else + let ty = + newgenty (Tvariant + (create_row ~fields:rest ~more ~closed ~fixed ~name)) + in + update_level_for Unify (get_env uenv) (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty; + link_type rm ty + in + let tm1 = Transient_expr.repr rm1 and tm2 = Transient_expr.repr rm2 in + let md1 = tm1.desc and md2 = tm2.desc in + begin try + set_more Second row2 r1; + set_more First row1 r2; + List.iter + (fun (l,f1,f2) -> + try unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 + with Unify_trace trace -> + raise_trace_for Unify (Variant (Incompatible_types_for l) :: trace) + ) + pairs; + if static_row row1 then begin + let rm = row_more row1 in + if is_Tvar rm then link_type rm (newty2 ~level:(get_level rm) Tnil) + end + with exn -> + Transient_expr.set_desc tm1 md1; + Transient_expr.set_desc tm2 md2; + raise exn + end + +and unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 = + let if_not_fixed (pos,fixed) f = + match fixed with + | None -> f () + | Some fix -> + let tr = [Variant(Fixed_row(pos,Cannot_add_tags [l],fix))] in + raise_trace_for Unify tr in + let first = First, fixed1 and second = Second, fixed2 in + let either_fixed = match fixed1, fixed2 with + | None, None -> false + | _ -> true in + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + Rpresent(Some t1), Rpresent(Some t2) -> unify uenv t1 t2 + | Rpresent None, Rpresent None -> () + | Reither(c1, tl1, m1), Reither(c2, tl2, m2) -> + if eq_row_field_ext f1 f2 then () else + let no_arg = c1 || c2 and matched = m1 || m2 in + if either_fixed && not no_arg + && List.length tl1 = List.length tl2 then begin + (* PR#7496 *) + let f = rf_either [] ~no_arg ~matched in + link_row_field_ext ~inside:f1 f; link_row_field_ext ~inside:f2 f; + List.iter2 (unify uenv) tl1 tl2 + end + else let redo = + (m1 || m2 || either_fixed || + !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && + begin match tl1 @ tl2 with [] -> false + | t1 :: tl -> + if no_arg then raise_unexplained_for Unify; + Types.changed_row_field_exts [f1;f2] (fun () -> + List.iter (unify uenv t1) tl + ) + end in + if redo then unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 else + let remq tl = + List.filter (fun ty -> not (List.exists (eq_type ty) tl)) in + let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in + (* PR#6744 *) + let env = get_env uenv in + let (tlu1,tl1') = List.partition (has_free_univars env) tl1' + and (tlu2,tl2') = List.partition (has_free_univars env) tl2' in + begin match tlu1, tlu2 with + [], [] -> () + | (tu1::tlu1), _ :: _ -> + (* Attempt to merge all the types containing univars *) + List.iter (unify uenv tu1) (tlu1@tlu2) + | (tu::_, []) | ([], tu::_) -> + occur_univar_for Unify env tu + end; + (* Is this handling of levels really principal? *) + let update_levels rm = + let env = get_env uenv in + List.iter + (fun ty -> + update_level_for Unify env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty) + in + update_levels rm2 tl1'; + update_levels rm1 tl2'; + let f1' = rf_either tl2' ~no_arg ~matched in + let f2' = rf_either tl1' ~use_ext_of:f1' ~no_arg ~matched in + link_row_field_ext ~inside:f1 f1'; link_row_field_ext ~inside:f2 f2'; + | Reither(_, _, false), Rabsent -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rabsent, Reither(_, _, false) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | Rabsent, Rabsent -> () + | Reither(false, tl, _), Rpresent(Some t2) -> + if_not_fixed first (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f1 f2; + update_level_for Unify (get_env uenv) (get_level rm1) t2; + update_scope_for Unify (get_scope rm1) t2; + (try List.iter (fun t1 -> unify uenv t1 t2) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Rpresent(Some t1), Reither(false, tl, _) -> + if_not_fixed second (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f2 f1; + update_level_for Unify (get_env uenv) (get_level rm2) t1; + update_scope_for Unify (get_scope rm2) t1; + (try List.iter (unify uenv t1) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Reither(true, [], _), Rpresent None -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rpresent None, Reither(true, [], _) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | Rabsent, (Rpresent _ | Reither(_,_,true)) -> + raise_trace_for Unify [Variant(No_tags(First, [l,f1]))] + | (Rpresent _ | Reither (_,_,true)), Rabsent -> + raise_trace_for Unify [Variant(No_tags(Second, [l,f2]))] + | (Rpresent (Some _) | Reither(false,_,_)), + (Rpresent None | Reither(true,_,_)) + | (Rpresent None | Reither(true,_,_)), + (Rpresent (Some _) | Reither(false,_,_)) -> + (* constructor arity mismatch: 0 <> 1 *) + raise_unexplained_for Unify + | Reither(true, _ :: _, _ ), Rpresent _ + | Rpresent _ , Reither(true, _ :: _, _ ) -> + (* inconsistent conjunction on a non-absent field *) + raise_unexplained_for Unify + +let unify uenv ty1 ty2 = + let snap = Btype.snapshot () in + try + unify uenv ty1 ty2 + with + Unify_trace trace -> + undo_compress snap; + raise (Unify (expand_to_unification_error (get_env uenv) trace)) + +let unify_gadt (penv : Pattern_env.t) ty1 ty2 = + let equated_types = TypePairs.create 0 in + let equations_generation = Allowed { equated_types } in + let uenv = Pattern + { penv; + equations_generation; + assume_injective = true; + unify_eq_set = TypePairs.create 11; } + in + with_univar_pairs [] (fun () -> + unify uenv ty1 ty2; + equated_types) + +let unify_var uenv t1 t2 = + if eq_type t1 t2 then () else + match get_desc t1, get_desc t2 with + Tvar _, Tconstr _ when deep_occur t1 t2 -> + unify uenv t1 t2 + | Tvar _, _ -> + let env = get_env uenv in + let reset_tracing = check_trace_gadt_instances env in + begin try + occur_for Unify uenv t1 t2; + update_level_for Unify env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise (Unify (expand_to_unification_error + env + (Diff { got = t1; expected = t2 } :: trace))) + end + | _ -> + unify uenv t1 t2 + +let _ = unify_var' := unify_var + +(* the final versions of unification functions *) +let unify_var env ty1 ty2 = + unify_var (Expression {env; in_subst = false}) ty1 ty2 + +let unify_pairs env ty1 ty2 pairs = + with_univar_pairs pairs (fun () -> + unify (Expression {env; in_subst = false}) ty1 ty2) + +let unify env ty1 ty2 = + unify_pairs env ty1 ty2 [] + +(* Lower the level of a type to the current level *) +let enforce_current_level env ty = unify_var env (newvar ()) ty + + +(**** Special cases of unification ****) + +let expand_head_trace env t = + let reset_tracing = check_trace_gadt_instances env in + let t = expand_head_unif env t in + reset_trace_gadt_instances reset_tracing; + t + +(* + Unify [t] and [l:'a -> 'b]. Return ['a] and ['b]. + In [-nolabels] mode, label mismatch is accepted when + (1) the requested label is "" + (2) the original label is not optional +*) + +type filter_arrow_failure = + | Unification_error of unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +let filter_arrow env t l = + let function_type level = + let t1 = newvar2 level and t2 = newvar2 level in + let t' = newty2 ~level (Tarrow (l, t1, t2, commu_ok)) in + t', t1, t2 + in + let t = + try expand_head_trace env t + with Unify_trace trace -> + let t', _, _ = function_type (get_level t) in + raise (Filter_arrow_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = t'; expected = t } :: trace)))) + in + match get_desc t with + | Tvar _ -> + let t', t1, t2 = function_type (get_level t) in + link_type t t'; + (t1, t2) + | Tarrow(l', t1, t2, _) -> + if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') + then (t1, t2) + else raise (Filter_arrow_failed + (Label_mismatch + { got = l; expected = l'; expected_type = t })) + | _ -> + raise (Filter_arrow_failed Not_a_function) + +type filter_method_failure = + | Unification_error of unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +(* Used by [filter_method]. *) +let rec filter_method_field env name ty = + let method_type ~level = + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = newty2 ~level (Tfield (name, field_public, ty1, ty2)) in + ty', ty1 + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let ty', _ = method_type ~level in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let ty', ty1 = method_type ~level in + link_type ty ty'; + ty1 + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + unify_kind kind field_public; + ty1 + end else + filter_method_field env name ty2 + | _ -> + raise (Filter_method_failed Not_a_method) + +(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) +let filter_method env name ty = + let object_type ~level ~scope = + let ty1 = newvar2 level in + let ty' = newty3 ~level ~scope (Tobject (ty1, ref None)) in + let ty_meth = filter_method_field env name ty1 in + (ty', ty_meth) + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let scope = get_scope ty in + let ty', _ = object_type ~level ~scope in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let scope = get_scope ty in + let ty', ty_meth = object_type ~level ~scope in + link_type ty ty'; + ty_meth + | Tobject(f, _) -> + filter_method_field env name f + | _ -> + raise (Filter_method_failed (Not_an_object ty)) + +exception Filter_method_row_failed + +let rec filter_method_row env name priv ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let field = newvar2 level in + let row = newvar2 level in + let kind, priv = + match priv with + | Private -> + let kind = field_private () in + kind, Mprivate kind + | Public -> + field_public, Mpublic + in + let ty' = newty2 ~level (Tfield (name, kind, field, row)) in + link_type ty ty'; + priv, field, row + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + let priv = + match priv with + | Public -> + unify_kind kind field_public; + Mpublic + | Private -> Mprivate kind + in + priv, ty1, ty2 + end else begin + let level = get_level ty in + let priv, field, row = filter_method_row env name priv ty2 in + let row = newty2 ~level (Tfield (n, kind, ty1, row)) in + priv, field, row + end + | Tnil -> + if name = Btype.dummy_method then raise Filter_method_row_failed + else begin + match priv with + | Public -> raise Filter_method_row_failed + | Private -> + let level = get_level ty in + let kind = field_absent in + Mprivate kind, newvar2 level, ty + end + | _ -> + raise Filter_method_row_failed + +(* Operations on class signatures *) + +let new_class_signature () = + let row = newvar () in + let self = newobj row in + { csig_self = self; + csig_self_row = row; + csig_vars = Vars.empty; + csig_meths = Meths.empty; } + +let add_dummy_method env ~scope sign = + let _, ty, row = + filter_method_row env dummy_method Private sign.csig_self_row + in + unify env ty (new_scoped_ty scope (Ttuple [])); + sign.csig_self_row <- row + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +let add_method env label priv virt ty sign = + let meths = sign.csig_meths in + let priv, virt = + match Meths.find label meths with + | (priv', virt', ty') -> begin + let priv = + match priv' with + | Mpublic -> Mpublic + | Mprivate k -> + match priv with + | Public -> + begin match field_kind_repr k with + | Fpublic -> () + | Fprivate -> link_kind ~inside:k field_public + | Fabsent -> assert false + end; + Mpublic + | Private -> priv' + in + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + match unify env ty ty' with + | () -> priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + | exception Not_found -> begin + let priv, ty', row = + match filter_method_row env label priv sign.csig_self_row with + | priv, ty', row -> + priv, ty', row + | exception Filter_method_row_failed -> + raise (Add_method_failed Unexpected_method) + in + match unify env ty ty' with + | () -> + sign.csig_self_row <- row; + priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + in + let meths = Meths.add label (priv, virt, ty) meths in + sign.csig_meths <- meths + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +let check_mutability mut mut' = + match mut, mut' with + | Mutable, Mutable -> () + | Immutable, Immutable -> () + | Mutable, Immutable | Immutable, Mutable -> + raise (Add_instance_variable_failed (Mutability_mismatch mut)) + +let add_instance_variable ~strict env label mut virt ty sign = + let vars = sign.csig_vars in + let virt = + match Vars.find label vars with + | (mut', virt', ty') -> + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + if strict then begin + check_mutability mut mut'; + match unify env ty ty' with + | () -> () + | exception Unify trace -> + raise (Add_instance_variable_failed (Type_mismatch trace)) + end; + virt + | exception Not_found -> virt + in + let vars = Vars.add label (mut, virt, ty) vars in + sign.csig_vars <- vars + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +let unify_self_types env sign1 sign2 = + let self_type1 = sign1.csig_self in + let self_type2 = sign2.csig_self in + match unify env self_type1 self_type2 with + | () -> () + | exception Unify err -> begin + match err.trace with + | Errortrace.Diff _ :: Errortrace.Incompatible_fields {name; _} :: rem -> + let err = Errortrace.unification_error ~trace:rem in + let failure = Method (name, Type_mismatch err) in + raise (Inherit_class_signature_failed failure) + | _ -> + raise (Inherit_class_signature_failed (Self_type_mismatch err)) + end + +(* Unify components of sign2 into sign1 *) +let inherit_class_signature ~strict env sign1 sign2 = + unify_self_types env sign1 sign2; + Meths.iter + (fun label (priv, virt, ty) -> + let priv = + match priv with + | Mpublic -> Public + | Mprivate kind -> + assert (field_kind_repr kind = Fabsent); + Private + in + match add_method env label priv virt ty sign1 with + | () -> () + | exception Add_method_failed failure -> + let failure = Method(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_meths; + Vars.iter + (fun label (mut, virt, ty) -> + match add_instance_variable ~strict env label mut virt ty sign1 with + | () -> () + | exception Add_instance_variable_failed failure -> + let failure = Instance_variable(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_vars + +let update_class_signature env sign = + let self = expand_head env sign.Types.csig_self in + let fields, row = flatten_fields (object_fields self) in + let meths, implicitly_public, implicitly_declared = + List.fold_left + (fun (meths, implicitly_public, implicitly_declared) (lab, k, ty) -> + if lab = dummy_method then + meths, implicitly_public, implicitly_declared + else begin + match Meths.find lab meths with + | priv, virt, ty' -> + let meths, implicitly_public = + match priv, field_kind_repr k with + | Mpublic, _ -> meths, implicitly_public + | Mprivate _, Fpublic -> + let meths = Meths.add lab (Mpublic, virt, ty') meths in + let implicitly_public = lab :: implicitly_public in + meths, implicitly_public + | Mprivate _, _ -> meths, implicitly_public + in + meths, implicitly_public, implicitly_declared + | exception Not_found -> + let meths, implicitly_declared = + match field_kind_repr k with + | Fpublic -> + let meths = Meths.add lab (Mpublic, Virtual, ty) meths in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fprivate -> + let meths = + Meths.add lab (Mprivate k, Virtual, ty) meths + in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fabsent -> meths, implicitly_declared + in + meths, implicitly_public, implicitly_declared + end) + (sign.csig_meths, [], []) fields + in + sign.csig_meths <- meths; + sign.csig_self_row <- row; + implicitly_public, implicitly_declared + +let hide_private_methods env sign = + let self = expand_head env sign.Types.csig_self in + let fields, _ = flatten_fields (object_fields self) in + List.iter + (fun (_, k, _) -> + match field_kind_repr k with + | Fprivate -> link_kind ~inside:k field_absent + | _ -> ()) + fields + +let close_class_signature env sign = + let rec close env ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + link_type ty (newty2 ~level Tnil); true + | Tfield(lab, _, _, _) when lab = dummy_method -> + false + | Tfield(_, _, _, ty') -> close env ty' + | Tnil -> true + | _ -> assert false + in + let self = expand_head env sign.csig_self in + close env (object_fields self) + +let generalize_class_signature_spine sign = + (* Generalize the spine of methods *) + sign.csig_meths <- + Meths.map (fun (priv, virt, ty) -> priv, virt, copy_spine ty) + sign.csig_meths + + (***********************************) + (* Matching between type schemes *) + (***********************************) + +(* Level of the subject, should be just below generic_level *) +let subject_level = generic_level - 1 + +(* + Update the level of [ty]. First check that the levels of generic + variables from the subject are not lowered. +*) +let moregen_occur env level ty = + with_type_mark begin fun mark -> + let rec occur ty = + let lv = get_level ty in + if lv <= level then () else + if is_Tvar ty && lv >= subject_level then raise Occur else + if try_mark_node mark ty then iter_type_expr occur ty + in + try + occur ty + with Occur -> + raise_unexplained_for Moregen + end; + (* also check for free univars *) + occur_univar_for Moregen env ty; + update_level_for Moregen env level ty + +let may_instantiate inst_nongen t1 = + let level = get_level t1 in + if inst_nongen then level <> subject_level + else level = generic_level + +let rec moregen inst_nongen type_pairs env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, _) when may_instantiate inst_nongen t1 -> + moregen_occur env (get_level t1) t2; + update_scope_for Moregen (get_scope t1) t2; + occur_for Moregen (Expression {env; in_subst = false}) t1 t2; + link_type t1 t2 + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> + () + | _ -> + let t1' = expand_head env t1 in + let t2' = expand_head env t2 in + (* Expansion may have changed the representative of the types... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, _) when may_instantiate inst_nongen t1' -> + moregen_occur env (get_level t1') t2; + update_scope_for Moregen (get_scope t1') t2; + link_type t1' t2 + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) -> + eq_labels Moregen ~in_pattern_mode:false l1 l2; + moregen inst_nongen type_pairs env t1 t2; + moregen inst_nongen type_pairs env u1 u2 + | (Ttuple tl1, Ttuple tl2) -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) + when Path.same p1 p2 -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin match + unify_package env (moregen_list inst_nongen type_pairs env) + (get_level t1') p1 fl1 (get_level t2') p2 fl2 + with + | Ok () -> () + | Error fme -> raise_for Moregen (First_class_module fme) + | exception Not_found -> raise_unexplained_for Moregen + end + | (Tnil, Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> raise_for Moregen (Obj (Abstract_row First)) + | (Tvariant row1, Tvariant row2) -> + moregen_row inst_nongen type_pairs env row1 row2 + | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> + moregen_fields inst_nongen type_pairs env fi1 fi2 + | (Tfield _, Tfield _) -> (* Actually unused *) + moregen_fields inst_nongen type_pairs env + t1' t2' + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + moregen inst_nongen type_pairs env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly_for Moregen env t1 tl1 t2 tl2 + (moregen inst_nongen type_pairs env) + | (Tunivar _, Tunivar _) -> + unify_univar_for Moregen t1' t2' !univar_pairs + | (_, _) -> + raise_unexplained_for Moregen + end + with Moregen_trace trace -> + raise_trace_for Moregen (Diff {got = t1; expected = t2} :: trace) + + +and moregen_list inst_nongen type_pairs env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise_unexplained_for Moregen; + List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + +and moregen_fields inst_nongen type_pairs env ty1 ty2 = + let (fields1, rest1) = flatten_fields ty1 + and (fields2, rest2) = flatten_fields ty2 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + begin + match miss1 with + | (n, _, _) :: _ -> raise_for Moregen (Obj (Missing_field (Second, n))) + | [] -> () + end; + moregen inst_nongen type_pairs env rest1 + (build_fields (get_level ty2) miss2 rest2); + List.iter + (fun (name, k1, t1, k2, t2) -> + (* The below call should never throw [Public_method_to_private_method] *) + moregen_kind k1 k2; + try moregen inst_nongen type_pairs env t1 t2 with Moregen_trace trace -> + raise_trace_for Moregen + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + +and moregen_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fpublic) -> () + | (Fpublic, Fprivate) -> raise Public_method_to_private_method + | (Fabsent, _) | (_, Fabsent) -> assert false + +and moregen_row inst_nongen type_pairs env row1 row2 = + let Row {fields = row1_fields; more = rm1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = rm2; closed = row2_closed; + fixed = row2_fixed} = row_repr row2 in + if eq_type rm1 rm2 then () else + let may_inst = + is_Tvar rm1 && may_instantiate inst_nongen rm1 || get_desc rm1 = Tnil in + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in + let r1, r2 = + if row2_closed then + filter_row_fields may_inst r1, filter_row_fields false r2 + else r1, r2 + in + begin + if r1 <> [] then raise_for Moregen (Variant (No_tags (Second, r1))) + end; + if row1_closed then begin + match row2_closed, r2 with + | false, _ -> raise_for Moregen (Variant (Openness Second)) + | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2))) + | _, [] -> () + end; + let md1 = get_desc rm1 (* This lets us undo a following [link_type] *) in + begin match md1, get_desc rm2 with + Tunivar _, Tunivar _ -> + unify_univar_for Moregen rm1 rm2 !univar_pairs + | Tunivar _, _ | _, Tunivar _ -> + raise_unexplained_for Moregen + | _ when static_row row1 -> () + | _ when may_inst -> + let ext = + newgenty (Tvariant + (create_row ~fields:r2 ~more:rm2 ~name:None + ~fixed:row2_fixed ~closed:row2_closed)) + in + moregen_occur env (get_level rm1) ext; + update_scope_for Moregen (get_scope rm1) ext; + (* This [link_type] has to be undone if the rest of the function fails *) + link_type rm1 ext + | Tconstr _, Tconstr _ -> + moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise_unexplained_for Moregen + end; + try + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + moregen inst_nongen type_pairs env t1 t2 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both [Reither] *) + | Reither(c1, tl1, _), Reither(c2, tl2, m2) -> begin + try + if not (eq_row_field_ext f1 f2) then begin + if c1 && not c2 then raise_unexplained_for Moregen; + let f2' = + rf_either [] ~use_ext_of:f2 ~no_arg:c2 ~matched:m2 in + link_row_field_ext ~inside:f1 f2'; + if List.length tl1 = List.length tl2 then + List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + else match tl2 with + | t2 :: _ -> + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + | [] -> if tl1 <> [] then raise_unexplained_for Moregen + end + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + (* Generalizing [Reither] *) + | Reither(false, tl1, _), Rpresent(Some t2) when may_inst -> begin + try + link_row_field_ext ~inside:f1 f2; + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Reither(true, [], _), Rpresent None when may_inst -> + link_row_field_ext ~inside:f1 f2 + | Reither(_, _, _), Rabsent when may_inst -> + link_row_field_ext ~inside:f1 f2 + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) -> + raise_for Moregen (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Moregen (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Moregen (Variant (No_tags (Second, [l, f1])))) + pairs + with exn -> + (* Undo [link_type] if we failed *) + set_type_desc rm1 md1; raise exn + +(* Must empty univar_pairs first *) +let moregen inst_nongen type_pairs env patt subj = + with_univar_pairs [] (fun () -> + moregen inst_nongen type_pairs env patt subj) + +(* + Non-generic variable can be instantiated only if [inst_nongen] is + true. So, [inst_nongen] should be set to false if the subject might + contain non-generic variables (and we do not want them to be + instantiated). + Usually, the subject is given by the user, and the pattern + is unimportant. So, no need to propagate abbreviations. +*) +let moregeneral env inst_nongen pat_sch subj_sch = + (* Moregen splits the generic level into two finer levels: + [generic_level] and [subject_level = generic_level - 1]. + In order to properly detect and print weak variables when + printing errors, we need to merge those levels back together. + We do that by starting at level [subject_level - 1], using + [with_local_level_generalize] to first set the current level + to [subject_level], and then generalize nodes at [subject_level] + on exit. + Strictly speaking, we could avoid generalizing when there is no error, + as nodes at level [subject_level] are never unified with nodes of + the original types, but that would be rather ad hoc. + *) + with_level ~level:(subject_level - 1) begin fun () -> + match with_local_level_generalize begin fun () -> + assert (!current_level = subject_level); + (* + Generic variables are first duplicated with [instance]. So, + their levels are lowered to [subject_level]. The subject is + then copied with [duplicate_type]. That way, its levels won't be + changed. + *) + let subj_inst = instance subj_sch in + let subj = duplicate_type subj_inst in + (* Duplicate generic variables *) + let patt = generic_instance pat_sch in + try Ok (moregen inst_nongen (TypePairs.create 13) env patt subj) + with Moregen_trace trace -> Error trace + end with + | Ok () -> () + | Error trace -> raise (Moregen (expand_to_moregen_error env trace)) + end + +let is_moregeneral env inst_nongen pat_sch subj_sch = + match moregeneral env inst_nongen pat_sch subj_sch with + | () -> true + | exception Moregen _ -> false + +(* Alternative approach: "rigidify" a type scheme, + and check validity after unification *) +(* Simpler, no? *) + +let rec rigidify_rec mark vars ty = + if try_mark_node mark ty then + begin match get_desc ty with + | Tvar _ -> + if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars + | Tvariant row -> + let Row {more; name; closed} = row_repr row in + if is_Tvar more && not (has_fixed_explanation row) then begin + let more' = newty2 ~level:(get_level more) (get_desc more) in + let row' = + create_row ~fixed:(Some Rigid) ~fields:[] ~more:more' + ~name ~closed + in link_type more (newty2 ~level:(get_level ty) (Tvariant row')) + end; + iter_row (rigidify_rec mark vars) row; + (* only consider the row variable if the variant is not static *) + if not (static_row row) then + rigidify_rec mark vars (row_more row) + | _ -> + iter_type_expr (rigidify_rec mark vars) ty + end + +let rigidify ty = + let vars = ref TypeSet.empty in + with_type_mark (fun mark -> rigidify_rec mark vars ty); + TypeSet.elements !vars + +let all_distinct_vars env vars = + let tys = ref TypeSet.empty in + List.for_all + (fun ty -> + let ty = expand_head env ty in + if TypeSet.mem ty !tys then false else + (tys := TypeSet.add ty !tys; is_Tvar ty)) + vars + +let matches ~expand_error_trace env ty ty' = + let snap = snapshot () in + let vars = rigidify ty in + cleanup_abbrev (); + match unify env ty ty' with + | () -> + if not (all_distinct_vars env vars) then begin + backtrack snap; + let diff = + if expand_error_trace + then expanded_diff env ~got:ty ~expected:ty' + else unexpanded_diff ~got:ty ~expected:ty' + in + raise (Matches_failure (env, unification_error ~trace:[diff])) + end; + backtrack snap + | exception Unify err -> + backtrack snap; + raise (Matches_failure (env, err)) + +let does_match env ty ty' = + match matches ~expand_error_trace:false env ty ty' with + | () -> true + | exception Matches_failure (_, _) -> false + + (*********************************************) + (* Equivalence between parameterized types *) + (*********************************************) + +let expand_head_rigid env ty = + let old = !rigid_variants in + rigid_variants := true; + let ty' = expand_head env ty in + rigid_variants := old; ty' + +let eqtype_subst type_pairs subst t1 t2 = + if List.exists + (fun (t,t') -> + let found1 = eq_type t1 t in + let found2 = eq_type t2 t' in + if found1 && found2 then true else + if found1 || found2 then raise_unexplained_for Equality else false) + !subst + then () + else begin + subst := (t1, t2) :: !subst; + TypePairs.add type_pairs (t1, t2) + end + +let rec eqtype rename type_pairs subst env t1 t2 = + let check_phys_eq t1 t2 = + not rename && eq_type t1 t2 + in + (* Checking for physical equality of type representatives when [rename] is + true would be incorrect: imagine comparing ['a * 'a] with ['b * 'a]. The + first ['a] and ['b] would be identified in [eqtype_subst], and then the + second ['a] and ['a] would be [eq_type]. So we do not call [eq_type] here. + + On the other hand, when [rename] is false we need to check for physical + equality, as that's the only way variables can be identified. + *) + if check_phys_eq t1 t2 then () else + try + match (get_desc t1, get_desc t2) with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1 t2 + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> + () + | _ -> + let t1' = expand_head_rigid env t1 in + let t2' = expand_head_rigid env t2 in + (* Expansion may have changed the representative of the types... *) + if check_phys_eq t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1' t2' + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) -> + eq_labels Equality ~in_pattern_mode:false l1 l2; + eqtype rename type_pairs subst env t1 t2; + eqtype rename type_pairs subst env u1 u2 + | (Ttuple tl1, Ttuple tl2) -> + eqtype_list rename type_pairs subst env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) + when Path.same p1 p2 -> + eqtype_list_same_length rename type_pairs subst env tl1 tl2 + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin match + unify_package env (eqtype_list rename type_pairs subst env) + (get_level t1') p1 fl1 (get_level t2') p2 fl2 + with + | Ok () -> () + | Error fme -> raise_for Equality (First_class_module fme) + | exception Not_found -> raise_unexplained_for Equality + end + | (Tnil, Tconstr _ ) -> + raise_for Equality (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Equality (Obj (Abstract_row First)) + | (Tvariant row1, Tvariant row2) -> + eqtype_row rename type_pairs subst env row1 row2 + | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> + eqtype_fields rename type_pairs subst env fi1 fi2 + | (Tfield _, Tfield _) -> (* Actually unused *) + eqtype_fields rename type_pairs subst env + t1' t2' + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + eqtype rename type_pairs subst env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly_for Equality env t1 tl1 t2 tl2 + (eqtype rename type_pairs subst env) + | (Tunivar _, Tunivar _) -> + unify_univar_for Equality t1' t2' !univar_pairs + | (_, _) -> + raise_unexplained_for Equality + end + with Equality_trace trace -> + raise_trace_for Equality (Diff {got = t1; expected = t2} :: trace) + +and eqtype_list_same_length rename type_pairs subst env tl1 tl2 = + List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + +and eqtype_list rename type_pairs subst env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise_unexplained_for Equality; + eqtype_list_same_length rename type_pairs subst env tl1 tl2 + +and eqtype_fields rename type_pairs subst env ty1 ty2 = + let (fields1, rest1) = flatten_fields ty1 in + let (fields2, rest2) = flatten_fields ty2 in + (* First check if same row => already equal *) + let same_row = + (* [not rename]: see comment at top of [eqtype] *) + (not rename && eq_type rest1 rest2) || + TypePairs.mem type_pairs (rest1,rest2) + in + if same_row then () else + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env rest2) with + Tobject(ty2,_) -> eqtype_fields rename type_pairs subst env ty1 ty2 + | _ -> + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + eqtype rename type_pairs subst env rest1 rest2; + match miss1, miss2 with + | ((n, _, _)::_, _) -> raise_for Equality (Obj (Missing_field (Second, n))) + | (_, (n, _, _)::_) -> raise_for Equality (Obj (Missing_field (First, n))) + | [], [] -> + List.iter + (function (name, k1, t1, k2, t2) -> + eqtype_kind k1 k2; + try + eqtype rename type_pairs subst env t1 t2; + with Equality_trace trace -> + raise_trace_for Equality + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace)) + pairs + +and eqtype_kind k1 k2 = + let k1 = field_kind_repr k1 in + let k2 = field_kind_repr k2 in + match k1, k2 with + | (Fprivate, Fprivate) + | (Fpublic, Fpublic) -> () + | _ -> raise_unexplained_for Unify + (* It's probably not possible to hit this case with + real OCaml code *) + +and eqtype_row rename type_pairs subst env row1 row2 = + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env (row_more row2)) with + Tvariant row2 -> eqtype_row rename type_pairs subst env row1 row2 + | _ -> + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + if row_closed row1 <> row_closed row2 then begin + raise_for Equality + (Variant (Openness (if row_closed row2 then First else Second))) + end; + if not (row_closed row1) then begin + match r1, r2 with + | _::_, _ -> raise_for Equality (Variant (No_tags (Second, r1))) + | _, _::_ -> raise_for Equality (Variant (No_tags (First, r2))) + | _, _ -> () + end; + begin + match filter_row_fields false r1 with + | [] -> (); + | _ :: _ as r1 -> raise_for Equality (Variant (No_tags (Second, r1))) + end; + begin + match filter_row_fields false r2 with + | [] -> () + | _ :: _ as r2 -> raise_for Equality (Variant (No_tags (First, r2))) + end; + if not (static_row row1) then + eqtype rename type_pairs subst env (row_more row1) (row_more row2); + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + eqtype rename type_pairs subst env t1 t2 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both matching [Reither]s *) + | Reither(c1, [], _), Reither(c2, [], _) when c1 = c2 -> () + | Reither(c1, t1::tl1, _), Reither(c2, t2::tl2, _) + when c1 = c2 -> begin + try + eqtype rename type_pairs subst env t1 t2; + if List.length tl1 = List.length tl2 then + (* if same length allow different types (meaning?) *) + List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + else begin + (* otherwise everything must be equal *) + List.iter (eqtype rename type_pairs subst env t1) tl2; + List.iter + (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 + end + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) + | Reither _, Reither _ -> + raise_for Equality (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Equality (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Equality (Variant (No_tags (Second, [l, f1])))) + pairs + +(* Must empty univar_pairs first *) +let eqtype_list_same_length rename type_pairs subst env tl1 tl2 = + with_univar_pairs [] (fun () -> + let snap = Btype.snapshot () in + Misc.try_finally + ~always:(fun () -> backtrack snap) + (fun () -> eqtype_list_same_length rename type_pairs subst env tl1 tl2)) + +let eqtype rename type_pairs subst env t1 t2 = + eqtype_list_same_length rename type_pairs subst env [t1] [t2] + +(* Two modes: with or without renaming of variables *) +let equal env rename tyl1 tyl2 = + if List.length tyl1 <> List.length tyl2 then + raise_unexplained_for Equality; + if List.for_all2 eq_type tyl1 tyl2 then () else + let subst = ref [] in + try eqtype_list_same_length rename (TypePairs.create 11) subst env tyl1 tyl2 + with Equality_trace trace -> + raise (Equality (expand_to_equality_error env trace !subst)) + +let is_equal env rename tyl1 tyl2 = + match equal env rename tyl1 tyl2 with + | () -> true + | exception Equality _ -> false + +let rec equal_private env params1 ty1 params2 ty2 = + match equal env true (params1 @ [ty1]) (params2 @ [ty2]) with + | () -> () + | exception (Equality _ as err) -> + match try_expand_safe_opt env (expand_head env ty1) with + | ty1' -> equal_private env params1 ty1' params2 ty2 + | exception Cannot_expand -> raise err + + (*************************) + (* Class type matching *) + (*************************) + +type class_match_failure = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of int * Env.t * equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of int * Env.t * moregen_error + | CM_Val_type_mismatch of string * Env.t * comparison_error + | CM_Meth_type_mismatch of string * Env.t * comparison_error + | CM_Non_mutable_value of string + | CM_Non_concrete_value of string + | CM_Missing_value of string + | CM_Missing_method of string + | CM_Hide_public of string + | CM_Hide_virtual of string * string + | CM_Public_method of string + | CM_Private_method of string + | CM_Virtual_method of string + +exception Failure of class_match_failure list + +let match_class_sig_shape ~strict sign1 sign2 = + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> CM_Missing_method lab::err + | (priv', vr', _) -> + match priv', priv with + | Mpublic, Mprivate _ -> CM_Public_method lab::err + | Mprivate _, Mpublic when strict -> CM_Private_method lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Virtual_method lab::err + | _, _ -> err) + sign2.csig_meths [] + in + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + if Meths.mem lab sign2.csig_meths then err + else begin + let err = + match priv with + | Mpublic -> CM_Hide_public lab :: err + | Mprivate _ -> err + in + match vr with + | Virtual -> CM_Hide_virtual ("method", lab) :: err + | Concrete -> err + end) + sign1.csig_meths errors + in + let errors = + Vars.fold + (fun lab (mut, vr, _) err -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> CM_Missing_value lab::err + | (mut', vr', _) -> + match mut', mut with + | Immutable, Mutable -> CM_Non_mutable_value lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Non_concrete_value lab::err + | _, _ -> err) + sign2.csig_vars errors + in + Vars.fold + (fun lab (_,vr,_) err -> + if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then + CM_Hide_virtual ("instance variable", lab) :: err + else err) + sign1.csig_vars errors + +(* [arrow_index] is the number of [Cty_arrow] + constructors we've seen so far. *) +let rec moregen_clty ~arrow_index trace type_pairs env cty1 cty2 = + try + match cty1, cty2 with + | Cty_constr (_, _, cty1), _ -> + moregen_clty ~arrow_index true type_pairs env cty1 cty2 + | _, Cty_constr (_, _, cty2) -> + moregen_clty ~arrow_index true type_pairs env cty1 cty2 + | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 -> + let arrow_index = arrow_index + 1 in + begin + try moregen true type_pairs env ty1 ty2 with Moregen_trace trace -> + raise (Failure [ + CM_Parameter_mismatch + (arrow_index, env, expand_to_moregen_error env trace)]) + end; + moregen_clty ~arrow_index false type_pairs env cty1' cty2' + | Cty_signature sign1, Cty_signature sign2 -> + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_vars + | _ -> + raise (Failure []) + with + Failure error when trace || error = [] -> + raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) + +let moregen_clty trace type_pairs env cty1 cty2 = + moregen_clty ~arrow_index:0 trace type_pairs env cty1 cty2 + +let match_class_types ?(trace=true) env pat_sch subj_sch = + let sign1 = signature_of_class_type pat_sch in + let sign2 = signature_of_class_type subj_sch in + let errors = match_class_sig_shape ~strict:false sign1 sign2 in + match errors with + | [] -> + (* Moregen splits the generic level into two finer levels: + [generic_level] and [subject_level = generic_level - 1]. + In order to properly detect and print weak variables when + printing errors, we need to merge those levels back together. + We do that by starting at level [subject_level - 1], using + [with_local_level_generalize] to first set the current level + to [subject_level], and then generalize nodes at [subject_level] + on exit. + Strictly speaking, we could avoid generalizing when there is no error, + as nodes at level [subject_level] are never unified with nodes of + the original types, but that would be rather ad hoc. + *) + with_level ~level:(subject_level - 1) begin fun () -> + with_local_level_generalize begin fun () -> + assert (!current_level = subject_level); + (* + Generic variables are first duplicated with [instance]. So, + their levels are lowered to [subject_level]. The subject is + then copied with [duplicate_type]. That way, its levels won't be + changed. + *) + let (_, subj_inst) = instance_class [] subj_sch in + let subj = duplicate_class_type subj_inst in + (* Duplicate generic variables *) + let (_, patt) = + with_level ~level:generic_level + (fun () -> instance_class [] pat_sch) in + let type_pairs = TypePairs.create 53 in + let sign1 = signature_of_class_type patt in + let sign2 = signature_of_class_type subj in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + moregen true type_pairs env row1 row2; + (* May fail *) + try moregen_clty trace type_pairs env patt subj; [] + with Failure res -> res + end + end + | errors -> + CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors + +let equal_clsig trace type_pairs subst env sign1 sign2 = + try + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_vars + with + Failure error when trace -> + raise (Failure (CM_Class_type_mismatch + (env, Cty_signature sign1, Cty_signature sign2)::error)) + +let match_class_declarations env patt_params patt_type subj_params subj_type = + let sign1 = signature_of_class_type patt_type in + let sign2 = signature_of_class_type subj_type in + let errors = match_class_sig_shape ~strict:true sign1 sign2 in + match errors with + | [] -> begin + try + let subst = ref [] in + let type_pairs = TypePairs.create 53 in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + eqtype true type_pairs subst env row1 row2; + let lp = List.length patt_params in + let ls = List.length subj_params in + if lp <> ls then + raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); + Stdlib.List.iteri2 (fun n p s -> + try eqtype true type_pairs subst env p s with Equality_trace trace -> + raise (Failure + [CM_Type_parameter_mismatch + (n+1, env, expand_to_equality_error env trace !subst)])) + patt_params subj_params; + (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) + equal_clsig false type_pairs subst env sign1 sign2; + (* Use moregeneral for class parameters, need to recheck everything to + keeps relationships (PR#4824) *) + let clty_params = + List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in + match_class_types ~trace:false env + (clty_params patt_params patt_type) + (clty_params subj_params subj_type) + with Failure r -> r + end + | error -> + error + + + (***************) + (* Subtyping *) + (***************) + + +(**** Build a subtype of a given type. ****) + +(* build_subtype: + [visited] traces traversed object and variant types + [loops] is a mapping from variables to variables, to reproduce + positive loops in a class type + [posi] true if the current variance is positive + [level] number of expansions/enlargement allowed on this branch *) + +let warn = ref false (* whether double coercion might do better *) +let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n +let pred_enlarge n = if n mod 2 = 1 then pred n else n + +type change = Unchanged | Equiv | Changed +let max_change c1 c2 = + match c1, c2 with + | _, Changed | Changed, _ -> Changed + | Equiv, _ | _, Equiv -> Equiv + | _ -> Unchanged + +let collect l = List.fold_left (fun c1 (_, c2) -> max_change c1 c2) Unchanged l + +let rec filter_visited = function + [] -> [] + | {desc=Tobject _|Tvariant _} :: _ as l -> l + | _ :: l -> filter_visited l + +let memq_warn t visited = + if List.memq t visited then (warn := true; true) else false + +let find_cltype_for_path env p = + let cl_abbr = Env.find_hash_type p env in + match cl_abbr.type_manifest with + Some ty -> + begin match get_desc ty with + Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty + | _ -> raise Not_found + end + | None -> assert false + +let has_constr_row' env t = + has_constr_row (expand_abbrev env t) + +let rec build_subtype env (visited : transient_expr list) + (loops : (int * type_expr) list) posi level t = + match get_desc t with + Tvar _ -> + if posi then + try + let t' = List.assq (get_id t) loops in + warn := true; + (t', Equiv) + with Not_found -> + (t, Unchanged) + else + (t, Unchanged) + | Tarrow(l, t1, t2, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in + let (t1', c1) = build_subtype env visited loops (not posi) level t1 in + let (t2', c2) = build_subtype env visited loops posi level t2 in + let c = max_change c1 c2 in + if c > Unchanged + then (newty (Tarrow(l, t1', t2', commu_ok)), c) + else (t, Unchanged) + | Ttuple tlist -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in + let tlist' = + List.map (build_subtype env visited loops posi level) tlist + in + let c = collect tlist' in + if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c) + else (t, Unchanged) + | Tconstr(p, tl, abbrev) + when level > 0 && generic_abbrev env p && safe_abbrev env t + && not (has_constr_row' env t) -> + let t' = expand_abbrev env t in + let level' = pred_expand level in + begin try match get_desc t' with + Tobject _ when posi && not (opened_object t') -> + let cl_abbr, body = find_cltype_for_path env p in + let ty = + try + subst env !current_level Public abbrev None + cl_abbr.type_params tl body + with Cannot_subst -> assert false in + let ty1, tl1 = + match get_desc ty with + Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' -> + ty1, tl1 + | _ -> raise Not_found + in + (* Fix PR#4505: do not set ty to Tvar when it appears in tl1, + as this occurrence might break the occur check. + XXX not clear whether this correct anyway... *) + if List.exists (deep_occur ty) tl1 then raise Not_found; + set_type_desc ty (Tvar None); + let t'' = newvar () in + let loops = (get_id ty, t'') :: loops in + (* May discard [visited] as level is going down *) + let (ty1', c) = + build_subtype env [Transient_expr.repr t'] + loops posi (pred_enlarge level') ty1 in + assert (is_Tvar t''); + let nm = + if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in + set_type_desc t'' (Tobject (ty1', ref nm)); + (try unify_var env ty t with Unify _ -> assert false); + ( t'', Changed) + | _ -> raise Not_found + with Not_found -> + let (t'',c) = + build_subtype env visited loops posi level' t' in + if c > Unchanged then (t'',c) + else (t, Unchanged) + end + | Tconstr(p, tl, _abbrev) -> + (* Must check recursion on constructors, since we do not always + expand them *) + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in + begin try + let decl = Env.find_type p env in + if level = 0 && generic_abbrev env p && safe_abbrev env t + && not (has_constr_row' env t) + then warn := true; + let tl' = + List.map2 + (fun v t -> + let (co,cn) = Variance.get_upper v in + if cn then + if co then (t, Unchanged) + else build_subtype env visited loops (not posi) level t + else + if co then build_subtype env visited loops posi level t + else (newvar(), Changed)) + decl.type_variance tl + in + let c = collect tl' in + if c > Unchanged then (newconstr p (List.map fst tl'), c) + else (t, Unchanged) + with Not_found -> + (t, Unchanged) + end + | Tvariant row -> + let tt = Transient_expr.repr t in + if memq_warn tt visited || not (static_row row) then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: if level' < level then [] else filter_visited visited in + let fields = filter_row_fields false (row_fields row) in + let fields = + List.map + (fun (l,f as orig) -> match row_field_repr f with + Rpresent None -> + if posi then + (l, rf_either_of None), Unchanged + else + orig, Unchanged + | Rpresent(Some t) -> + let (t', c) = build_subtype env visited loops posi level' t in + let f = + if posi && level > 0 + then rf_either_of (Some t') + else rf_present (Some t') + in (l, f), c + | _ -> assert false) + fields + in + let c = collect fields in + let row = + create_row ~fields:(List.map fst fields) ~more:(newvar ()) + ~closed:posi ~fixed:None + ~name:(if c > Unchanged then None else row_name row) + in + (newty (Tvariant row), Changed) + | Tobject (t1, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited || opened_object t1 then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: if level' < level then [] else filter_visited visited in + let (t1', c) = build_subtype env visited loops posi level' t1 in + if c > Unchanged then (newty (Tobject (t1', ref None)), c) + else (t, Unchanged) + | Tfield(s, _, t1, t2) (* Always present *) -> + let (t1', c1) = build_subtype env visited loops posi level t1 in + let (t2', c2) = build_subtype env visited loops posi level t2 in + let c = max_change c1 c2 in + if c > Unchanged then (newty (Tfield(s, field_public, t1', t2')), c) + else (t, Unchanged) + | Tnil -> + if posi then + let v = newvar () in + (v, Changed) + else begin + warn := true; + (t, Unchanged) + end + | Tsubst _ | Tlink _ -> + assert false + | Tpoly(t1, tl) -> + let (t1', c) = build_subtype env visited loops posi level t1 in + if c > Unchanged then (newty (Tpoly(t1', tl)), c) + else (t, Unchanged) + | Tunivar _ | Tpackage _ -> + (t, Unchanged) + +let enlarge_type env ty = + warn := false; + (* [level = 4] allows 2 expansions involving objects/variants *) + let (ty', _) = build_subtype env [] [] true 4 ty in + (ty', !warn) + +(**** Check whether a type is a subtype of another type. ****) + +(* + During the traversal, a trace of visited types is maintained. It + is printed in case of error. + Constraints (pairs of types that must be equals) are accumulated + rather than being enforced straight. Indeed, the result would + otherwise depend on the order in which these constraints are + enforced. + A function enforcing these constraints is returned. That way, type + variables can be bound to their actual values before this function + is called (see Typecore). + Only well-defined abbreviations are expanded (hence the tests + [generic_abbrev ...]). +*) + +let subtypes = TypePairs.create 17 + +let subtype_error ~env ~trace ~unification_trace = + raise (Subtype (Subtype.error + ~trace:(expand_subtype_trace env (List.rev trace)) + ~unification_trace)) + +let rec subtype_rec env trace t1 t2 cstrs = + if eq_type t1 t2 then cstrs else + + if TypePairs.mem subtypes (t1, t2) then + cstrs + else begin + TypePairs.add subtypes (t1, t2); + match (get_desc t1, get_desc t2) with + (Tvar _, _) | (_, Tvar _) -> + (trace, t1, t2, !univar_pairs)::cstrs + | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) + when compatible_labels ~in_pattern_mode:false l1 l2 -> + let cstrs = + subtype_rec + env + (Subtype.Diff {got = t2; expected = t1} :: trace) + t2 t1 + cstrs + in + subtype_rec + env + (Subtype.Diff {got = u1; expected = u2} :: trace) + u1 u2 + cstrs + | (Ttuple tl1, Ttuple tl2) -> + subtype_list env trace tl1 tl2 cstrs + | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 -> + cstrs + | (Tconstr(p1, _tl1, _abbrev1), _) + when generic_abbrev env p1 && safe_abbrev env t1 -> + subtype_rec env trace (expand_abbrev env t1) t2 cstrs + | (_, Tconstr(p2, _tl2, _abbrev2)) + when generic_abbrev env p2 && safe_abbrev env t2 -> + subtype_rec env trace t1 (expand_abbrev env t2) cstrs + | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 -> + begin try + let decl = Env.find_type p1 env in + List.fold_left2 + (fun cstrs v (t1, t2) -> + let (co, cn) = Variance.get_upper v in + if co then + if cn then + (trace, newty2 ~level:(get_level t1) (Ttuple[t1]), + newty2 ~level:(get_level t2) (Ttuple[t2]), !univar_pairs) + :: cstrs + else + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + else + if cn + then + subtype_rec + env + (Subtype.Diff {got = t2; expected = t1} :: trace) + t2 t1 + cstrs + else cstrs) + cstrs decl.type_variance (List.combine tl1 tl2) + with Not_found -> + (trace, t1, t2, !univar_pairs)::cstrs + end + | (Tconstr(p1, _, _), _) + when generic_private_abbrev env p1 && safe_abbrev_opt env t1 -> + subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs +(* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> + subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) + | (Tobject (f1, _), Tobject (f2, _)) + when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> + (* Same row variable implies same object. *) + (trace, t1, t2, !univar_pairs)::cstrs + | (Tobject (f1, _), Tobject (f2, _)) -> + subtype_fields env trace f1 f2 cstrs + | (Tvariant row1, Tvariant row2) -> + begin try + subtype_row env trace row1 row2 cstrs + with Exit -> + (trace, t1, t2, !univar_pairs)::cstrs + end + | (Tpoly (u1, []), Tpoly (u2, [])) -> + subtype_rec env trace u1 u2 cstrs + | (Tpoly (u1, tl1), Tpoly (u2, [])) -> + let _, u1' = instance_poly ~fixed:false tl1 u1 in + subtype_rec env trace u1' u2 cstrs + | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> + begin try + enter_poly env u1 tl1 u2 tl2 + (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) + with Escape _ -> + (trace, t1, t2, !univar_pairs)::cstrs + end + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin try + let ntl1 = + complete_type_list env fl2 (get_level t1) (Mty_ident p1) fl1 + and ntl2 = + complete_type_list env fl1 (get_level t2) (Mty_ident p2) fl2 + ~allow_absent:true in + let cstrs' = + List.map + (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs)) + ntl2 + in + if eq_package_path env p1 p2 then cstrs' @ cstrs + else begin + (* need to check module subtyping *) + let snap = Btype.snapshot () in + match List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs' with + | () when Result.is_ok (!package_subtype env p1 fl1 p2 fl2) -> + Btype.backtrack snap; cstrs' @ cstrs + | () | exception Unify _ -> + Btype.backtrack snap; raise Not_found + end + with Not_found -> + (trace, t1, t2, !univar_pairs)::cstrs + end + | (_, _) -> + (trace, t1, t2, !univar_pairs)::cstrs + end + +and subtype_list env trace tl1 tl2 cstrs = + if List.length tl1 <> List.length tl2 then + subtype_error ~env ~trace ~unification_trace:[]; + List.fold_left2 + (fun cstrs t1 t2 -> + subtype_rec + env + (Subtype.Diff { got = t1; expected = t2 } :: trace) + t1 t2 + cstrs) + cstrs tl1 tl2 + +and subtype_fields env trace ty1 ty2 cstrs = + (* Assume that either rest1 or rest2 is not Tvar *) + let (fields1, rest1) = flatten_fields ty1 in + let (fields2, rest2) = flatten_fields ty2 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let cstrs = + if get_desc rest2 = Tnil then cstrs else + if miss1 = [] then + subtype_rec + env + (Subtype.Diff {got = rest1; expected = rest2} :: trace) + rest1 rest2 + cstrs + else + (trace, build_fields (get_level ty1) miss1 rest1, rest2, + !univar_pairs) :: cstrs + in + let cstrs = + if miss2 = [] then cstrs else + (trace, rest1, build_fields (get_level ty2) miss2 (newvar ()), + !univar_pairs) :: cstrs + in + List.fold_left + (fun cstrs (_, _k1, t1, _k2, t2) -> + (* These fields are always present *) + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs) + cstrs pairs + +and subtype_row env trace row1 row2 cstrs = + let Row {fields = row1_fields; more = more1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = more2; closed = row2_closed} = + row_repr row2 in + let r1, r2, pairs = + merge_row_fields row1_fields row2_fields in + let r1 = if row2_closed then filter_row_fields false r1 else r1 in + let r2 = if row1_closed then filter_row_fields false r2 else r2 in + match get_desc more1, get_desc more2 with + Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs + | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) + when row1_closed && r1 = [] -> + List.fold_left + (fun cstrs (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + (Rpresent None|Reither(true,_,_)), Rpresent None -> + cstrs + | Rpresent(Some t1), Rpresent(Some t2) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Reither(false, t1::_, _), Rpresent(Some t2) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) + cstrs pairs + | Tunivar _, Tunivar _ + when row1_closed = row2_closed && r1 = [] && r2 = [] -> + let cstrs = + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs + in + List.fold_left + (fun cstrs (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent None, Rpresent None + | Reither(true,[],_), Reither(true,[],_) + | Rabsent, Rabsent -> + cstrs + | Rpresent(Some t1), Rpresent(Some t2) + | Reither(false,[t1],_), Reither(false,[t2],_) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | _ -> raise Exit) + cstrs pairs + | _ -> + raise Exit + +let subtype env ty1 ty2 = + TypePairs.clear subtypes; + with_univar_pairs [] (fun () -> + (* Build constraint set. *) + let cstrs = + subtype_rec env [Subtype.Diff {got = ty1; expected = ty2}] ty1 ty2 [] + in + TypePairs.clear subtypes; + (* Enforce constraints. *) + function () -> + List.iter + (function (trace0, t1, t2, pairs) -> + try unify_pairs env t1 t2 pairs with Unify {trace} -> + subtype_error + ~env + ~trace:trace0 + ~unification_trace:(List.tl trace)) + (List.rev cstrs)) + + (*******************) + (* Miscellaneous *) + (*******************) + +(* Utility for printing. The resulting type is not used in computation. *) +let rec unalias_object ty = + let level = get_level ty in + match get_desc ty with + Tfield (s, k, t1, t2) -> + newty2 ~level (Tfield (s, k, t1, unalias_object t2)) + | Tvar _ | Tnil as desc -> + newty2 ~level desc + | Tunivar _ -> + ty + | Tconstr _ -> + newvar2 level + | _ -> + assert false + +let unalias ty = + let level = get_level ty in + match get_desc ty with + Tvar _ | Tunivar _ -> + ty + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + newty2 ~level + (Tvariant + (create_row ~fields ~name ~fixed ~closed ~more: + (newty2 ~level:(get_level more) (get_desc more)))) + | Tobject (ty, nm) -> + newty2 ~level (Tobject (unalias_object ty, nm)) + | desc -> + newty2 ~level desc + +(* Return the arity (as for curried functions) of the given type. *) +let rec arity ty = + match get_desc ty with + Tarrow(_, _t1, t2, _) -> 1 + arity t2 + | _ -> 0 + +(* Check for non-generalizable type variables *) +let add_nongen_vars_in_schema = + let rec loop env ((visited, weak_set) as acc) ty = + if TypeSet.mem ty visited + then acc + else begin + let visited = TypeSet.add ty visited in + match get_desc ty with + | Tvar _ when get_level ty <> generic_level -> + visited, TypeSet.add ty weak_set + | Tconstr _ -> + let (_, unexpanded_candidate) as unexpanded_candidate' = + fold_type_expr + (loop env) + (visited, weak_set) + ty + in + (* Using `==` is okay because `loop` will return the original set + when it does not change it. Similarly, `TypeSet.add` will return + the original set if the element is already present. *) + if unexpanded_candidate == weak_set + then (visited, weak_set) + else begin + match + loop env (visited, weak_set) + (try_expand_head try_expand_safe env ty) + with + | exception Cannot_expand -> unexpanded_candidate' + | expanded_result -> expanded_result + end + | Tfield(_, kind, t1, t2) -> + let visited, weak_set = + match field_kind_repr kind with + | Fpublic -> loop env (visited, weak_set) t1 + | _ -> visited, weak_set + in + loop env (visited, weak_set) t2 + | Tvariant row -> + let visited, weak_set = + fold_row (loop env) (visited, weak_set) row + in + if not (static_row row) + then loop env (visited, weak_set) (row_more row) + else (visited, weak_set) + | _ -> + fold_type_expr (loop env) (visited, weak_set) ty + end + in + fun env acc ty -> + let _, result = loop env (TypeSet.empty, acc) ty in + result + +(* Return all non-generic variables of [ty]. *) +let nongen_vars_in_schema env ty = + let result = add_nongen_vars_in_schema env TypeSet.empty ty in + if TypeSet.is_empty result + then None + else Some result + +(* Check that all type variables are generalizable *) +(* Use Env.empty to prevent expansion of recursively defined object types; + cf. typing-poly/poly.ml *) +let nongen_class_type = + let add_nongen_vars_in_schema' ty weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + let add_nongen_vars_in_schema_fold fold m weak_set = + let f _key (_,_,ty) weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + fold f m weak_set + in + let rec nongen_class_type cty weak_set = + match cty with + | Cty_constr (_, params, _) -> + List.fold_left + (add_nongen_vars_in_schema Env.empty) + weak_set + params + | Cty_signature sign -> + weak_set + |> add_nongen_vars_in_schema' sign.csig_self + |> add_nongen_vars_in_schema' sign.csig_self_row + |> add_nongen_vars_in_schema_fold Meths.fold sign.csig_meths + |> add_nongen_vars_in_schema_fold Vars.fold sign.csig_vars + | Cty_arrow (_, ty, cty) -> + add_nongen_vars_in_schema' ty weak_set + |> nongen_class_type cty + in + nongen_class_type + +let nongen_class_declaration cty = + List.fold_left + (add_nongen_vars_in_schema Env.empty) + TypeSet.empty + cty.cty_params + |> nongen_class_type cty.cty_type + +let nongen_vars_in_class_declaration cty = + let result = nongen_class_declaration cty in + if TypeSet.is_empty result + then None + else Some result + +(* Normalize a type before printing, saving... *) +(* Cannot use mark_type because deep_occur uses it too *) +let rec normalize_type_rec mark ty = + if try_mark_node mark ty then begin + let tm = row_of_type ty in + begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then + match get_desc tm with (* PR#7348 *) + Tconstr (Path.Pdot(m,i), tl, _abbrev) -> + let i' = String.sub i 0 (String.length i - 4) in + set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil)) + | _ -> assert false + else match get_desc ty with + | Tvariant row -> + let Row {fields = orig_fields; more; name; fixed; closed} = + row_repr row in + let fields = List.map + (fun (l,f) -> + l, + match row_field_repr f with Reither(b, ty::(_::_ as tyl), m) -> + let tyl' = + List.fold_left + (fun tyl ty -> + if List.exists + (fun ty' -> is_equal Env.empty false [ty] [ty']) + tyl + then tyl + else ty::tyl) + [ty] tyl + in + if List.length tyl' <= List.length tyl then + rf_either (List.rev tyl') ~use_ext_of:f ~no_arg:b ~matched:m + else f + | _ -> f) + orig_fields in + let fields = + List.sort (fun (p,_) (q,_) -> compare p q) + (List.filter (fun (_,fi) -> row_field_repr fi <> Rabsent) fields) in + set_type_desc ty (Tvariant + (create_row ~fields ~more ~name ~fixed ~closed)) + | Tobject (fi, nm) -> + begin match !nm with + | None -> () + | Some (n, v :: l) -> + if deep_occur ty (newgenty (Ttuple l)) then + (* The abbreviation may be hiding something, so remove it *) + set_name nm None + else + begin match get_desc v with + | Tvar _ | Tunivar _ -> () + | Tnil -> set_type_desc ty (Tconstr (n, l, ref Mnil)) + | _ -> set_name nm None + end + | _ -> + fatal_error "Ctype.normalize_type_rec" + end; + let level = get_level fi in + if level < lowest_level then () else + let fields, row = flatten_fields fi in + let fi' = build_fields level fields row in + set_type_desc fi (get_desc fi') + | _ -> () + end; + iter_type_expr (normalize_type_rec mark) ty; + end + +let normalize_type ty = + with_type_mark (fun mark -> normalize_type_rec mark ty) + + + (*************************) + (* Remove dependencies *) + (*************************) + + +(* + Variables are left unchanged. Other type nodes are duplicated, with + levels set to generic level. + We cannot use Tsubst here, because unification may be called by + expand_abbrev. +*) + +let nondep_hash = TypeHash.create 47 +let nondep_variants = TypeHash.create 17 +let clear_hash () = + TypeHash.clear nondep_hash; TypeHash.clear nondep_variants + +let rec nondep_type_rec ?(expand_private=false) env ids ty = + let try_expand env t = + if expand_private then try_expand_safe_opt env t + else try_expand_safe env t + in + match get_desc ty with + Tvar _ | Tunivar _ -> ty + | _ -> try TypeHash.find nondep_hash ty + with Not_found -> + let ty' = newgenstub ~scope:(get_scope ty) in + TypeHash.add nondep_hash ty ty'; + match + match get_desc ty with + | Tconstr(p, tl, _abbrev) as desc -> + begin try + (* First, try keeping the same type constructor p *) + match Path.find_free_opt ids p with + | Some id -> + raise (Nondep_cannot_erase id) + | None -> + Tconstr(p, List.map (nondep_type_rec env ids) tl, ref Mnil) + with (Nondep_cannot_erase _) as exn -> + (* If that doesn't work, try expanding abbrevs *) + try Tlink (nondep_type_rec ~expand_private env ids + (try_expand env (newty2 ~level:(get_level ty) desc))) + (* + The [Tlink] is important. The expanded type may be a + variable, or may not be completely copied yet + (recursive type), so one cannot just take its + description. + *) + with Cannot_expand -> raise exn + end + | Tpackage(p, fl) when Path.exists_free ids p -> + let p' = normalize_package_path env p in + begin match Path.find_free_opt ids p' with + | Some id -> raise (Nondep_cannot_erase id) + | None -> + let nondep_field_rec (n, ty) = (n, nondep_type_rec env ids ty) in + Tpackage (p', List.map nondep_field_rec fl) + end + | Tobject (t1, name) -> + Tobject (nondep_type_rec env ids t1, + ref (match !name with + None -> None + | Some (p, tl) -> + if Path.exists_free ids p then None + else Some (p, List.map (nondep_type_rec env ids) tl))) + | Tvariant row -> + let more = row_more row in + (* We must keep sharing according to the row variable *) + begin try + let ty2 = TypeHash.find nondep_variants more in + (* This variant type has been already copied *) + TypeHash.add nondep_hash ty ty2; + Tlink ty2 + with Not_found -> + (* Register new type first for recursion *) + TypeHash.add nondep_variants more ty'; + let static = static_row row in + let more' = + if static then newgenty Tnil else nondep_type_rec env ids more + in + (* Return a new copy *) + let row = + copy_row (nondep_type_rec env ids) true row true more' in + match row_name row with + Some (p, _tl) when Path.exists_free ids p -> + Tvariant (set_row_name row None) + | _ -> Tvariant row + end + | desc -> copy_type_desc (nondep_type_rec env ids) desc + with + | desc -> + Transient_expr.set_stub_desc ty' desc; + ty' + | exception e -> + TypeHash.remove nondep_hash ty; + raise e + +let nondep_type env id ty = + try + let ty' = nondep_type_rec env id ty in + clear_hash (); + ty' + with Nondep_cannot_erase _ as exn -> + clear_hash (); + raise exn + +let () = nondep_type' := nondep_type + +(* Preserve sharing inside type declarations. *) +let nondep_type_decl env mid is_covariant decl = + try + let params = List.map (nondep_type_rec env mid) decl.type_params in + let tk = + try map_kind (nondep_type_rec env mid) decl.type_kind + with Nondep_cannot_erase _ when is_covariant -> Type_abstract Definition + and tm, priv = + match decl.type_manifest with + | None -> None, decl.type_private + | Some ty -> + try Some (nondep_type_rec env mid ty), decl.type_private + with Nondep_cannot_erase _ when is_covariant -> + clear_hash (); + try Some (nondep_type_rec ~expand_private:true env mid ty), + Private + with Nondep_cannot_erase _ -> + None, decl.type_private + in + clear_hash (); + let priv = + match tm with + | Some ty when Btype.has_constr_row ty -> Private + | _ -> priv + in + { type_params = params; + type_arity = decl.type_arity; + type_kind = tk; + type_manifest = tm; + type_private = priv; + type_variance = decl.type_variance; + type_separability = decl.type_separability; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = decl.type_loc; + type_attributes = decl.type_attributes; + type_immediate = decl.type_immediate; + type_unboxed_default = decl.type_unboxed_default; + type_uid = decl.type_uid; + } + with Nondep_cannot_erase _ as exn -> + clear_hash (); + raise exn + +(* Preserve sharing inside extension constructors. *) +let nondep_extension_constructor env ids ext = + try + let type_path, type_params = + match Path.find_free_opt ids ext.ext_type_path with + | Some id -> + begin + let ty = + newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil)) + in + let ty' = nondep_type_rec env ids ty in + match get_desc ty' with + Tconstr(p, tl, _) -> p, tl + | _ -> raise (Nondep_cannot_erase id) + end + | None -> + let type_params = + List.map (nondep_type_rec env ids) ext.ext_type_params + in + ext.ext_type_path, type_params + in + let args = map_type_expr_cstr_args (nondep_type_rec env ids) ext.ext_args in + let ret_type = Option.map (nondep_type_rec env ids) ext.ext_ret_type in + clear_hash (); + { ext_type_path = type_path; + ext_type_params = type_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = ext.ext_private; + ext_attributes = ext.ext_attributes; + ext_loc = ext.ext_loc; + ext_uid = ext.ext_uid; + } + with Nondep_cannot_erase _ as exn -> + clear_hash (); + raise exn + + +(* Preserve sharing inside class types. *) +let nondep_class_signature env id sign = + { csig_self = nondep_type_rec env id sign.csig_self; + csig_self_row = nondep_type_rec env id sign.csig_self_row; + csig_vars = + Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) + sign.csig_vars; + csig_meths = + Meths.map (function (p, v, t) -> (p, v, nondep_type_rec env id t)) + sign.csig_meths } + +let rec nondep_class_type env ids = + function + Cty_constr (p, _, cty) when Path.exists_free ids p -> + nondep_class_type env ids cty + | Cty_constr (p, tyl, cty) -> + Cty_constr (p, List.map (nondep_type_rec env ids) tyl, + nondep_class_type env ids cty) + | Cty_signature sign -> + Cty_signature (nondep_class_signature env ids sign) + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, nondep_type_rec env ids ty, nondep_class_type env ids cty) + +let nondep_class_declaration env ids decl = + assert (not (Path.exists_free ids decl.cty_path)); + let decl = + { cty_params = List.map (nondep_type_rec env ids) decl.cty_params; + cty_variance = decl.cty_variance; + cty_type = nondep_class_type env ids decl.cty_type; + cty_path = decl.cty_path; + cty_new = + begin match decl.cty_new with + None -> None + | Some ty -> Some (nondep_type_rec env ids ty) + end; + cty_loc = decl.cty_loc; + cty_attributes = decl.cty_attributes; + cty_uid = decl.cty_uid; + } + in + clear_hash (); + decl + +let nondep_cltype_declaration env ids decl = + assert (not (Path.exists_free ids decl.clty_path)); + let decl = + { clty_params = List.map (nondep_type_rec env ids) decl.clty_params; + clty_variance = decl.clty_variance; + clty_type = nondep_class_type env ids decl.clty_type; + clty_path = decl.clty_path; + clty_hash_type = nondep_type_decl env ids false decl.clty_hash_type ; + clty_loc = decl.clty_loc; + clty_attributes = decl.clty_attributes; + clty_uid = decl.clty_uid; + } + in + clear_hash (); + decl + +(* collapse conjunctive types in class parameters *) +let rec collapse_conj env visited ty = + let id = get_id ty in + if List.memq id visited then () else + let visited = id :: visited in + match get_desc ty with + Tvariant row -> + List.iter + (fun (_l,fi) -> + match row_field_repr fi with + Reither (_c, t1::(_::_ as tl), _m) -> + List.iter (unify env t1) tl + | _ -> + ()) + (row_fields row); + iter_row (collapse_conj env visited) row + | _ -> + iter_type_expr (collapse_conj env visited) ty + +let collapse_conj_params env params = + List.iter (collapse_conj env []) params + +let same_constr env t1 t2 = + let t1 = expand_head env t1 in + let t2 = expand_head env t2 in + match get_desc t1, get_desc t2 with + | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 + | _ -> false + +let () = + Env.same_constr := same_constr + +let immediacy env typ = + match get_desc typ with + | Tconstr(p, _args, _abbrev) -> + begin try + let type_decl = Env.find_type p env in + type_decl.type_immediate + with Not_found -> Type_immediacy.Unknown + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *) + end + | Tvariant row -> + (* if all labels are devoid of arguments, not a pointer *) + if + not (row_closed row) + || List.exists + (fun (_, f) -> match row_field_repr f with + | Rpresent (Some _) | Reither (false, _, _) -> true + | _ -> false) + (row_fields row) + then + Type_immediacy.Unknown + else + Type_immediacy.Always + | _ -> Type_immediacy.Unknown diff --git a/upstream/ocaml_503/typing/ctype.mli b/upstream/ocaml_503/typing/ctype.mli new file mode 100644 index 000000000..66e22917a --- /dev/null +++ b/upstream/ocaml_503/typing/ctype.mli @@ -0,0 +1,475 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Operations on core types *) + +open Asttypes +open Types + +exception Unify of Errortrace.unification_error +exception Equality of Errortrace.equality_error +exception Moregen of Errortrace.moregen_error +exception Subtype of Errortrace.Subtype.error + +exception Escape of type_expr Errortrace.escape + +exception Tags of label * label +exception Cannot_expand +exception Cannot_apply +exception Matches_failure of Env.t * Errortrace.unification_error + (* Raised from [matches], hence the odd name *) +exception Incompatible + (* Raised from [mcomp] *) + +(* All the following wrapper functions revert to the original level, + even in case of exception. *) +val with_local_level_generalize: + ?before_generalize:('a -> unit) -> (unit -> 'a) -> 'a +val with_local_level_generalize_if: + bool -> ?before_generalize:('a -> unit) -> (unit -> 'a) -> 'a +val with_local_level_generalize_structure: (unit -> 'a) -> 'a +val with_local_level_generalize_structure_if: bool -> (unit -> 'a) -> 'a +val with_local_level_generalize_structure_if_principal: (unit -> 'a) -> 'a +val with_local_level_generalize_for_class: (unit -> 'a) -> 'a + +val with_local_level: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* [with_local_level (fun () -> cmd) ~post] evaluates [cmd] at a + raised level. + If given, [post] is applied to the result, at the original level. + It is expected to contain only level related post-processing. *) +val with_local_level_if: bool -> (unit -> 'a) -> post:('a -> unit) -> 'a + (* Same as [with_local_level], but only raise the level conditionally. + [post] also is only called if the level is raised. *) +val with_local_level_iter: (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Variant of [with_local_level], where [post] is iterated on the + returned list. *) +val with_local_level_iter_if: + bool -> (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Conditional variant of [with_local_level_iter] *) +val with_level: level: int -> (unit -> 'a) -> 'a + (* [with_level ~level (fun () -> cmd)] evaluates [cmd] with + [current_level] set to [level] *) +val with_level_if: bool -> level: int -> (unit -> 'a) -> 'a + (* Conditional variant of [with_level] *) +val with_local_level_if_principal: (unit -> 'a) -> post:('a -> unit) -> 'a +val with_local_level_iter_if_principal: + (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Applications of [with_local_level_if] and [with_local_level_iter_if] + to [!Clflags.principal] *) + +val with_local_level_for_class: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* Variant of [with_local_level], where the current level is raised but + the nongen level is not touched *) +val with_raised_nongen_level: (unit -> 'a) -> 'a + (* Variant of [with_local_level], + raises the nongen level to the current level *) + +val reset_global_level: unit -> unit + (* Reset the global level before typing an expression *) +val increase_global_level: unit -> int +val restore_global_level: int -> unit + (* This pair of functions is only used in Typetexp *) + +val create_scope : unit -> int + +val newty: type_desc -> type_expr +val new_scoped_ty: int -> type_desc -> type_expr +val newvar: ?name:string -> unit -> type_expr +val newvar2: ?name:string -> int -> type_expr + (* Return a fresh variable *) +val new_global_var: ?name:string -> unit -> type_expr + (* Return a fresh variable, bound at toplevel + (as type variables ['a] in type constraints). *) +val newobj: type_expr -> type_expr +val newconstr: Path.t -> type_expr list -> type_expr +val none: type_expr + (* A dummy type expression *) + +val object_fields: type_expr -> type_expr +val flatten_fields: + type_expr -> (string * field_kind * type_expr) list * type_expr +(** Transform a field type into a list of pairs label-type. + The fields are sorted. + + Beware of the interaction with GADTs: + + Due to the introduction of object indexes for GADTs, the row variable of + an object may now be an expansible type abbreviation. + A first consequence is that [flatten_fields] will not completely flatten + the object, since the type abbreviation will not be expanded + ([flatten_fields] does not receive the current environment). + Another consequence is that various functions may be called with the + expansion of this type abbreviation, which is a Tfield, e.g. during + printing. + + Concrete problems have been fixed, but new bugs may appear in the + future. (Test cases were added to typing-gadts/test.ml) +*) + +val associate_fields: + (string * field_kind * type_expr) list -> + (string * field_kind * type_expr) list -> + (string * field_kind * type_expr * field_kind * type_expr) list * + (string * field_kind * type_expr) list * + (string * field_kind * type_expr) list +val opened_object: type_expr -> bool +val set_object_name: + Ident.t -> type_expr list -> type_expr -> unit +val remove_object_name: type_expr -> unit +val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr + +val sort_row_fields: (label * row_field) list -> (label * row_field) list +val merge_row_fields: + (label * row_field) list -> (label * row_field) list -> + (label * row_field) list * (label * row_field) list * + (label * row_field * row_field) list +val filter_row_fields: + bool -> (label * row_field) list -> (label * row_field) list + +val lower_contravariant: Env.t -> type_expr -> unit + (* Lower level of type variables inside contravariant branches; + to be used before generalize for expansive expressions *) +val lower_variables_only: Env.t -> int -> type_expr -> unit + (* Lower all variables to the given level *) +val enforce_current_level: Env.t -> type_expr -> unit + (* Lower whole type to !current_level *) +val generalize_class_signature_spine: class_signature -> unit + (* Special function to generalize methods during inference *) +val limited_generalize: type_expr -> inside:type_expr -> unit + (* Only generalize some part of the type + Make the remaining of the type non-generalizable *) +val limited_generalize_class_type: type_expr -> inside:class_type -> unit + (* Same, but for class types *) + +val duplicate_type: type_expr -> type_expr + (* Returns a copy with non-variable nodes at generic level *) +val fully_generic: type_expr -> bool + +val check_scope_escape : Env.t -> int -> type_expr -> unit + (* [check_scope_escape env lvl ty] ensures that [ty] could be raised + to the level [lvl] without any scope escape. + Raises [Escape] otherwise *) + +val instance: ?partial:bool -> type_expr -> type_expr + (* Take an instance of a type scheme *) + (* partial=None -> normal + partial=false -> newvar() for non generic subterms + partial=true -> newty2 ty.level Tvar for non generic subterms *) +val generic_instance: type_expr -> type_expr + (* Same as instance, but new nodes at generic_level *) +val instance_list: type_expr list -> type_expr list + (* Take an instance of a list of type schemes *) +val new_local_type: + ?loc:Location.t -> + ?manifest_and_scope:(type_expr * int) -> + type_origin -> type_declaration + +module Pattern_env : sig + type t = private + { mutable env : Env.t; + equations_scope : int; + (* scope for local type declarations *) + allow_recursive_equations : bool; + (* true iff checking counter examples *) + } + val make: Env.t -> equations_scope:int -> allow_recursive_equations:bool -> t + val copy: ?equations_scope:int -> t -> t + val set_env: t -> Env.t -> unit +end + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of Pattern_env.t + +val instance_constructor: existential_treatment -> + constructor_description -> type_expr list * type_expr * type_expr list + (* Same, for a constructor. Also returns existentials. *) +val instance_parameterized_type: + ?keep_names:bool -> + type_expr list -> type_expr -> type_expr list * type_expr +val instance_declaration: type_declaration -> type_declaration +val generic_instance_declaration: type_declaration -> type_declaration + (* Same as instance_declaration, but new nodes at generic_level *) +val instance_class: + type_expr list -> class_type -> type_expr list * class_type + +val instance_poly: + ?keep_names:bool -> fixed:bool -> + type_expr list -> type_expr -> type_expr list * type_expr + (* Take an instance of a type scheme containing free univars *) +val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool +val instance_label: + fixed:bool -> + label_description -> type_expr list * type_expr * type_expr + (* Same, for a label *) +val apply: + ?use_current_level:bool -> + Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr + (* [apply [p1...pN] t [a1...aN]] applies the type function + [fun p1 ... pN -> t] to the arguments [a1...aN] and returns the + resulting instance of [t]. + New nodes default to generic level except if [use_current_level] is + set to true. + Exception [Cannot_apply] is raised in case of failure. *) + +val try_expand_once_opt: Env.t -> type_expr -> type_expr +val try_expand_safe_opt: Env.t -> type_expr -> type_expr + +val expand_head_once: Env.t -> type_expr -> type_expr +val expand_head: Env.t -> type_expr -> type_expr +val expand_head_opt: Env.t -> type_expr -> type_expr +(** The compiler's own version of [expand_head] necessary for type-based + optimisations. *) + +(** Expansion of types for error traces; lives here instead of in [Errortrace] + because the expansion machinery lives here. *) + +(** Create an [Errortrace.Diff] by expanding the two types *) +val expanded_diff : + Env.t -> + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +(** Create an [Errortrace.Diff] by *duplicating* the two types, so that each + one's expansion is identical to itself. Despite the name, does create + [Errortrace.expanded_type]s. *) +val unexpanded_diff : + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + (* The original path of the types, and the first concrete + type declaration found expanding it. *) + | Has_no_typedecl + | May_have_typedecl + +val extract_concrete_typedecl: + Env.t -> type_expr -> typedecl_extraction_result + +val get_new_abstract_name : Env.t -> string -> string + +val unify: Env.t -> type_expr -> type_expr -> unit + (* Unify the two types given. Raise [Unify] if not possible. *) +val unify_gadt: + Pattern_env.t -> type_expr -> type_expr -> Btype.TypePairs.t + (* Unify the two types given and update the environment with the + local constraints. Raise [Unify] if not possible. + Returns the pairs of types that have been equated. *) +val unify_var: Env.t -> type_expr -> type_expr -> unit + (* Same as [unify], but allow free univars when first type + is a variable. *) +val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr + (* A special case of unification with [l:'a -> 'b]. Raises + [Filter_arrow_failed] instead of [Unify]. *) +val filter_method: Env.t -> string -> type_expr -> type_expr + (* A special case of unification (with {m : 'a; 'b}). Raises + [Filter_method_failed] instead of [Unify]. *) +val occur_in: Env.t -> type_expr -> type_expr -> bool +val deep_occur: type_expr -> type_expr -> bool +val moregeneral: Env.t -> bool -> type_expr -> type_expr -> unit + (* Check if the first type scheme is more general than the second. *) +val is_moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool +val rigidify: type_expr -> type_expr list + (* "Rigidify" a type and return its type variable *) +val all_distinct_vars: Env.t -> type_expr list -> bool + (* Check those types are all distinct type variables *) +val matches: expand_error_trace:bool -> Env.t -> type_expr -> type_expr -> unit + (* Same as [moregeneral false], implemented using the two above + functions and backtracking. Ignore levels. The [expand_error_trace] + flag controls whether the error raised performs expansion; this + should almost always be [true]. *) +val does_match: Env.t -> type_expr -> type_expr -> bool + (* Same as [matches], but returns a [bool] *) + +val reify_univars : Env.t -> Types.type_expr -> Types.type_expr + (* Replaces all the variables of a type by a univar. *) + +(* Exceptions for special cases of unify *) + +type filter_arrow_failure = + | Unification_error of Errortrace.unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +type filter_method_failure = + | Unification_error of Errortrace.unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +type class_match_failure = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of int * Env.t * Errortrace.equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of int * Env.t * Errortrace.moregen_error + | CM_Val_type_mismatch of string * Env.t * Errortrace.comparison_error + | CM_Meth_type_mismatch of string * Env.t * Errortrace.comparison_error + | CM_Non_mutable_value of string + | CM_Non_concrete_value of string + | CM_Missing_value of string + | CM_Missing_method of string + | CM_Hide_public of string + | CM_Hide_virtual of string * string + | CM_Public_method of string + | CM_Private_method of string + | CM_Virtual_method of string + +val match_class_types: + ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list + (* Check if the first class type is more general than the second. *) +val equal: Env.t -> bool -> type_expr list -> type_expr list -> unit + (* [equal env [x1...xn] tau [y1...yn] sigma] + checks whether the parameterized types + [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *) +val is_equal : Env.t -> bool -> type_expr list -> type_expr list -> bool +val equal_private : + Env.t -> type_expr list -> type_expr -> + type_expr list -> type_expr -> unit +(* [equal_private env t1 params1 t2 params2] checks that [t1::params1] + equals [t2::params2] but it is allowed to expand [t1] if it is a + private abbreviations. *) + +val match_class_declarations: + Env.t -> type_expr list -> class_type -> type_expr list -> + class_type -> class_match_failure list + (* Check if the first class type is more general than the second. *) + +val enlarge_type: Env.t -> type_expr -> type_expr * bool + (* Make a type larger, flag is true if some pruning had to be done *) +val subtype: Env.t -> type_expr -> type_expr -> unit -> unit + (* [subtype env t1 t2] checks that [t1] is a subtype of [t2]. + It accumulates the constraints the type variables must + enforce and returns a function that enforces this + constraints. *) + +(* Operations on class signatures *) + +val new_class_signature : unit -> class_signature +val add_dummy_method : Env.t -> scope:int -> class_signature -> unit + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +val add_method : Env.t -> + label -> private_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +val add_instance_variable : strict:bool -> Env.t -> + label -> mutable_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +val inherit_class_signature : strict:bool -> Env.t -> + class_signature -> class_signature -> unit + +val update_class_signature : + Env.t -> class_signature -> label list * label list + +val hide_private_methods : Env.t -> class_signature -> unit + +val close_class_signature : Env.t -> class_signature -> bool + +exception Nondep_cannot_erase of Ident.t + +val nondep_type: Env.t -> Ident.t list -> type_expr -> type_expr + (* Return a type equivalent to the given type but without + references to any of the given identifiers. + Raise [Nondep_cannot_erase id] if no such type exists because [id], + in particular, could not be erased. *) +val nondep_type_decl: + Env.t -> Ident.t list -> bool -> type_declaration -> type_declaration + (* Same for type declarations. *) +val nondep_extension_constructor: + Env.t -> Ident.t list -> extension_constructor -> + extension_constructor + (* Same for extension constructor *) +val nondep_class_declaration: + Env.t -> Ident.t list -> class_declaration -> class_declaration + (* Same for class declarations. *) +val nondep_cltype_declaration: + Env.t -> Ident.t list -> class_type_declaration -> class_type_declaration + (* Same for class type declarations. *) +(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) +val is_contractive: Env.t -> Path.t -> bool +val normalize_type: type_expr -> unit + +val nongen_vars_in_schema: Env.t -> type_expr -> Btype.TypeSet.t option + (* Return any non-generic variables in the type scheme *) + +val nongen_vars_in_class_declaration:class_declaration -> Btype.TypeSet.t option + (* Return any non-generic variables in the class type. + Uses the empty environment. *) + +type variable_kind = Row_variable | Type_variable +type closed_class_failure = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} + +val free_variables: ?env:Env.t -> type_expr -> type_expr list + (* If env present, then check for incomplete definitions too *) +val closed_type_decl: type_declaration -> type_expr option +val closed_extension_constructor: extension_constructor -> type_expr option +val closed_class: + type_expr list -> class_signature -> + closed_class_failure option + (* Check whether all type variables are bound *) + +val unalias: type_expr -> type_expr + +val arity: type_expr -> int + (* Return the arity (as for curried functions) of the given type. *) + +val collapse_conj_params: Env.t -> type_expr list -> unit + (* Collapse conjunctive types in class parameters *) + +val get_current_level: unit -> int +val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b + +val immediacy : Env.t -> type_expr -> Type_immediacy.t + +(* Stubs *) +val package_subtype : + (Env.t -> Path.t -> (Longident.t * type_expr) list -> + Path.t -> (Longident.t * type_expr) list -> + (unit,Errortrace.first_class_module) Result.t) ref + +(* Raises [Incompatible] *) +val mcomp : Env.t -> type_expr -> type_expr -> unit diff --git a/upstream/ocaml_503/typing/datarepr.ml b/upstream/ocaml_503/typing/datarepr.ml new file mode 100644 index 000000000..522803115 --- /dev/null +++ b/upstream/ocaml_503/typing/datarepr.ml @@ -0,0 +1,239 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compute constructor and label descriptions from type declarations, + determining their representation. *) + +open Asttypes +open Types +open Btype + +(* Simplified version of Ctype.free_vars *) +let free_vars ?(param=false) ty = + let ret = ref TypeSet.empty in + with_type_mark begin fun mark -> + let rec loop ty = + if try_mark_node mark ty then + match get_desc ty with + | Tvar _ -> + ret := TypeSet.add ty !ret + | Tvariant row -> + iter_row loop row; + if not (static_row row) then begin + match get_desc (row_more row) with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop (row_more row) + end + (* XXX: What about Tobject ? *) + | _ -> + iter_type_expr loop ty + in + loop ty + end; + !ret + +let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) + +let constructor_existentials cd_args cd_res = + let tyl = + match cd_args with + | Cstr_tuple l -> l + | Cstr_record l -> List.map (fun l -> l.ld_type) l + in + let existentials = + match cd_res with + | None -> [] + | Some type_ret -> + let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in + let res_vars = free_vars type_ret in + TypeSet.elements (TypeSet.diff arg_vars_set res_vars) + in + (tyl, existentials) + +let constructor_args ~current_unit priv cd_args cd_res path rep = + let tyl, existentials = constructor_existentials cd_args cd_res in + match cd_args with + | Cstr_tuple l -> existentials, l, None + | Cstr_record lbls -> + let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in + let type_params = TypeSet.elements arg_vars_set in + let arity = List.length type_params in + let tdecl = + { + type_params; + type_arity = arity; + type_kind = Type_record (lbls, rep); + type_private = priv; + type_manifest = None; + type_variance = Variance.unknown_signature ~injective:true ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = Location.none; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit; + } + in + existentials, + [ newgenconstr path type_params ], + Some tdecl + +let constructor_descrs ~current_unit ty_path decl cstrs rep = + let ty_res = newgenconstr ty_path decl.type_params in + let num_consts = ref 0 and num_nonconsts = ref 0 in + List.iter + (fun {cd_args; _} -> + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) + cstrs; + let rec describe_constructors idx_const idx_nonconst = function + [] -> [] + | {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} :: rem -> + let ty_res = + match cd_res with + | Some ty_res' -> ty_res' + | None -> ty_res + in + let (tag, descr_rem) = + match cd_args, rep with + | _, Variant_unboxed -> + assert (rem = []); + (Cstr_unboxed, []) + | Cstr_tuple [], Variant_regular -> + (Cstr_constant idx_const, + describe_constructors (idx_const+1) idx_nonconst rem) + | _, Variant_regular -> + (Cstr_block idx_nonconst, + describe_constructors idx_const (idx_nonconst+1) rem) in + let cstr_name = Ident.name cd_id in + let existentials, cstr_args, cstr_inlined = + let representation = + match rep with + | Variant_unboxed -> Record_unboxed true + | Variant_regular -> Record_inlined idx_nonconst + in + constructor_args ~current_unit decl.type_private cd_args cd_res + Path.(Pextra_ty (ty_path, Pcstr_ty cstr_name)) representation + in + let cstr = + { cstr_name; + cstr_res = ty_res; + cstr_existentials = existentials; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = tag; + cstr_consts = !num_consts; + cstr_nonconsts = !num_nonconsts; + cstr_private = decl.type_private; + cstr_generalized = cd_res <> None; + cstr_loc = cd_loc; + cstr_attributes = cd_attributes; + cstr_inlined; + cstr_uid = cd_uid; + } in + (cd_id, cstr) :: descr_rem in + describe_constructors 0 0 cstrs + +let extension_descr ~current_unit path_ext ext = + let ty_res = + match ext.ext_ret_type with + Some type_ret -> type_ret + | None -> newgenconstr ext.ext_type_path ext.ext_type_params + in + let existentials, cstr_args, cstr_inlined = + constructor_args ~current_unit ext.ext_private ext.ext_args ext.ext_ret_type + Path.(Pextra_ty (path_ext, Pext_ty)) (Record_extension path_ext) + in + { cstr_name = Path.last path_ext; + cstr_res = ty_res; + cstr_existentials = existentials; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = Cstr_extension(path_ext, cstr_args = []); + cstr_consts = -1; + cstr_nonconsts = -1; + cstr_private = ext.ext_private; + cstr_generalized = ext.ext_ret_type <> None; + cstr_loc = ext.ext_loc; + cstr_attributes = ext.ext_attributes; + cstr_inlined; + cstr_uid = ext.ext_uid; + } + +let none = + create_expr (Ttuple []) ~level:(-1) ~scope:Btype.generic_level ~id:(-1) + (* Clearly ill-formed type *) + +let dummy_label = + { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; + lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; + lbl_private = Public; + lbl_loc = Location.none; + lbl_attributes = []; + lbl_uid = Uid.internal_not_actually_unique; + } + +let label_descrs ty_res lbls repres priv = + let all_labels = Array.make (List.length lbls) dummy_label in + let rec describe_labels num = function + [] -> [] + | l :: rest -> + let lbl = + { lbl_name = Ident.name l.ld_id; + lbl_res = ty_res; + lbl_arg = l.ld_type; + lbl_mut = l.ld_mutable; + lbl_pos = num; + lbl_all = all_labels; + lbl_repres = repres; + lbl_private = priv; + lbl_loc = l.ld_loc; + lbl_attributes = l.ld_attributes; + lbl_uid = l.ld_uid; + } in + all_labels.(num) <- lbl; + (l.ld_id, lbl) :: describe_labels (num+1) rest in + describe_labels 0 lbls + +exception Constr_not_found + +let rec find_constr tag num_const num_nonconst = function + [] -> + raise Constr_not_found + | {cd_args = Cstr_tuple []; _} as c :: rem -> + if tag = Cstr_constant num_const + then c + else find_constr tag (num_const + 1) num_nonconst rem + | c :: rem -> + if tag = Cstr_block num_nonconst || tag = Cstr_unboxed + then c + else find_constr tag num_const (num_nonconst + 1) rem + +let find_constr_by_tag tag cstrlist = + find_constr tag 0 0 cstrlist + +let constructors_of_type ~current_unit ty_path decl = + match decl.type_kind with + | Type_variant (cstrs,rep) -> + constructor_descrs ~current_unit ty_path decl cstrs rep + | Type_record _ | Type_abstract _ | Type_open -> [] + +let labels_of_type ty_path decl = + match decl.type_kind with + | Type_record(labels, rep) -> + label_descrs (newgenconstr ty_path decl.type_params) + labels rep decl.type_private + | Type_variant _ | Type_abstract _ | Type_open -> [] diff --git a/upstream/ocaml_503/typing/datarepr.mli b/upstream/ocaml_503/typing/datarepr.mli new file mode 100644 index 000000000..1ccb918e5 --- /dev/null +++ b/upstream/ocaml_503/typing/datarepr.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compute constructor and label descriptions from type declarations, + determining their representation. *) + +open Types + +val extension_descr: + current_unit:(Unit_info.t option) -> Path.t -> extension_constructor -> + constructor_description + +val labels_of_type: + Path.t -> type_declaration -> + (Ident.t * label_description) list +val constructors_of_type: + current_unit:(Unit_info.t option) -> Path.t -> type_declaration -> + (Ident.t * constructor_description) list + + +exception Constr_not_found + +val find_constr_by_tag: + constructor_tag -> constructor_declaration list -> + constructor_declaration + +val constructor_existentials : + constructor_arguments -> type_expr option -> type_expr list * type_expr list +(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and + returns: + - the types of the constructor's arguments + - the existential variables introduced by the constructor + *) diff --git a/upstream/ocaml_503/typing/env.ml b/upstream/ocaml_503/typing/env.ml new file mode 100644 index 000000000..5fb306c1f --- /dev/null +++ b/upstream/ocaml_503/typing/env.ml @@ -0,0 +1,3729 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Environment handling *) + +open Cmi_format +open Misc +open Asttypes +open Longident +open Path +open Types + +open Local_store + +module String = Misc.Stdlib.String + +let add_delayed_check_forward = ref (fun _ -> assert false) + +type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t +(** This table is used to track usage of value declarations. + A declaration is identified by its uid. + The callback attached to a declaration is called whenever the value (or + type, or ...) is used explicitly (lookup_value, ...) or implicitly + (inclusion test between signatures, cf Includemod.value_descriptions, ...). +*) + +let value_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 +let type_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 +let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 + +type constructor_usage = Positive | Pattern | Exported_private | Exported +type constructor_usages = + { + mutable cu_positive: bool; + mutable cu_pattern: bool; + mutable cu_exported_private: bool; + } +let add_constructor_usage cu usage = + match usage with + | Positive -> cu.cu_positive <- true + | Pattern -> cu.cu_pattern <- true + | Exported_private -> cu.cu_exported_private <- true + | Exported -> + cu.cu_positive <- true; + cu.cu_pattern <- true; + cu.cu_exported_private <- true + +let constructor_usages () = + {cu_positive = false; cu_pattern = false; cu_exported_private = false} + +let constructor_usage_complaint ~rebind priv cu + : Warnings.constructor_usage_warning option = + match priv, rebind with + | Asttypes.Private, _ | _, true -> + if cu.cu_positive || cu.cu_pattern || cu.cu_exported_private then None + else Some Unused + | Asttypes.Public, false -> begin + match cu.cu_positive, cu.cu_pattern, cu.cu_exported_private with + | true, _, _ -> None + | false, false, false -> Some Unused + | false, true, _ -> Some Not_constructed + | false, false, true -> Some Only_exported_private + end + +let used_constructors : constructor_usage usage_tbl ref = + s_table Types.Uid.Tbl.create 16 + +type label_usage = + Projection | Mutation | Construct | Exported_private | Exported +type label_usages = + { + mutable lu_projection: bool; + mutable lu_mutation: bool; + mutable lu_construct: bool; + } +let add_label_usage lu usage = + match usage with + | Projection -> lu.lu_projection <- true; + | Mutation -> lu.lu_mutation <- true + | Construct -> lu.lu_construct <- true + | Exported_private -> + lu.lu_projection <- true + | Exported -> + lu.lu_projection <- true; + lu.lu_mutation <- true; + lu.lu_construct <- true + +let is_mutating_label_usage = function + | Mutation -> true + | (Projection | Construct | Exported_private | Exported) -> false + +let label_usages () = + {lu_projection = false; lu_mutation = false; lu_construct = false} + +let label_usage_complaint priv mut lu + : Warnings.field_usage_warning option = + match priv, mut with + | Asttypes.Private, _ -> + if lu.lu_projection then None + else Some Unused + | Asttypes.Public, Asttypes.Immutable -> begin + match lu.lu_projection, lu.lu_construct with + | true, _ -> None + | false, false -> Some Unused + | false, true -> Some Not_read + end + | Asttypes.Public, Asttypes.Mutable -> begin + match lu.lu_projection, lu.lu_mutation, lu.lu_construct with + | true, true, _ -> None + | false, false, false -> Some Unused + | false, _, _ -> Some Not_read + | true, false, _ -> Some Not_mutated + end + +let used_labels : label_usage usage_tbl ref = + s_table Types.Uid.Tbl.create 16 + +(** Map indexed by the name of module components. *) +module NameMap = String.Map + +type value_unbound_reason = + | Val_unbound_instance_variable + | Val_unbound_self + | Val_unbound_ancestor + | Val_unbound_ghost_recursive of Location.t + +type module_unbound_reason = + | Mod_unbound_illegal_recursion + +type summary = + Env_empty + | Env_value of summary * Ident.t * value_description + | Env_type of summary * Ident.t * type_declaration + | Env_extension of summary * Ident.t * extension_constructor + | Env_module of summary * Ident.t * module_presence * module_declaration + | Env_modtype of summary * Ident.t * modtype_declaration + | Env_class of summary * Ident.t * class_declaration + | Env_cltype of summary * Ident.t * class_type_declaration + | Env_open of summary * Path.t + | Env_functor_arg of summary * Ident.t + | Env_constraints of summary * type_declaration Path.Map.t + | Env_copy_types of summary + | Env_persistent of summary * Ident.t + | Env_value_unbound of summary * string * value_unbound_reason + | Env_module_unbound of summary * string * module_unbound_reason + +let map_summary f = function + Env_empty -> Env_empty + | Env_value (s, id, d) -> Env_value (f s, id, d) + | Env_type (s, id, d) -> Env_type (f s, id, d) + | Env_extension (s, id, d) -> Env_extension (f s, id, d) + | Env_module (s, id, p, d) -> Env_module (f s, id, p, d) + | Env_modtype (s, id, d) -> Env_modtype (f s, id, d) + | Env_class (s, id, d) -> Env_class (f s, id, d) + | Env_cltype (s, id, d) -> Env_cltype (f s, id, d) + | Env_open (s, p) -> Env_open (f s, p) + | Env_functor_arg (s, id) -> Env_functor_arg (f s, id) + | Env_constraints (s, m) -> Env_constraints (f s, m) + | Env_copy_types s -> Env_copy_types (f s) + | Env_persistent (s, id) -> Env_persistent (f s, id) + | Env_value_unbound (s, u, r) -> Env_value_unbound (f s, u, r) + | Env_module_unbound (s, u, r) -> Env_module_unbound (f s, u, r) + +type address = + | Aident of Ident.t + | Adot of address * int + +module TycompTbl = + struct + (** This module is used to store components of types (i.e. labels + and constructors). We keep a representation of each nested + "open" and the set of local bindings between each of them. *) + + type 'a t = { + current: 'a Ident.tbl; + (** Local bindings since the last open. *) + + opened: 'a opened option; + (** Symbolic representation of the last (innermost) open, if any. *) + } + + and 'a opened = { + components: ('a list) NameMap.t; + (** Components from the opened module. We keep a list of + bindings for each name, as in comp_labels and + comp_constrs. *) + + root: Path.t; + (** Only used to check removal of open *) + + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this + "open". This is used to detect unused "opens". The + arguments are used to detect shadowing. *) + + next: 'a t; + (** The table before opening the module. *) + } + + let empty = { current = Ident.empty; opened = None } + + let add id x tbl = + {tbl with current = Ident.add id x tbl.current} + + let add_open slot wrap root components next = + let using = + match slot with + | None -> None + | Some f -> Some (fun s x -> f s (wrap x)) + in + { + current = Ident.empty; + opened = Some {using; components; root; next}; + } + + let remove_last_open rt tbl = + match tbl.opened with + | Some {root; next; _} when Path.same rt root -> + { next with current = + Ident.fold_all Ident.add tbl.current next.current } + | _ -> + assert false + + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> + begin match tbl.opened with + | Some {next; _} -> find_same id next + | None -> raise exn + end + + let nothing = fun () -> () + + let mk_callback rest name desc using = + match using with + | None -> nothing + | Some f -> + (fun () -> + match rest with + | [] -> f name None + | (hidden, _) :: _ -> f name (Some (desc, hidden))) + + let rec find_all ~mark name tbl = + List.map (fun (_id, desc) -> desc, nothing) + (Ident.find_all name tbl.current) @ + match tbl.opened with + | None -> [] + | Some {using; next; components; root = _} -> + let rest = find_all ~mark name next in + let using = if mark then using else None in + match NameMap.find name components with + | exception Not_found -> rest + | opened -> + List.map + (fun desc -> desc, mk_callback rest name desc using) + opened + @ rest + + let rec fold_name f tbl acc = + let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in + match tbl.opened with + | Some {using = _; next; components; root = _} -> + acc + |> NameMap.fold + (fun _name -> List.fold_right f) + components + |> fold_name f next + | None -> + acc + + let rec local_keys tbl acc = + let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in + match tbl.opened with + | Some o -> local_keys o.next acc + | None -> acc + + let diff_keys is_local tbl1 tbl2 = + let keys2 = local_keys tbl2 [] in + List.filter + (fun id -> + is_local (find_same id tbl2) && + try ignore (find_same id tbl1); false + with Not_found -> true) + keys2 + + end + + +module IdTbl = + struct + (** This module is used to store all kinds of components except + (labels and constructors) in environments. We keep a + representation of each nested "open" and the set of local + bindings between each of them. *) + + + type ('a, 'b) t = { + current: 'a Ident.tbl; + (** Local bindings since the last open *) + + layer: ('a, 'b) layer; + (** Symbolic representation of the last (innermost) open, if any. *) + } + + and ('a, 'b) layer = + | Open of { + root: Path.t; + (** The path of the opened module, to be prefixed in front of + its local names to produce a valid path in the current + environment. *) + + components: 'b NameMap.t; + (** Components from the opened module. *) + + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this + "open". This is used to detect unused "opens". The + arguments are used to detect shadowing. *) + + next: ('a, 'b) t; + (** The table before opening the module. *) + } + + | Map of { + f: ('a -> 'a); + next: ('a, 'b) t; + } + + | Nothing + + let empty = { current = Ident.empty; layer = Nothing } + + let add id x tbl = + {tbl with current = Ident.add id x tbl.current} + + let remove id tbl = + {tbl with current = Ident.remove id tbl.current} + + let add_open slot wrap root components next = + let using = + match slot with + | None -> None + | Some f -> Some (fun s x -> f s (wrap x)) + in + { + current = Ident.empty; + layer = Open {using; root; components; next}; + } + + let remove_last_open rt tbl = + match tbl.layer with + | Open {root; next; _} when Path.same rt root -> + { next with current = + Ident.fold_all Ident.add tbl.current next.current } + | _ -> + assert false + + let map f next = + { + current = Ident.empty; + layer = Map {f; next} + } + + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> + begin match tbl.layer with + | Open {next; _} -> find_same id next + | Map {f; next} -> f (find_same id next) + | Nothing -> raise exn + end + + let rec find_name wrap ~mark name tbl = + try + let (id, desc) = Ident.find_name name tbl.current in + Pident id, desc + with Not_found as exn -> + begin match tbl.layer with + | Open {using; root; next; components} -> + begin try + let descr = wrap (NameMap.find name components) in + let res = Pdot (root, name), descr in + if mark then begin match using with + | None -> () + | Some f -> begin + match find_name wrap ~mark:false name next with + | exception Not_found -> f name None + | _, descr' -> f name (Some (descr', descr)) + end + end; + res + with Not_found -> + find_name wrap ~mark name next + end + | Map {f; next} -> + let (p, desc) = find_name wrap ~mark name next in + p, f desc + | Nothing -> + raise exn + end + + let rec find_all wrap name tbl = + List.map + (fun (id, desc) -> Pident id, desc) + (Ident.find_all name tbl.current) @ + match tbl.layer with + | Nothing -> [] + | Open {root; using = _; next; components} -> + begin try + let desc = wrap (NameMap.find name components) in + (Pdot (root, name), desc) :: find_all wrap name next + with Not_found -> + find_all wrap name next + end + | Map {f; next} -> + List.map (fun (p, desc) -> (p, f desc)) + (find_all wrap name next) + + let rec find_all_idents name tbl () = + let current = + Ident.find_all_seq name tbl.current + |> Seq.map (fun (id, _) -> Some id) + in + let next () = + match tbl.layer with + | Nothing -> Seq.Nil + | Open { next; components; _ } -> + if NameMap.mem name components then + Seq.Cons(None, find_all_idents name next) + else + find_all_idents name next () + | Map {next; _ } -> find_all_idents name next () + in + Seq.append current next () + + let rec fold_name wrap f tbl acc = + let acc = + Ident.fold_name + (fun id d -> f (Ident.name id) (Pident id, d)) + tbl.current acc + in + match tbl.layer with + | Open {root; using = _; next; components} -> + acc + |> NameMap.fold + (fun name desc -> f name (Pdot (root, name), wrap desc)) + components + |> fold_name wrap f next + | Nothing -> + acc + | Map {f=g; next} -> + acc + |> fold_name wrap + (fun name (path, desc) -> f name (path, g desc)) + next + + let rec local_keys tbl acc = + let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in + match tbl.layer with + | Open {next; _ } | Map {next; _} -> local_keys next acc + | Nothing -> acc + + + let rec iter wrap f tbl = + Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; + match tbl.layer with + | Open {root; using = _; next; components} -> + NameMap.iter + (fun s x -> + let root_scope = Path.scope root in + f (Ident.create_scoped ~scope:root_scope s) + (Pdot (root, s), wrap x)) + components; + iter wrap f next + | Map {f=g; next} -> + iter wrap (fun id (path, desc) -> f id (path, g desc)) next + | Nothing -> () + + let diff_keys tbl1 tbl2 = + let keys2 = local_keys tbl2 [] in + List.filter + (fun id -> + try ignore (find_same id tbl1); false + with Not_found -> true) + keys2 + + + end + +type type_descr_kind = + (label_description, constructor_description) type_kind + +type type_descriptions = type_descr_kind + +let in_signature_flag = 0x01 + +type t = { + values: (value_entry, value_data) IdTbl.t; + constrs: constructor_data TycompTbl.t; + labels: label_data TycompTbl.t; + types: (type_data, type_data) IdTbl.t; + modules: (module_entry, module_data) IdTbl.t; + modtypes: (modtype_data, modtype_data) IdTbl.t; + classes: (class_data, class_data) IdTbl.t; + cltypes: (cltype_data, cltype_data) IdTbl.t; + functor_args: unit Ident.tbl; + summary: summary; + local_constraints: type_declaration Path.Map.t; + flags: int; +} + +and module_components = + { + alerts: alerts; + uid: Uid.t; + comps: + (components_maker, + (module_components_repr, module_components_failure) result) + Lazy_backtrack.t; + } + +and components_maker = { + cm_env: t; + cm_prefixing_subst: Subst.t; + cm_path: Path.t; + cm_addr: address_lazy; + cm_mty: Subst.Lazy.modtype; + cm_shape: Shape.t; +} + +and module_components_repr = + Structure_comps of structure_components + | Functor_comps of functor_components + +and module_components_failure = + | No_components_abstract + | No_components_alias of Path.t + +and structure_components = { + mutable comp_values: value_data NameMap.t; + mutable comp_constrs: constructor_data list NameMap.t; + mutable comp_labels: label_data list NameMap.t; + mutable comp_types: type_data NameMap.t; + mutable comp_modules: module_data NameMap.t; + mutable comp_modtypes: modtype_data NameMap.t; + mutable comp_classes: class_data NameMap.t; + mutable comp_cltypes: cltype_data NameMap.t; +} + +and functor_components = { + fcomp_arg: functor_parameter; + (* Formal parameter and argument signature *) + fcomp_res: module_type; (* Result signature *) + fcomp_shape: Shape.t; + fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *) + fcomp_subst_cache: (Path.t, module_type) Hashtbl.t +} + +and address_unforced = + | Projection of { parent : address_lazy; pos : int; } + | ModAlias of { env : t; path : Path.t; } + +and address_lazy = (address_unforced, address) Lazy_backtrack.t + +and value_data = + { vda_description : value_description; + vda_address : address_lazy; + vda_shape : Shape.t } + +and value_entry = + | Val_bound of value_data + | Val_unbound of value_unbound_reason + +and constructor_data = + { cda_description : constructor_description; + cda_address : address_lazy option; + cda_shape: Shape.t; } + +and label_data = label_description + +and type_data = + { tda_declaration : type_declaration; + tda_descriptions : type_descriptions; + tda_shape : Shape.t; } + +and module_data = + { mda_declaration : Subst.Lazy.module_decl; + mda_components : module_components; + mda_address : address_lazy; + mda_shape: Shape.t; } + +and module_entry = + | Mod_local of module_data + | Mod_persistent + | Mod_unbound of module_unbound_reason + +and modtype_data = + { mtda_declaration : Subst.Lazy.modtype_declaration; + mtda_shape : Shape.t; } + +and class_data = + { clda_declaration : class_declaration; + clda_address : address_lazy; + clda_shape : Shape.t } + +and cltype_data = + { cltda_declaration : class_type_declaration; + cltda_shape : Shape.t } + +let empty_structure = + Structure_comps { + comp_values = NameMap.empty; + comp_constrs = NameMap.empty; + comp_labels = NameMap.empty; + comp_types = NameMap.empty; + comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; + comp_classes = NameMap.empty; + comp_cltypes = NameMap.empty } + +type unbound_value_hint = + | No_hint + | Missing_rec of Location.t + +type lookup_error = + | Unbound_value of Longident.t * unbound_value_hint + | Unbound_type of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t + | Unbound_module of Longident.t + | Unbound_class of Longident.t + | Unbound_modtype of Longident.t + | Unbound_cltype of Longident.t + | Unbound_instance_variable of string + | Not_an_instance_variable of string + | Masked_instance_variable of Longident.t + | Masked_self_variable of Longident.t + | Masked_ancestor_variable of Longident.t + | Structure_used_as_functor of Longident.t + | Abstract_used_as_functor of Longident.t + | Functor_used_as_structure of Longident.t + | Abstract_used_as_structure of Longident.t + | Generative_used_as_applicative of Longident.t + | Illegal_reference_to_recursive_module + | Cannot_scrape_alias of Longident.t * Path.t + +type error = + | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string + | Lookup_error of Location.t * t * lookup_error + +exception Error of error + +let error err = raise (Error err) + +let lookup_error loc env err = + error (Lookup_error(loc, env, err)) + +let same_type_declarations e1 e2 = + e1.types == e2.types && + e1.modules == e2.modules && + e1.local_constraints == e2.local_constraints + +let same_constr = ref (fun _ _ _ -> assert false) + +let check_well_formed_module = ref (fun _ -> assert false) + +(* Helper to decide whether to report an identifier shadowing + by some 'open'. For labels and constructors, we do not report + if the two elements are from the same re-exported declaration. + + Later, one could also interpret some attributes on value and + type declarations to silence the shadowing warnings. *) + +let check_shadowing env = function + | `Constructor (Some (cda1, cda2)) + when not (!same_constr env + cda1.cda_description.cstr_res + cda2.cda_description.cstr_res) -> + Some "constructor" + | `Label (Some (l1, l2)) + when not (!same_constr env l1.lbl_res l2.lbl_res) -> + Some "label" + | `Value (Some (Val_unbound _, _)) -> None + | `Value (Some (_, _)) -> Some "value" + | `Type (Some _) -> Some "type" + | `Module (Some (Mod_unbound _, _)) -> None + | `Module (Some _) | `Component (Some _) -> + Some "module" + | `Module_type (Some _) -> Some "module type" + | `Class (Some _) -> Some "class" + | `Class_type (Some _) -> Some "class type" + | `Constructor _ | `Label _ + | `Value None | `Type None | `Module None | `Module_type None + | `Class None | `Class_type None | `Component None -> + None + +let empty = { + values = IdTbl.empty; constrs = TycompTbl.empty; + labels = TycompTbl.empty; types = IdTbl.empty; + modules = IdTbl.empty; modtypes = IdTbl.empty; + classes = IdTbl.empty; cltypes = IdTbl.empty; + summary = Env_empty; local_constraints = Path.Map.empty; + flags = 0; + functor_args = Ident.empty; + } + +let in_signature b env = + let flags = + if b then env.flags lor in_signature_flag + else env.flags land (lnot in_signature_flag) + in + {env with flags} + +let is_in_signature env = env.flags land in_signature_flag <> 0 + +let has_local_constraints env = + not (Path.Map.is_empty env.local_constraints) + +let is_ext cda = + match cda.cda_description with + | {cstr_tag = Cstr_extension _} -> true + | _ -> false + +let is_local_ext cda = + match cda.cda_description with + | {cstr_tag = Cstr_extension(p, _)} -> begin + match p with + | Pident _ -> true + | Pdot _ | Papply _ | Pextra_ty _ -> false + end + | _ -> false + +let diff env1 env2 = + IdTbl.diff_keys env1.values env2.values @ + TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @ + IdTbl.diff_keys env1.modules env2.modules @ + IdTbl.diff_keys env1.classes env2.classes + +(* Functions for use in "wrap" parameters in IdTbl *) +let wrap_identity x = x +let wrap_value vda = Val_bound vda +let wrap_module mda = Mod_local mda + +(* Forward declarations *) + +let components_of_module_maker' = + ref ((fun _ -> assert false) : + components_maker -> + (module_components_repr, module_components_failure) result) + +let components_of_functor_appl' = + ref ((fun ~loc:_ ~f_path:_ ~f_comp:_ ~arg:_ _env -> assert false) : + loc:Location.t -> f_path:Path.t -> f_comp:functor_components -> + arg:Path.t -> t -> module_components) +let check_functor_application = + (* to be filled by Includemod *) + ref ((fun ~errors:_ ~loc:_ + ~lid_whole_app:_ ~f0_path:_ ~args:_ + ~arg_path:_ ~arg_mty:_ ~param_mty:_ + _env + -> assert false) : + errors:bool -> loc:Location.t -> + lid_whole_app:Longident.t -> + f0_path:Path.t -> args:(Path.t * Types.module_type) list -> + arg_path:Path.t -> arg_mty:module_type -> param_mty:module_type -> + t -> unit) +let strengthen = + (* to be filled with Mtype.strengthen *) + ref ((fun ~aliasable:_ _env _mty _path -> assert false) : + aliasable:bool -> t -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) + +let md md_type = + {md_type; md_attributes=[]; md_loc=Location.none + ;md_uid = Uid.internal_not_actually_unique} + +(* Print addresses *) + +let rec print_address ppf = function + | Aident id -> Format.fprintf ppf "%s" (Ident.name id) + | Adot(a, pos) -> Format.fprintf ppf "%a.[%i]" print_address a pos + +(* The name of the compilation unit currently compiled. + "" if outside a compilation unit. *) +module Current_unit : sig + val get : unit -> Unit_info.t option + val set : Unit_info.t -> unit + val unset : unit -> unit + + module Name : sig + val get : unit -> modname + val is : modname -> bool + val is_ident : Ident.t -> bool + val is_path : Path.t -> bool + end +end = struct + let current_unit : Unit_info.t option ref = + ref None + let get () = + !current_unit + let set cu = + current_unit := Some cu + let unset () = + current_unit := None + + module Name = struct + let get () = + match !current_unit with + | None -> "" + | Some cu -> Unit_info.modname cu + let is name = + get () = name + let is_ident id = + Ident.persistent id && is (Ident.name id) + let is_path = function + | Pident id -> is_ident id + | Pdot _ | Papply _ | Pextra_ty _ -> false + end +end + +let set_current_unit = Current_unit.set +let get_current_unit = Current_unit.get +let get_current_unit_name = Current_unit.Name.get + +let find_same_module id tbl = + match IdTbl.find_same id tbl with + | x -> x + | exception Not_found + when Ident.persistent id && not (Current_unit.Name.is_ident id) -> + Mod_persistent + +let find_name_module ~mark name tbl = + match IdTbl.find_name wrap_module ~mark name tbl with + | x -> x + | exception Not_found when not (Current_unit.Name.is name) -> + let path = Pident(Ident.create_persistent name) in + path, Mod_persistent + +let add_persistent_structure id env = + if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure"; + if Current_unit.Name.is_ident id then env + else begin + let material = + (* This addition only observably changes the environment if it shadows a + non-persistent module already in the environment. + (See PR#9345) *) + match + IdTbl.find_name wrap_module ~mark:false (Ident.name id) env.modules + with + | exception Not_found | _, Mod_persistent -> false + | _ -> true + in + let summary = + if material then Env_persistent (env.summary, id) + else env.summary + in + let modules = + (* With [-no-alias-deps], non-material additions should not + affect the environment at all. We should only observe the + existence of a cmi when accessing components of the module. + (See #9991). *) + if material || not !Clflags.transparent_modules then + IdTbl.add id Mod_persistent env.modules + else + env.modules + in + { env with modules; summary } + end + +let components_of_module ~alerts ~uid env ps path addr mty shape = + { + alerts; + uid; + comps = Lazy_backtrack.create { + cm_env = env; + cm_prefixing_subst = ps; + cm_path = path; + cm_addr = addr; + cm_mty = mty; + cm_shape = shape; + } + } + +let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } = + let name = cmi.cmi_name in + let sign = cmi.cmi_sign in + let flags = cmi.cmi_flags in + let id = Ident.create_persistent name in + let path = Pident id in + let alerts = + List.fold_left (fun acc -> function Alerts s -> s | _ -> acc) + Misc.Stdlib.String.Map.empty + flags + in + let md = + { md_type = Mty_signature sign; + md_loc = Location.none; + md_attributes = []; + md_uid = Uid.of_compilation_unit_id id; + } + in + let mda_address = Lazy_backtrack.create_forced (Aident id) in + let mda_declaration = + Subst.(Lazy.module_decl Make_local identity (Lazy.of_module_decl md)) + in + let mda_shape = Shape.for_persistent_unit name in + let mda_components = + let mty = Subst.Lazy.of_modtype (Mty_signature sign) in + let mty = + if freshen then + Subst.Lazy.modtype (Subst.Rescope (Path.scope path)) + Subst.identity mty + else mty + in + components_of_module ~alerts ~uid:md.md_uid + empty Subst.identity + path mda_address mty mda_shape + in + { + mda_declaration; + mda_components; + mda_address; + mda_shape; + } + +let read_sign_of_cmi = sign_of_cmi ~freshen:true + +let save_sign_of_cmi = sign_of_cmi ~freshen:false + +let persistent_env : module_data Persistent_env.t ref = + s_table Persistent_env.empty () + +let without_cmis f x = + Persistent_env.without_cmis !persistent_env f x + +let imports () = Persistent_env.imports !persistent_env + +let import_crcs ~source crcs = + Persistent_env.import_crcs !persistent_env ~source crcs + +let read_pers_mod cmi = + Persistent_env.read !persistent_env read_sign_of_cmi cmi + +let find_pers_mod name = + Persistent_env.find !persistent_env read_sign_of_cmi name + +let check_pers_mod ~loc name = + Persistent_env.check !persistent_env read_sign_of_cmi ~loc name + +let crc_of_unit name = + Persistent_env.crc_of_unit !persistent_env read_sign_of_cmi name + +let is_imported_opaque modname = + Persistent_env.is_imported_opaque !persistent_env modname + +let register_import_as_opaque modname = + Persistent_env.register_import_as_opaque !persistent_env modname + +let reset_declaration_caches () = + Types.Uid.Tbl.clear !value_declarations; + Types.Uid.Tbl.clear !type_declarations; + Types.Uid.Tbl.clear !module_declarations; + Types.Uid.Tbl.clear !used_constructors; + Types.Uid.Tbl.clear !used_labels; + () + +let reset_cache () = + Current_unit.unset (); + Persistent_env.clear !persistent_env; + reset_declaration_caches (); + () + +let reset_cache_toplevel () = + Persistent_env.clear_missing !persistent_env; + reset_declaration_caches (); + () + +(* get_components *) + +let get_components_res c = + match Persistent_env.can_load_cmis !persistent_env with + | Persistent_env.Can_load_cmis -> + Lazy_backtrack.force !components_of_module_maker' c.comps + | Persistent_env.Cannot_load_cmis log -> + Lazy_backtrack.force_logged log !components_of_module_maker' c.comps + +let get_components c = + match get_components_res c with + | Error _ -> empty_structure + | Ok c -> c + +(* Module type of functor application *) + +let modtype_of_functor_appl fcomp p1 p2 = + match fcomp.fcomp_res with + | Mty_alias _ as mty -> mty + | mty -> + try + Hashtbl.find fcomp.fcomp_subst_cache p2 + with Not_found -> + let scope = Path.scope (Papply(p1, p2)) in + let mty = + let subst = + match fcomp.fcomp_arg with + | Unit + | Named (None, _) -> Subst.identity + | Named (Some param, _) -> Subst.add_module param p2 Subst.identity + in + Subst.modtype (Rescope scope) subst mty + in + Hashtbl.add fcomp.fcomp_subst_cache p2 mty; + mty + +let check_functor_appl + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~f_comp + ~arg_path ~arg_mty ~param_mty + env = + if not (Hashtbl.mem f_comp.fcomp_cache arg_path) then + !check_functor_application + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~arg_path ~arg_mty ~param_mty + env + +(* Lookup by identifier *) + +let find_ident_module id env = + match find_same_module id env.modules with + | Mod_local data -> data + | Mod_unbound _ -> raise Not_found + | Mod_persistent -> find_pers_mod ~allow_hidden:true (Ident.name id) + +let rec find_module_components path env = + match path with + | Pident id -> (find_ident_module id env).mda_components + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_modules).mda_components + | Papply(f_path, arg) -> + let f_comp = find_functor_components f_path env in + let loc = Location.(in_file !input_name) in + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env + | Pextra_ty _ -> raise Not_found + +and find_structure_components path env = + match get_components (find_module_components path env) with + | Structure_comps c -> c + | Functor_comps _ -> raise Not_found + +and find_functor_components path env = + match get_components (find_module_components path env) with + | Functor_comps f -> f + | Structure_comps _ -> raise Not_found + +let find_module ~alias path env = + match path with + | Pident id -> + let data = find_ident_module id env in + Subst.Lazy.force_module_decl data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + Subst.Lazy.force_module_decl data.mda_declaration + | Papply(p1, p2) -> + let fc = find_functor_components p1 env in + if alias then md (fc.fcomp_res) + else md (modtype_of_functor_appl fc p1 p2) + | Pextra_ty _ -> raise Not_found + +let find_module_lazy ~alias path env = + match path with + | Pident id -> + let data = find_ident_module id env in + data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + data.mda_declaration + | Papply(p1, p2) -> + let fc = find_functor_components p1 env in + let md = + if alias then md (fc.fcomp_res) + else md (modtype_of_functor_appl fc p1 p2) + in + Subst.Lazy.of_module_decl md + | Pextra_ty _ -> raise Not_found + +let find_strengthened_module ~aliasable path env = + let md = find_module_lazy ~alias:true path env in + let mty = !strengthen ~aliasable env md.mdl_type path in + Subst.Lazy.force_modtype mty + +let find_value_full path env = + match path with + | Pident id -> begin + match IdTbl.find_same id env.values with + | Val_bound data -> data + | Val_unbound _ -> raise Not_found + end + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_values + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_extension_full path env = + match path with + | Pident id -> TycompTbl.find_same id env.constrs + | Pdot(p, s) -> begin + let comps = find_structure_components p env in + let cstrs = NameMap.find s comps.comp_constrs in + let exts = List.filter is_ext cstrs in + match exts with + | [cda] -> cda + | _ -> raise Not_found + end + | Papply _ | Pextra_ty _ -> raise Not_found + +let type_of_cstr path = function + | {cstr_inlined = Some decl; _} -> + let labels = + List.map snd (Datarepr.labels_of_type path decl) + in + begin match decl.type_kind with + | Type_record (_, repr) -> + { + tda_declaration = decl; + tda_descriptions = Type_record (labels, repr); + tda_shape = Shape.leaf decl.type_uid; + } + | _ -> assert false + end + | _ -> assert false + +let rec find_type_data path env = + match Path.Map.find path env.local_constraints with + | decl -> + { + tda_declaration = decl; + tda_descriptions = Type_abstract (Btype.type_origin decl); + tda_shape = Shape.leaf decl.type_uid; + } + | exception Not_found -> begin + match path with + | Pident id -> IdTbl.find_same id env.types + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_types + | Papply _ -> raise Not_found + | Pextra_ty (p, extra) -> begin + match extra with + | Pcstr_ty s -> + let cstr = find_cstr p s env in + type_of_cstr path cstr + | Pext_ty -> + let cda = find_extension_full p env in + type_of_cstr path cda.cda_description + end + end +and find_cstr path name env = + let tda = find_type_data path env in + match tda.tda_descriptions with + | Type_variant (cstrs, _) -> + List.find (fun cstr -> cstr.cstr_name = name) cstrs + | Type_record _ | Type_abstract _ | Type_open -> raise Not_found + + + +let find_modtype_lazy path env = + match path with + | Pident id -> (IdTbl.find_same id env.modtypes).mtda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_modtypes).mtda_declaration + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_modtype path env = + Subst.Lazy.force_modtype_decl (find_modtype_lazy path env) + +let find_class_full path env = + match path with + | Pident id -> IdTbl.find_same id env.classes + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_classes + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_cltype path env = + match path with + | Pident id -> (IdTbl.find_same id env.cltypes).cltda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_cltypes).cltda_declaration + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_value path env = + (find_value_full path env).vda_description + +let find_class path env = + (find_class_full path env).clda_declaration + +let find_ident_constructor id env = + (TycompTbl.find_same id env.constrs).cda_description + +let find_ident_label id env = + TycompTbl.find_same id env.labels + +let find_type p env = + (find_type_data p env).tda_declaration +let find_type_descrs p env = + (find_type_data p env).tda_descriptions + +let rec find_module_address path env = + match path with + | Pident id -> get_address (find_ident_module id env).mda_address + | Pdot(p, s) -> + let c = find_structure_components p env in + get_address (NameMap.find s c.comp_modules).mda_address + | Papply _ | Pextra_ty _ -> raise Not_found + +and force_address = function + | Projection { parent; pos } -> Adot(get_address parent, pos) + | ModAlias { env; path } -> find_module_address path env + +and get_address a = + Lazy_backtrack.force force_address a + +let find_value_address path env = + get_address (find_value_full path env).vda_address + +let find_class_address path env = + get_address (find_class_full path env).clda_address + +let rec get_constrs_address = function + | [] -> raise Not_found + | cda :: rest -> + match cda.cda_address with + | None -> get_constrs_address rest + | Some a -> get_address a + +let find_constructor_address path env = + match path with + | Pident id -> begin + let cda = TycompTbl.find_same id env.constrs in + match cda.cda_address with + | None -> raise Not_found + | Some addr -> get_address addr + end + | Pdot(p, s) -> + let c = find_structure_components p env in + get_constrs_address (NameMap.find s c.comp_constrs) + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_hash_type path env = + match path with + | Pident id -> + let name = Ident.name id in + let _, cltda = + IdTbl.find_name wrap_identity ~mark:false name env.cltypes + in + cltda.cltda_declaration.clty_hash_type + | Pdot(p, name) -> + let c = find_structure_components p env in + let cltda = NameMap.find name c.comp_cltypes in + cltda.cltda_declaration.clty_hash_type + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_shape env (ns : Shape.Sig_component_kind.t) id = + match ns with + | Type -> + (IdTbl.find_same id env.types).tda_shape + | Constructor -> + Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid) + | Label -> + Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid) + | Extension_constructor -> + (TycompTbl.find_same id env.constrs).cda_shape + | Value -> + begin match IdTbl.find_same id env.values with + | Val_bound x -> x.vda_shape + | Val_unbound _ -> raise Not_found + end + | Module -> + begin match IdTbl.find_same id env.modules with + | Mod_local { mda_shape; _ } -> mda_shape + | Mod_persistent -> Shape.for_persistent_unit (Ident.name id) + | Mod_unbound _ -> + (* Only present temporarily while approximating the environment for + recursive modules. + [find_shape] is only ever called after the environment gets + properly populated. *) + assert false + | exception Not_found + when Ident.persistent id && not (Current_unit.Name.is_ident id) -> + Shape.for_persistent_unit (Ident.name id) + end + | Module_type -> + (IdTbl.find_same id env.modtypes).mtda_shape + | Class -> + (IdTbl.find_same id env.classes).clda_shape + | Class_type -> + (IdTbl.find_same id env.cltypes).cltda_shape + +let shape_of_path ~namespace env = + Shape.of_path ~namespace ~find_shape:(find_shape env) + +let shape_or_leaf uid = function + | None -> Shape.leaf uid + | Some shape -> shape + +let required_globals = s_ref [] +let reset_required_globals () = required_globals := [] +let get_required_globals () = !required_globals +let add_required_global id = + if Ident.global id && not !Clflags.transparent_modules + && not (List.exists (Ident.same id) !required_globals) + then required_globals := id :: !required_globals + +let rec normalize_module_path lax env = function + | Pident id as path when lax && Ident.persistent id -> + path (* fast path (avoids lookup) *) + | Pdot (p, s) as path -> + let p' = normalize_module_path lax env p in + if p == p' then expand_module_path lax env path + else expand_module_path lax env (Pdot(p', s)) + | Papply (p1, p2) as path -> + let p1' = normalize_module_path lax env p1 in + let p2' = normalize_module_path true env p2 in + if p1 == p1' && p2 == p2' then expand_module_path lax env path + else expand_module_path lax env (Papply(p1', p2')) + | Pident _ as path -> + expand_module_path lax env path + | Pextra_ty _ -> assert false + +and expand_module_path lax env path = + try match find_module_lazy ~alias:true path env with + {mdl_type=MtyL_alias path1} -> + let path' = normalize_module_path lax env path1 in + if lax || !Clflags.transparent_modules then path' else + let id = Path.head path in + if Ident.global id && not (Ident.same id (Path.head path')) + then add_required_global id; + path' + | _ -> path + with Not_found when lax + || (match path with Pident id -> not (Ident.persistent id) | _ -> true) -> + path + +let normalize_module_path oloc env path = + try normalize_module_path (oloc = None) env path + with Not_found -> + match oloc with None -> assert false + | Some loc -> + error (Missing_module(loc, path, + normalize_module_path true env path)) + +let rec normalize_path_prefix oloc env path = + match path with + | Pdot(p, s) -> + let p2 = normalize_module_path oloc env p in + if p == p2 then path else Pdot(p2, s) + | Pident _ -> + path + | Pextra_ty (p, extra) -> + let p2 = normalize_path_prefix oloc env p in + if p == p2 then path else Pextra_ty (p2, extra) + | Papply _ -> + assert false + +let normalize_type_path = normalize_path_prefix + +let normalize_value_path = normalize_path_prefix + +let rec normalize_modtype_path env path = + let path = normalize_path_prefix None env path in + expand_modtype_path env path + +and expand_modtype_path env path = + match (find_modtype_lazy path env).mtdl_type with + | Some (MtyL_ident path) -> normalize_modtype_path env path + | _ | exception Not_found -> path + +let find_module path env = + find_module ~alias:false path env + +let find_module_lazy path env = + find_module_lazy ~alias:false path env + +(* Find the manifest type associated to a type when appropriate: + - the type should be public or should have a private row, + - the type should have an associated manifest type. *) +let find_type_expansion path env = + let decl = find_type path env in + match decl.type_manifest with + | Some body when decl.type_private = Public + || not (Btype.type_kind_is_abstract decl) + || Btype.has_constr_row body -> + (decl.type_params, body, decl.type_expansion_scope) + (* The manifest type of Private abstract data types without + private row are still considered unknown to the type system. + Hence, this case is caught by the following clause that also handles + purely abstract data types without manifest type definition. *) + | _ -> raise Not_found + +(* Find the manifest type information associated to a type, i.e. + the necessary information for the compiler's type-based optimisations. + In particular, the manifest type associated to a private abstract type + is revealed for the sake of compiler's type-based optimisations. *) +let find_type_expansion_opt path env = + let decl = find_type path env in + match decl.type_manifest with + (* The manifest type of Private abstract data types can still get + an approximation using their manifest type. *) + | Some body -> + (decl.type_params, body, decl.type_expansion_scope) + | _ -> raise Not_found + +let find_modtype_expansion_lazy path env = + match (find_modtype_lazy path env).mtdl_type with + | None -> raise Not_found + | Some mty -> mty + +let find_modtype_expansion path env = + Subst.Lazy.force_modtype (find_modtype_expansion_lazy path env) + +let rec is_functor_arg path env = + match path with + Pident id -> + begin try Ident.find_same id env.functor_args; true + with Not_found -> false + end + | Pdot (p, _) | Pextra_ty (p, _) -> is_functor_arg p env + | Papply _ -> true + +(* Copying types associated with values *) + +let make_copy_of_types env0 = + let memo = Hashtbl.create 16 in + let copy t = + try + Hashtbl.find memo (get_id t) + with Not_found -> + let t2 = Subst.type_expr Subst.identity t in + Hashtbl.add memo (get_id t) t2; + t2 + in + let f = function + | Val_unbound _ as entry -> entry + | Val_bound vda -> + let desc = vda.vda_description in + let desc = { desc with val_type = copy desc.val_type } in + Val_bound { vda with vda_description = desc } + in + let values = + IdTbl.map f env0.values + in + (fun env -> + (*if env.values != env0.values then fatal_error "Env.make_copy_of_types";*) + {env with values; summary = Env_copy_types env.summary} + ) + +(* Iter on an environment (ignoring the body of functors and + not yet evaluated structures) *) + +type iter_cont = unit -> unit +let iter_env_cont = ref [] + +let rec scrape_alias_for_visit env mty = + let open Subst.Lazy in + match mty with + | MtyL_alias path -> begin + match path with + | Pident id + when Ident.persistent id + && not (Persistent_env.looked_up !persistent_env (Ident.name id)) -> + false + | path -> (* PR#6600: find_module may raise Not_found *) + try + scrape_alias_for_visit env (find_module_lazy path env).mdl_type + with Not_found -> false + end + | _ -> true + +let iter_env wrap proj1 proj2 f env () = + IdTbl.iter wrap (fun id x -> f (Pident id) x) (proj1 env); + let rec iter_components path path' mcomps = + let cont () = + let visit = + match Lazy_backtrack.get_arg mcomps.comps with + | None -> true + | Some { cm_mty; _ } -> + scrape_alias_for_visit env cm_mty + in + if not visit then () else + match get_components mcomps with + Structure_comps comps -> + NameMap.iter + (fun s d -> f (Pdot (path, s)) (Pdot (path', s), d)) + (proj2 comps); + NameMap.iter + (fun s mda -> + iter_components + (Pdot (path, s)) (Pdot (path', s)) mda.mda_components) + comps.comp_modules + | Functor_comps _ -> () + in iter_env_cont := (path, cont) :: !iter_env_cont + in + IdTbl.iter wrap_module + (fun id (path, entry) -> + match entry with + | Mod_unbound _ -> () + | Mod_local data -> + iter_components (Pident id) path data.mda_components + | Mod_persistent -> + let modname = Ident.name id in + match Persistent_env.find_in_cache !persistent_env modname with + | None -> () + | Some data -> + iter_components (Pident id) path data.mda_components) + env.modules + +let run_iter_cont l = + iter_env_cont := []; + List.iter (fun c -> c ()) l; + let cont = List.rev !iter_env_cont in + iter_env_cont := []; + cont + +let iter_types f = + iter_env wrap_identity (fun env -> env.types) (fun sc -> sc.comp_types) + (fun p1 (p2, tda) -> f p1 (p2, tda.tda_declaration)) + +let same_types env1 env2 = + env1.types == env2.types && env1.modules == env2.modules + +let used_persistent () = + Persistent_env.fold !persistent_env + (fun s _m r -> String.Set.add s r) + String.Set.empty + +let find_all_comps wrap proj s (p, mda) = + match get_components mda.mda_components with + Functor_comps _ -> [] + | Structure_comps comps -> + try + let c = NameMap.find s (proj comps) in + [Pdot(p,s), wrap c] + with Not_found -> [] + +let rec find_shadowed_comps path env = + match path with + | Pident id -> + List.filter_map + (fun (p, data) -> + match data with + | Mod_local x -> Some (p, x) + | Mod_unbound _ | Mod_persistent -> None) + (IdTbl.find_all wrap_module (Ident.name id) env.modules) + | Pdot (p, s) -> + let l = find_shadowed_comps p env in + let l' = + List.map + (find_all_comps wrap_identity + (fun comps -> comps.comp_modules) s) l + in + List.flatten l' + | Papply _ | Pextra_ty _ -> [] + +let find_shadowed wrap proj1 proj2 path env = + match path with + Pident id -> + IdTbl.find_all wrap (Ident.name id) (proj1 env) + | Pdot (p, s) -> + let l = find_shadowed_comps p env in + let l' = List.map (find_all_comps wrap proj2 s) l in + List.flatten l' + | Papply _ | Pextra_ty _ -> [] + +let find_shadowed_types path env = + List.map fst + (find_shadowed wrap_identity + (fun env -> env.types) (fun comps -> comps.comp_types) path env) + +(* Expand manifest module type names at the top of the given module type *) + +let rec scrape_alias env ?path mty = + let open Subst.Lazy in + match mty, path with + MtyL_ident p, _ -> + begin try + scrape_alias env (find_modtype_expansion_lazy p env) ?path + with Not_found -> + mty + end + | MtyL_alias path, _ -> + begin try + scrape_alias env ((find_module_lazy path env).mdl_type) ~path + with Not_found -> + (*Location.prerr_warning Location.none + (Warnings.No_cmi_file (Path.name path));*) + mty + end + | mty, Some path -> + !strengthen ~aliasable:true env mty path + | _ -> mty + +(* Given a signature and a root path, prefix all idents in the signature + by the root path and build the corresponding substitution. *) + +let prefix_idents root prefixing_sub sg = + let open Subst.Lazy in + let rec prefix_idents root items_and_paths prefixing_sub = + function + | [] -> (List.rev items_and_paths, prefixing_sub) + | SigL_value(id, _, _) as item :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((item, p) :: items_and_paths) prefixing_sub rem + | SigL_type(id, td, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_type(id, td, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_typext(id, ec, es, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + (* we extend the substitution in case of an inlined record *) + prefix_idents root + ((SigL_typext(id, ec, es, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_module(id, pres, md, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_module(id, pres, md, rs, vis), p) :: items_and_paths) + (Subst.add_module id p prefixing_sub) + rem + | SigL_modtype(id, mtd, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_modtype(id, mtd, vis), p) :: items_and_paths) + (Subst.add_modtype id (Mty_ident p) prefixing_sub) + rem + | SigL_class(id, cd, rs, vis) :: rem -> + (* pretend this is a type, cf. PR#6650 *) + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class(id, cd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_class_type(id, ctd, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class_type(id, ctd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + in + let sg = Subst.Lazy.force_signature_once sg in + prefix_idents root [] prefixing_sub sg + +(* Compute structure descriptions *) + +let add_to_tbl id decl tbl = + let decls = try NameMap.find id tbl with Not_found -> [] in + NameMap.add id (decl :: decls) tbl + +let value_declaration_address (_ : t) id decl = + match decl.val_kind with + | Val_prim _ -> Lazy_backtrack.create_failed Not_found + | _ -> Lazy_backtrack.create_forced (Aident id) + +let extension_declaration_address (_ : t) id (_ : extension_constructor) = + Lazy_backtrack.create_forced (Aident id) + +let class_declaration_address (_ : t) id (_ : class_declaration) = + Lazy_backtrack.create_forced (Aident id) + +let module_declaration_address env id presence md = + match presence with + | Mp_absent -> begin + let open Subst.Lazy in + match md.mdl_type with + | MtyL_alias path -> Lazy_backtrack.create (ModAlias {env; path}) + | _ -> assert false + end + | Mp_present -> + Lazy_backtrack.create_forced (Aident id) + +let rec components_of_module_maker + {cm_env; cm_prefixing_subst; + cm_path; cm_addr; cm_mty; cm_shape} : _ result = + match scrape_alias cm_env cm_mty with + MtyL_signature sg -> + let c = + { comp_values = NameMap.empty; + comp_constrs = NameMap.empty; + comp_labels = NameMap.empty; comp_types = NameMap.empty; + comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; + comp_classes = NameMap.empty; comp_cltypes = NameMap.empty } + in + let items_and_paths, sub = + prefix_idents cm_path cm_prefixing_subst sg + in + let env = ref cm_env in + let pos = ref 0 in + let next_address () = + let addr : address_unforced = + Projection { parent = cm_addr; pos = !pos } + in + incr pos; + Lazy_backtrack.create addr + in + List.iter (fun ((item : Subst.Lazy.signature_item), path) -> + match item with + SigL_value(id, decl, _) -> + let decl' = Subst.value_description sub decl in + let addr = + match decl.val_kind with + | Val_prim _ -> Lazy_backtrack.create_failed Not_found + | _ -> next_address () + in + let vda_shape = Shape.proj cm_shape (Shape.Item.value id) in + let vda = + { vda_description = decl'; vda_address = addr; vda_shape } + in + c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values; + | SigL_type(id, decl, _, _) -> + let final_decl = Subst.type_declaration sub decl in + Btype.set_static_row_name final_decl + (Subst.type_path sub (Path.Pident id)); + let descrs = + match decl.type_kind with + | Type_variant (_,repr) -> + let cstrs = List.map snd + (Datarepr.constructors_of_type path final_decl + ~current_unit:(get_current_unit ())) + in + List.iter + (fun descr -> + let cda_shape = Shape.leaf descr.cstr_uid in + let cda = { + cda_description = descr; + cda_address = None; + cda_shape } + in + c.comp_constrs <- + add_to_tbl descr.cstr_name cda c.comp_constrs + ) cstrs; + Type_variant (cstrs, repr) + | Type_record (_, repr) -> + let lbls = List.map snd + (Datarepr.labels_of_type path final_decl) + in + List.iter + (fun descr -> + c.comp_labels <- + add_to_tbl descr.lbl_name descr c.comp_labels) + lbls; + Type_record (lbls, repr) + | Type_abstract r -> Type_abstract r + | Type_open -> Type_open + in + let shape = Shape.proj cm_shape (Shape.Item.type_ id) in + let tda = + { tda_declaration = final_decl; + tda_descriptions = descrs; + tda_shape = shape; } + in + c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types; + env := store_type_infos ~tda_shape:shape id decl !env + | SigL_typext(id, ext, _, _) -> + let ext' = Subst.extension_constructor sub ext in + let descr = + Datarepr.extension_descr ~current_unit:(get_current_unit ()) path + ext' + in + let addr = next_address () in + let cda_shape = + Shape.proj cm_shape (Shape.Item.extension_constructor id) + in + let cda = + { cda_description = descr; cda_address = Some addr; cda_shape } + in + c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs + | SigL_module(id, pres, md, _, _) -> + let md' = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.module_decl + (Subst.Rescope (Path.scope cm_path)) sub md + in + let addr = + match pres with + | Mp_absent -> begin + match md.mdl_type with + | MtyL_alias path -> + Lazy_backtrack.create (ModAlias {env = !env; path}) + | _ -> assert false + end + | Mp_present -> next_address () + in + let alerts = + Builtin_attributes.alerts_of_attrs md.mdl_attributes + in + let shape = Shape.proj cm_shape (Shape.Item.module_ id) in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid !env + sub path addr md.mdl_type shape + in + let mda = + { mda_declaration = md'; + mda_components = comps; + mda_address = addr; + mda_shape = shape; } + in + c.comp_modules <- + NameMap.add (Ident.name id) mda c.comp_modules; + env := + store_module ~update_summary:false ~check:None + id addr pres md shape !env + | SigL_modtype(id, decl, _) -> + let final_decl = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.modtype_decl (Rescope (Path.scope cm_path)) + sub decl + in + let shape = Shape.proj cm_shape (Shape.Item.module_type id) in + let mtda = + { mtda_declaration = final_decl; + mtda_shape = shape; } + in + c.comp_modtypes <- + NameMap.add (Ident.name id) mtda c.comp_modtypes; + env := store_modtype ~update_summary:false id decl shape !env + | SigL_class(id, decl, _, _) -> + let decl' = Subst.class_declaration sub decl in + let addr = next_address () in + let shape = Shape.proj cm_shape (Shape.Item.class_ id) in + let clda = + { clda_declaration = decl'; + clda_address = addr; + clda_shape = shape; } + in + c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes + | SigL_class_type(id, decl, _, _) -> + let decl' = Subst.cltype_declaration sub decl in + let shape = Shape.proj cm_shape (Shape.Item.class_type id) in + let cltda = { cltda_declaration = decl'; cltda_shape = shape } in + c.comp_cltypes <- + NameMap.add (Ident.name id) cltda c.comp_cltypes) + items_and_paths; + Ok (Structure_comps c) + | MtyL_functor(arg, ty_res) -> + let sub = cm_prefixing_subst in + let scoping = Subst.Rescope (Path.scope cm_path) in + let open Subst.Lazy in + Ok (Functor_comps { + (* fcomp_arg and fcomp_res must be prefixed eagerly, because + they are interpreted in the outer environment *) + fcomp_arg = + (match arg with + | Unit -> Unit + | Named (param, ty_arg) -> + Named (param, force_modtype (modtype scoping sub ty_arg))); + fcomp_res = force_modtype (modtype scoping sub ty_res); + fcomp_shape = cm_shape; + fcomp_cache = Hashtbl.create 17; + fcomp_subst_cache = Hashtbl.create 17 }) + | MtyL_ident _ -> Error No_components_abstract + | MtyL_alias p -> Error (No_components_alias p) + +(* Insertion of bindings by identifier + path *) + +and check_usage loc id uid warn tbl = + if not loc.Location.loc_ghost && + Uid.for_actual_declaration uid && + Warnings.is_active (warn "") + then begin + let name = Ident.name id in + if Types.Uid.Tbl.mem tbl uid then () + else let used = ref false in + Types.Uid.Tbl.add tbl uid (fun () -> used := true); + if not (name = "" || name.[0] = '_' || name.[0] = '#') + then + !add_delayed_check_forward + (fun () -> if not !used then Location.prerr_warning loc (warn name)) + end; + +and check_value_name name loc = + (* Note: we could also check here general validity of the + identifier, to protect against bad identifiers forged by -pp or + -ppx preprocessors. *) + if String.length name > 0 && not + (Utf8_lexeme.starts_like_a_valid_identifier name) then + for i = 1 to String.length name - 1 do + if name.[i] = '#' then + error (Illegal_value_name(loc, name)) + done + +and store_value ?check id addr decl shape env = + check_value_name (Ident.name id) decl.val_loc; + Builtin_attributes.mark_alerts_used decl.val_attributes; + Option.iter + (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations) + check; + let vda = + { vda_description = decl; + vda_address = addr; + vda_shape = shape } + in + { env with + values = IdTbl.add id (Val_bound vda) env.values; + summary = Env_value(env.summary, id, decl) } + +and store_constructor ~check type_decl type_id cstr_id cstr env = + Builtin_attributes.warning_scope cstr.cstr_attributes (fun () -> + if check && not type_decl.type_loc.Location.loc_ghost + && Warnings.is_active (Warnings.Unused_constructor ("", Unused)) + then begin + let ty_name = Ident.name type_id in + let name = cstr.cstr_name in + let loc = cstr.cstr_loc in + let k = cstr.cstr_uid in + let priv = type_decl.type_private in + if not (Types.Uid.Tbl.mem !used_constructors k) then begin + let used = constructor_usages () in + Types.Uid.Tbl.add !used_constructors k + (add_constructor_usage used); + if not (ty_name = "" || ty_name.[0] = '_') + then + !add_delayed_check_forward + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning loc + (Warnings.Unused_constructor(name, complaint))) + (constructor_usage_complaint ~rebind:false priv used)); + end; + end); + Builtin_attributes.mark_alerts_used cstr.cstr_attributes; + Builtin_attributes.mark_warn_on_literal_pattern_used cstr.cstr_attributes; + let cda_shape = Shape.leaf cstr.cstr_uid in + { env with + constrs = + TycompTbl.add cstr_id + { cda_description = cstr; cda_address = None; cda_shape } env.constrs; + } + +and store_label ~check type_decl type_id lbl_id lbl env = + Builtin_attributes.warning_scope lbl.lbl_attributes (fun () -> + if check && not type_decl.type_loc.Location.loc_ghost + && Warnings.is_active (Warnings.Unused_field ("", Unused)) + then begin + let ty_name = Ident.name type_id in + let priv = type_decl.type_private in + let name = lbl.lbl_name in + let loc = lbl.lbl_loc in + let mut = lbl.lbl_mut in + let k = lbl.lbl_uid in + if not (Types.Uid.Tbl.mem !used_labels k) then + let used = label_usages () in + Types.Uid.Tbl.add !used_labels k + (add_label_usage used); + if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_') + then !add_delayed_check_forward + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning + loc (Warnings.Unused_field(name, complaint))) + (label_usage_complaint priv mut used)) + end); + Builtin_attributes.mark_alerts_used lbl.lbl_attributes; + if lbl.lbl_mut = Mutable then + Builtin_attributes.mark_deprecated_mutable_used lbl.lbl_attributes; + { env with + labels = TycompTbl.add lbl_id lbl env.labels; + } + +and store_type ~check id info shape env = + let loc = info.type_loc in + if check then + check_usage loc id info.type_uid + (fun s -> Warnings.Unused_type_declaration s) + !type_declarations; + let descrs, env = + let path = Pident id in + match info.type_kind with + | Type_variant (_,repr) -> + let constructors = Datarepr.constructors_of_type path info + ~current_unit:(get_current_unit ()) + in + Type_variant (List.map snd constructors, repr), + List.fold_left + (fun env (cstr_id, cstr) -> + store_constructor ~check info id cstr_id cstr env) + env constructors + | Type_record (_, repr) -> + let labels = Datarepr.labels_of_type path info in + Type_record (List.map snd labels, repr), + List.fold_left + (fun env (lbl_id, lbl) -> + store_label ~check info id lbl_id lbl env) + env labels + | Type_abstract r -> Type_abstract r, env + | Type_open -> Type_open, env + in + let tda = + { tda_declaration = info; + tda_descriptions = descrs; + tda_shape = shape } + in + Builtin_attributes.mark_alerts_used info.type_attributes; + { env with + types = IdTbl.add id tda env.types; + summary = Env_type(env.summary, id, info) } + +and store_type_infos ~tda_shape id info env = + (* Simplified version of store_type that doesn't compute and store + constructor and label infos, but simply record the arity and + manifest-ness of the type. Used in components_of_module to + keep track of type abbreviations (e.g. type t = float) in the + computation of label representations. *) + let tda = + { + tda_declaration = info; + tda_descriptions = Type_abstract (Btype.type_origin info); + tda_shape + } + in + { env with + types = IdTbl.add id tda env.types; + summary = Env_type(env.summary, id, info) } + +and store_extension ~check ~rebind id addr ext shape env = + let loc = ext.ext_loc in + let cstr = + Datarepr.extension_descr + ~current_unit:(get_current_unit ()) (Pident id) ext + in + let cda = + { cda_description = cstr; + cda_address = Some addr; + cda_shape = shape } + in + Builtin_attributes.mark_alerts_used ext.ext_attributes; + Builtin_attributes.mark_warn_on_literal_pattern_used ext.ext_attributes; + Builtin_attributes.warning_scope ext.ext_attributes (fun () -> + if check && not loc.Location.loc_ghost && + Warnings.is_active (Warnings.Unused_extension ("", false, Unused)) + then begin + let priv = ext.ext_private in + let is_exception = Path.same ext.ext_type_path Predef.path_exn in + let name = cstr.cstr_name in + let k = cstr.cstr_uid in + if not (Types.Uid.Tbl.mem !used_constructors k) then begin + let used = constructor_usages () in + Types.Uid.Tbl.add !used_constructors k + (add_constructor_usage used); + !add_delayed_check_forward + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning loc + (Warnings.Unused_extension + (name, is_exception, complaint))) + (constructor_usage_complaint ~rebind priv used)) + end; + end); + { env with + constrs = TycompTbl.add id cda env.constrs; + summary = Env_extension(env.summary, id, ext) } + +and store_module ?(update_summary=true) ~check + id addr presence md shape env = + let open Subst.Lazy in + let loc = md.mdl_loc in + Option.iter + (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check; + Builtin_attributes.mark_alerts_used md.mdl_attributes; + let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid + env Subst.identity (Pident id) addr md.mdl_type shape + in + let mda = + { mda_declaration = md; + mda_components = comps; + mda_address = addr; + mda_shape = shape } + in + let summary = + if not update_summary then env.summary + else Env_module (env.summary, id, presence, force_module_decl md) in + { env with + modules = IdTbl.add id (Mod_local mda) env.modules; + summary } + +and store_modtype ?(update_summary=true) id info shape env = + Builtin_attributes.mark_alerts_used info.Subst.Lazy.mtdl_attributes; + let mtda = { mtda_declaration = info; mtda_shape = shape } in + let summary = + if not update_summary then env.summary + else Env_modtype (env.summary, id, Subst.Lazy.force_modtype_decl info) in + { env with + modtypes = IdTbl.add id mtda env.modtypes; + summary } + +and store_class id addr desc shape env = + Builtin_attributes.mark_alerts_used desc.cty_attributes; + let clda = + { clda_declaration = desc; + clda_address = addr; + clda_shape = shape; } + in + { env with + classes = IdTbl.add id clda env.classes; + summary = Env_class(env.summary, id, desc) } + +and store_cltype id desc shape env = + Builtin_attributes.mark_alerts_used desc.clty_attributes; + let cltda = { cltda_declaration = desc; cltda_shape = shape } in + { env with + cltypes = IdTbl.add id cltda env.cltypes; + summary = Env_cltype(env.summary, id, desc) } + +let scrape_alias env mty = scrape_alias env mty + +(* Compute the components of a functor application in a path. *) + +let components_of_functor_appl ~loc ~f_path ~f_comp ~arg env = + try + let c = Hashtbl.find f_comp.fcomp_cache arg in + c + with Not_found -> + let p = Papply(f_path, arg) in + let sub = + match f_comp.fcomp_arg with + | Unit + | Named (None, _) -> Subst.identity + | Named (Some param, _) -> Subst.add_module param arg Subst.identity + in + (* we have to apply eagerly instead of passing sub to [components_of_module] + because of the call to [check_well_formed_module]. *) + let mty = Subst.modtype (Rescope (Path.scope p)) sub f_comp.fcomp_res in + let addr = Lazy_backtrack.create_failed Not_found in + !check_well_formed_module env loc + ("the signature of " ^ Path.name p) mty; + let shape_arg = + shape_of_path ~namespace:Shape.Sig_component_kind.Module env arg + in + let shape = Shape.app f_comp.fcomp_shape ~arg:shape_arg in + let comps = + components_of_module ~alerts:Misc.Stdlib.String.Map.empty + ~uid:Uid.internal_not_actually_unique + (*???*) + env Subst.identity p addr (Subst.Lazy.of_modtype mty) shape + in + Hashtbl.add f_comp.fcomp_cache arg comps; + comps + +(* Define forward functions *) + +let _ = + components_of_functor_appl' := components_of_functor_appl; + components_of_module_maker' := components_of_module_maker + +(* Insertion of bindings by identifier *) + +let add_functor_arg id env = + {env with + functor_args = Ident.add id () env.functor_args; + summary = Env_functor_arg (env.summary, id)} + +let add_value ?check ?shape id desc env = + let addr = value_declaration_address env id desc in + let shape = shape_or_leaf desc.val_uid shape in + store_value ?check id addr desc shape env + +let add_type ~check ?shape id info env = + let shape = shape_or_leaf info.type_uid shape in + store_type ~check id info shape env + +and add_extension ~check ?shape ~rebind id ext env = + let addr = extension_declaration_address env id ext in + let shape = shape_or_leaf ext.ext_uid shape in + store_extension ~check ~rebind id addr ext shape env + +and add_module_declaration ?(arg=false) ?shape ~check id presence md env = + let check = + if not check then + None + else if arg && is_in_signature env then + Some (fun s -> Warnings.Unused_functor_parameter s) + else + Some (fun s -> Warnings.Unused_module s) + in + let md = Subst.Lazy.of_module_decl md in + let addr = module_declaration_address env id presence md in + let shape = shape_or_leaf md.mdl_uid shape in + let env = store_module ~check id addr presence md shape env in + if arg then add_functor_arg id env else env + +and add_module_declaration_lazy ~update_summary id presence md env = + let addr = module_declaration_address env id presence md in + let shape = Shape.leaf md.Subst.Lazy.mdl_uid in + let env = + store_module ~update_summary ~check:None id addr presence md shape env + in + env + +and add_modtype ?shape id info env = + let shape = shape_or_leaf info.mtd_uid shape in + store_modtype id (Subst.Lazy.of_modtype_decl info) shape env + +and add_modtype_lazy ~update_summary id info env = + let shape = Shape.leaf info.Subst.Lazy.mtdl_uid in + store_modtype ~update_summary id info shape env + +and add_class ?shape id ty env = + let addr = class_declaration_address env id ty in + let shape = shape_or_leaf ty.cty_uid shape in + store_class id addr ty shape env + +and add_cltype ?shape id ty env = + let shape = shape_or_leaf ty.clty_uid shape in + store_cltype id ty shape env + +let add_module ?arg ?shape id presence mty env = + add_module_declaration ~check:false ?arg ?shape id presence (md mty) env + +let add_module_lazy ~update_summary id presence mty env = + let md = Subst.Lazy.{mdl_type = mty; + mdl_attributes = []; + mdl_loc = Location.none; + mdl_uid = Uid.internal_not_actually_unique} + in + add_module_declaration_lazy ~update_summary id presence md env + +let add_local_constraint path info env = + { env with + local_constraints = Path.Map.add path info env.local_constraints } + +(* Non-lazy version of scrape_alias *) +let scrape_alias t mty = + mty |> Subst.Lazy.of_modtype |> scrape_alias t |> Subst.Lazy.force_modtype + +(* Insertion of bindings by name *) + +let enter_value ?check name desc env = + let id = Ident.create_local name in + let addr = value_declaration_address env id desc in + let env = store_value ?check id addr desc (Shape.leaf desc.val_uid) env in + (id, env) + +let enter_type ~scope name info env = + let id = Ident.create_scoped ~scope name in + let env = store_type ~check:true id info (Shape.leaf info.type_uid) env in + (id, env) + +let enter_extension ~scope ~rebind name ext env = + let id = Ident.create_scoped ~scope name in + let addr = extension_declaration_address env id ext in + let shape = Shape.leaf ext.ext_uid in + let env = store_extension ~check:true ~rebind id addr ext shape env in + (id, env) + +let enter_module_declaration ~scope ?arg ?shape s presence md env = + let id = Ident.create_scoped ~scope s in + (id, add_module_declaration ?arg ?shape ~check:true id presence md env) + +let enter_modtype ~scope name mtd env = + let id = Ident.create_scoped ~scope name in + let shape = Shape.leaf mtd.mtd_uid in + let env = store_modtype id (Subst.Lazy.of_modtype_decl mtd) shape env in + (id, env) + +let enter_class ~scope name desc env = + let id = Ident.create_scoped ~scope name in + let addr = class_declaration_address env id desc in + let env = store_class id addr desc (Shape.leaf desc.cty_uid) env in + (id, env) + +let enter_cltype ~scope name desc env = + let id = Ident.create_scoped ~scope name in + let env = store_cltype id desc (Shape.leaf desc.clty_uid) env in + (id, env) + +let enter_module ~scope ?arg s presence mty env = + enter_module_declaration ~scope ?arg s presence (md mty) env + +(* Insertion of all components of a signature *) + +let add_item (map, mod_shape) comp env = + let proj_shape item = + match mod_shape with + | None -> map, None + | Some mod_shape -> + let shape = Shape.proj mod_shape item in + Shape.Map.add map item shape, Some shape + in + match comp with + | Sig_value(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.value id) in + map, add_value ?shape id decl env + | Sig_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.type_ id) in + map, add_type ~check:false ?shape id decl env + | Sig_typext(id, ext, _, _) -> + let map, shape = proj_shape (Shape.Item.extension_constructor id) in + map, add_extension ~check:false ?shape ~rebind:false id ext env + | Sig_module(id, presence, md, _, _) -> + let map, shape = proj_shape (Shape.Item.module_ id) in + map, add_module_declaration ~check:false ?shape id presence md env + | Sig_modtype(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.module_type id) in + map, add_modtype ?shape id decl env + | Sig_class(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_ id) in + map, add_class ?shape id decl env + | Sig_class_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_type id) in + map, add_cltype ?shape id decl env + +let rec add_signature (map, mod_shape) sg env = + match sg with + [] -> map, env + | comp :: rem -> + let map, env = add_item (map, mod_shape) comp env in + add_signature (map, mod_shape) rem env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + let sg = Subst.signature (Rescope scope) Subst.identity sg in + let shape, env = add_signature (parent_shape, mod_shape) sg env in + sg, shape, env + +let enter_signature ?mod_shape ~scope sg env = + let sg, _, env = + enter_signature_and_shape ~scope ~parent_shape:Shape.Map.empty + mod_shape sg env + in + sg, env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env + +let add_value = add_value ?shape:None +let add_class = add_class ?shape:None +let add_cltype = add_cltype ?shape:None +let add_modtype = add_modtype ?shape:None +let add_signature sg env = + let _, env = add_signature (Shape.Map.empty, None) sg env in + env + +(* Add "unbound" bindings *) + +let enter_unbound_value name reason env = + let id = Ident.create_local name in + { env with + values = IdTbl.add id (Val_unbound reason) env.values; + summary = Env_value_unbound(env.summary, name, reason) } + +let enter_unbound_module name reason env = + let id = Ident.create_local name in + { env with + modules = IdTbl.add id (Mod_unbound reason) env.modules; + summary = Env_module_unbound(env.summary, name, reason) } + +(* Open a signature path *) + +let add_components slot root env0 comps = + let add_l w comps env0 = + TycompTbl.add_open slot w root comps env0 + in + let add w comps env0 = IdTbl.add_open slot w root comps env0 in + let constrs = + add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs + in + let labels = + add_l (fun x -> `Label x) comps.comp_labels env0.labels + in + let values = + add (fun x -> `Value x) comps.comp_values env0.values + in + let types = + add (fun x -> `Type x) comps.comp_types env0.types + in + let modtypes = + add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes + in + let classes = + add (fun x -> `Class x) comps.comp_classes env0.classes + in + let cltypes = + add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes + in + let modules = + add (fun x -> `Module x) comps.comp_modules env0.modules + in + { env0 with + summary = Env_open(env0.summary, root); + constrs; + labels; + values; + types; + modtypes; + classes; + cltypes; + modules; + } + +let open_signature slot root env0 : (_,_) result = + match get_components_res (find_module_components root env0) with + | Error _ -> Error `Not_found + | exception Not_found -> Error `Not_found + | Ok (Functor_comps _) -> Error `Functor + | Ok (Structure_comps comps) -> + Ok (add_components slot root env0 comps) + +let remove_last_open root env0 = + let rec filter_summary summary = + match summary with + Env_empty -> raise Exit + | Env_open (s, p) -> + if Path.same p root then s else raise Exit + | Env_value _ + | Env_type _ + | Env_extension _ + | Env_module _ + | Env_modtype _ + | Env_class _ + | Env_cltype _ + | Env_functor_arg _ + | Env_constraints _ + | Env_persistent _ + | Env_copy_types _ + | Env_value_unbound _ + | Env_module_unbound _ -> + map_summary filter_summary summary + in + match filter_summary env0.summary with + | summary -> + let rem_l tbl = TycompTbl.remove_last_open root tbl + and rem tbl = IdTbl.remove_last_open root tbl in + Some { env0 with + summary; + constrs = rem_l env0.constrs; + labels = rem_l env0.labels; + values = rem env0.values; + types = rem env0.types; + modtypes = rem env0.modtypes; + classes = rem env0.classes; + cltypes = rem env0.cltypes; + modules = rem env0.modules; } + | exception Exit -> + None + +(* Open a signature from a file *) + +let open_pers_signature name env = + match open_signature None (Pident(Ident.create_persistent name)) env with + | (Ok _ | Error `Not_found as res) -> res + | Error `Functor -> assert false + (* a compilation unit cannot refer to a functor *) + +let open_signature + ?(used_slot = ref false) + ?(loc = Location.none) ?(toplevel = false) + ovf root env = + let unused = + match ovf with + | Asttypes.Fresh -> Warnings.Unused_open (Path.name root) + | Asttypes.Override -> Warnings.Unused_open_bang (Path.name root) + in + let warn_unused = + Warnings.is_active unused + and warn_shadow_id = + Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) + and warn_shadow_lc = + Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")) + in + if not toplevel && not loc.Location.loc_ghost + && (warn_unused || warn_shadow_id || warn_shadow_lc) + then begin + let used = used_slot in + if warn_unused then + !add_delayed_check_forward + (fun () -> + if not !used then begin + used := true; + Location.prerr_warning loc unused + end + ); + let shadowed = ref [] in + let slot s b = + begin match check_shadowing env b with + | Some kind when + ovf = Asttypes.Fresh && not (List.mem (kind, s) !shadowed) -> + shadowed := (kind, s) :: !shadowed; + let w = + match kind with + | "label" | "constructor" -> + Warnings.Open_shadow_label_constructor (kind, s) + | _ -> Warnings.Open_shadow_identifier (kind, s) + in + Location.prerr_warning loc w + | _ -> () + end; + used := true + in + open_signature (Some slot) root env + end + else open_signature None root env + +(* Read a signature from a file *) +let read_signature u = + let mda = read_pers_mod u in + let md = Subst.Lazy.force_module_decl mda.mda_declaration in + match md.md_type with + | Mty_signature sg -> sg + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false + + +let unit_name_of_filename fn = + match Filename.extension fn with + | ".cmi" -> + let modname = Unit_info.strict_modname_from_source fn in + if Unit_info.is_unit_name modname then Some modname + else None + | _ -> None + +let persistent_structures_of_dir dir = + Load_path.Dir.files dir + |> List.to_seq + |> Seq.filter_map unit_name_of_filename + |> String.Set.of_seq + +(* Save a signature to a file *) +let save_signature_with_transform cmi_transform ~alerts sg cmi_info = + Btype.cleanup_abbrev (); + Subst.reset_for_saving (); + let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in + let cmi = + Persistent_env.make_cmi !persistent_env + (Unit_info.Artifact.modname cmi_info) sg alerts + |> cmi_transform in + let filename = Unit_info.Artifact.filename cmi_info in + let pers_sig = + Persistent_env.Persistent_signature.{ cmi; filename; visibility = Visible } + in + let pm = save_sign_of_cmi pers_sig in + Persistent_env.save_cmi !persistent_env pers_sig pm; + cmi + +let save_signature ~alerts sg cmi = + save_signature_with_transform (fun cmi -> cmi) ~alerts sg cmi + +let save_signature_with_imports ~alerts sg cmi imports = + let with_imports cmi = { cmi with cmi_crcs = imports } in + save_signature_with_transform with_imports ~alerts sg cmi + +(* Make the initial environment *) +let initial = + Predef.build_initial_env + (add_type ~check:false) + (add_extension ~check:false ~rebind:false) + empty + +(* Tracking usage *) + +let mark_module_used uid = + match Types.Uid.Tbl.find !module_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let mark_modtype_used _uid = () + +let mark_value_used uid = + match Types.Uid.Tbl.find !value_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let mark_type_used uid = + match Types.Uid.Tbl.find !type_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let mark_type_path_used env path = + match find_type path env with + | decl -> mark_type_used decl.type_uid + | exception Not_found -> () + +let mark_constructor_used usage cd = + match Types.Uid.Tbl.find !used_constructors cd.cd_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_extension_used usage ext = + match Types.Uid.Tbl.find !used_constructors ext.ext_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_label_used usage ld = + match Types.Uid.Tbl.find !used_labels ld.ld_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_constructor_description_used usage env cstr = + let ty_path = Btype.cstr_type_path cstr in + mark_type_path_used env ty_path; + match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_label_description_used usage env lbl = + let ty_path = + match get_desc lbl.lbl_res with + | Tconstr(path, _, _) -> path + | _ -> assert false + in + mark_type_path_used env ty_path; + match Types.Uid.Tbl.find !used_labels lbl.lbl_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_class_used uid = + match Types.Uid.Tbl.find !type_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let mark_cltype_used uid = + match Types.Uid.Tbl.find !type_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let set_value_used_callback vd callback = + Types.Uid.Tbl.add !value_declarations vd.val_uid callback + +let set_type_used_callback td callback = + if Uid.for_actual_declaration td.type_uid then + let old = + try Types.Uid.Tbl.find !type_declarations td.type_uid + with Not_found -> ignore + in + Types.Uid.Tbl.replace !type_declarations td.type_uid + (fun () -> callback old) + +(* Lookup by name *) + +let may_lookup_error report_errors loc env err = + if report_errors then lookup_error loc env err + else raise Not_found + +let report_module_unbound ~errors ~loc env reason = + match reason with + | Mod_unbound_illegal_recursion -> + (* see #5965 *) + may_lookup_error errors loc env Illegal_reference_to_recursive_module + +let report_value_unbound ~errors ~loc env reason lid = + match reason with + | Val_unbound_instance_variable -> + may_lookup_error errors loc env (Masked_instance_variable lid) + | Val_unbound_self -> + may_lookup_error errors loc env (Masked_self_variable lid) + | Val_unbound_ancestor -> + may_lookup_error errors loc env (Masked_ancestor_variable lid) + | Val_unbound_ghost_recursive rloc -> + let show_hint = + (* Only display the "missing rec" hint for non-ghost code *) + not loc.Location.loc_ghost + && not rloc.Location.loc_ghost + in + let hint = + if show_hint then Missing_rec rloc else No_hint + in + may_lookup_error errors loc env (Unbound_value(lid, hint)) + +let use_module ~use ~loc path mda = + if use then begin + let comps = mda.mda_components in + mark_module_used comps.uid; + Misc.Stdlib.String.Map.iter + (fun kind message -> + let message = if message = "" then "" else "\n" ^ message in + Location.alert ~kind loc + (Printf.sprintf "module %s%s" (Path.name path) message) + ) + comps.alerts + end + +let use_value ~use ~loc path vda = + if use then begin + let desc = vda.vda_description in + mark_value_used desc.val_uid; + Builtin_attributes.check_alerts loc desc.val_attributes + (Path.name path) + end + +let use_type ~use ~loc path tda = + if use then begin + let decl = tda.tda_declaration in + mark_type_used decl.type_uid; + Builtin_attributes.check_alerts loc decl.type_attributes + (Path.name path) + end + +let use_modtype ~use ~loc path desc = + let open Subst.Lazy in + if use then begin + mark_modtype_used desc.mtdl_uid; + Builtin_attributes.check_alerts loc desc.mtdl_attributes + (Path.name path) + end + +let use_class ~use ~loc path clda = + if use then begin + let desc = clda.clda_declaration in + mark_class_used desc.cty_uid; + Builtin_attributes.check_alerts loc desc.cty_attributes + (Path.name path) + end + +let use_cltype ~use ~loc path desc = + if use then begin + mark_cltype_used desc.clty_uid; + Builtin_attributes.check_alerts loc desc.clty_attributes + (Path.name path) + end + +let use_label ~use ~loc usage env lbl = + if use then begin + mark_label_description_used usage env lbl; + Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name; + if is_mutating_label_usage usage then + Builtin_attributes.check_deprecated_mutable loc lbl.lbl_attributes + lbl.lbl_name + end + +let use_constructor_desc ~use ~loc usage env cstr = + if use then begin + mark_constructor_description_used usage env cstr; + Builtin_attributes.check_alerts loc cstr.cstr_attributes cstr.cstr_name + end + +let use_constructor ~use ~loc usage env cda = + use_constructor_desc ~use ~loc usage env cda.cda_description + +type _ load = + | Load : module_data load + | Don't_load : unit load + +let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = + let path, data = + match find_name_module ~mark:use s env.modules with + | res -> res + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Lident s)) + in + match data with + | Mod_local mda -> begin + use_module ~use ~loc path mda; + match load with + | Load -> path, (mda : a) + | Don't_load -> path, (() : a) + end + | Mod_unbound reason -> + report_module_unbound ~errors ~loc env reason + | Mod_persistent -> begin + match load with + | Don't_load -> + check_pers_mod ~allow_hidden:false ~loc s; + path, (() : a) + | Load -> begin + match find_pers_mod ~allow_hidden:false s with + | mda -> + use_module ~use ~loc path mda; + path, (mda : a) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Lident s)) + end + end + +let lookup_ident_value ~errors ~use ~loc name env = + match IdTbl.find_name wrap_value ~mark:use name env.values with + | (path, Val_bound vda) -> + use_value ~use ~loc path vda; + path, vda.vda_description + | (_, Val_unbound reason) -> + report_value_unbound ~errors ~loc env reason (Lident name) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_value (Lident name, No_hint)) + +let lookup_ident_type ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.types with + | (path, data) as res -> + use_type ~use ~loc path data; + res + | exception Not_found -> + may_lookup_error errors loc env (Unbound_type (Lident s)) + +let lookup_ident_modtype ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with + | (path, data) -> + use_modtype ~use ~loc path data.mtda_declaration; + (path, data.mtda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_modtype (Lident s)) + +let lookup_ident_class ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.classes with + | (path, clda) -> + use_class ~use ~loc path clda; + path, clda.clda_declaration + | exception Not_found -> + may_lookup_error errors loc env (Unbound_class (Lident s)) + +let lookup_ident_cltype ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with + | path, cltda -> + use_cltype ~use ~loc path cltda.cltda_declaration; + path, cltda.cltda_declaration + | exception Not_found -> + may_lookup_error errors loc env (Unbound_cltype (Lident s)) + +let lookup_all_ident_labels ~errors ~use ~loc usage s env = + match TycompTbl.find_all ~mark:use s env.labels with + | [] -> may_lookup_error errors loc env (Unbound_label (Lident s)) + | lbls -> begin + List.map + (fun (lbl, use_fn) -> + let use_fn () = + use_label ~use ~loc usage env lbl; + use_fn () + in + (lbl, use_fn)) + lbls + end + +let lookup_all_ident_constructors ~errors ~use ~loc usage s env = + match TycompTbl.find_all ~mark:use s env.constrs with + | [] -> may_lookup_error errors loc env (Unbound_constructor (Lident s)) + | cstrs -> + List.map + (fun (cda, use_fn) -> + let use_fn () = + use_constructor ~use ~loc usage env cda; + use_fn () + in + (cda.cda_description, use_fn)) + cstrs + +let rec lookup_module_components ~errors ~use ~loc lid env = + match lid with + | Lident s -> + let path, data = lookup_ident_module Load ~errors ~use ~loc s env in + path, data.mda_components + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + path, data.mda_components + | Lapply _ as lid -> + let f_path, f_comp, arg = lookup_apply ~errors ~use ~loc lid env in + let comps = + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env in + Papply (f_path, arg), comps + +and lookup_structure_components ~errors ~use ~loc lid env = + let path, comps = lookup_module_components ~errors ~use ~loc lid env in + match get_components_res comps with + | Ok (Structure_comps comps) -> path, comps + | Ok (Functor_comps _) -> + may_lookup_error errors loc env (Functor_used_as_structure lid) + | Error No_components_abstract -> + may_lookup_error errors loc env (Abstract_used_as_structure lid) + | Error (No_components_alias p) -> + may_lookup_error errors loc env (Cannot_scrape_alias(lid, p)) + +and get_functor_components ~errors ~loc lid env comps = + match get_components_res comps with + | Ok (Functor_comps fcomps) -> begin + match fcomps.fcomp_arg with + | Unit -> (* PR#7611 *) + may_lookup_error errors loc env (Generative_used_as_applicative lid) + | Named (_, arg) -> fcomps, arg + end + | Ok (Structure_comps _) -> + may_lookup_error errors loc env (Structure_used_as_functor lid) + | Error No_components_abstract -> + may_lookup_error errors loc env (Abstract_used_as_functor lid) + | Error (No_components_alias p) -> + may_lookup_error errors loc env (Cannot_scrape_alias(lid, p)) + +and lookup_all_args ~errors ~use ~loc lid0 env = + let rec loop_lid_arg args = function + | Lident _ | Ldot _ as f_lid -> + (f_lid, args) + | Lapply (f_lid, arg_lid) -> + let arg_path, arg_md = lookup_module ~errors ~use ~loc arg_lid env in + loop_lid_arg ((f_lid,arg_path,arg_md.md_type)::args) f_lid + in + loop_lid_arg [] lid0 + +and lookup_apply ~errors ~use ~loc lid0 env = + let f0_lid, args0 = lookup_all_args ~errors ~use ~loc lid0 env in + let args_for_errors = List.map (fun (_,p,mty) -> (p,mty)) args0 in + let f0_path, f0_comp = + lookup_module_components ~errors ~use ~loc f0_lid env + in + let check_one_apply ~errors ~loc ~f_lid ~f_comp ~arg_path ~arg_mty env = + let f_comp, param_mty = + get_functor_components ~errors ~loc f_lid env f_comp + in + check_functor_appl + ~errors ~loc ~lid_whole_app:lid0 + ~f0_path ~args:args_for_errors ~f_comp + ~arg_path ~arg_mty ~param_mty + env; + arg_path, f_comp + in + let rec check_apply ~path:f_path ~comp:f_comp = function + | [] -> invalid_arg "Env.lookup_apply: empty argument list" + | [ f_lid, arg_path, arg_mty ] -> + let arg_path, comps = + check_one_apply ~errors ~loc ~f_lid ~f_comp + ~arg_path ~arg_mty env + in + f_path, comps, arg_path + | (f_lid, arg_path, arg_mty) :: args -> + let arg_path, f_comp = + check_one_apply ~errors ~loc ~f_lid ~f_comp + ~arg_path ~arg_mty env + in + let comp = + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg:arg_path env + in + let path = Papply (f_path, arg_path) in + check_apply ~path ~comp args + in + check_apply ~path:f0_path ~comp:f0_comp args0 + +and lookup_module ~errors ~use ~loc lid env = + match lid with + | Lident s -> + let path, data = lookup_ident_module Load ~errors ~use ~loc s env in + let md = Subst.Lazy.force_module_decl data.mda_declaration in + path, md + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + let md = Subst.Lazy.force_module_decl data.mda_declaration in + path, md + | Lapply _ as lid -> + let path_f, comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in + let md = md (modtype_of_functor_appl comp_f path_f path_arg) in + Papply(path_f, path_arg), md + +and lookup_dot_module ~errors ~use ~loc l s env = + let p, comps = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_modules with + | mda -> + let path = Pdot(p, s) in + use_module ~use ~loc path mda; + (path, mda) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Ldot(l, s))) + +let lookup_dot_value ~errors ~use ~loc l s env = + let (path, comps) = + lookup_structure_components ~errors ~use ~loc l env + in + match NameMap.find s comps.comp_values with + | vda -> + let path = Pdot(path, s) in + use_value ~use ~loc path vda; + (path, vda.vda_description) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_value (Ldot(l, s), No_hint)) + +let lookup_dot_type ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_types with + | tda -> + let path = Pdot(p, s) in + use_type ~use ~loc path tda; + (path, tda) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_type (Ldot(l, s))) + +let lookup_dot_modtype ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_modtypes with + | mta -> + let path = Pdot(p, s) in + use_modtype ~use ~loc path mta.mtda_declaration; + (path, mta.mtda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s))) + +let lookup_dot_class ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_classes with + | clda -> + let path = Pdot(p, s) in + use_class ~use ~loc path clda; + (path, clda.clda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_class (Ldot(l, s))) + +let lookup_dot_cltype ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_cltypes with + | cltda -> + let path = Pdot(p, s) in + use_cltype ~use ~loc path cltda.cltda_declaration; + (path, cltda.cltda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s))) + +let lookup_all_dot_labels ~errors ~use ~loc usage l s env = + let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_labels with + | [] | exception Not_found -> + may_lookup_error errors loc env (Unbound_label (Ldot(l, s))) + | lbls -> + List.map + (fun lbl -> + let use_fun () = use_label ~use ~loc usage env lbl in + (lbl, use_fun)) + lbls + +let lookup_all_dot_constructors ~errors ~use ~loc usage l s env = + match l with + | Longident.Lident "*predef*" -> + (* Hack to support compilation of default arguments *) + lookup_all_ident_constructors + ~errors ~use ~loc usage s initial + | _ -> + let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_constrs with + | [] | exception Not_found -> + may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s))) + | cstrs -> + List.map + (fun cda -> + let use_fun () = use_constructor ~use ~loc usage env cda in + (cda.cda_description, use_fun)) + cstrs + +(* General forms of the lookup functions *) + +let lookup_module_path ~errors ~use ~loc ~load lid env : Path.t = + match lid with + | Lident s -> + if !Clflags.transparent_modules && not load then + fst (lookup_ident_module Don't_load ~errors ~use ~loc s env) + else + fst (lookup_ident_module Load ~errors ~use ~loc s env) + | Ldot(l, s) -> fst (lookup_dot_module ~errors ~use ~loc l s env) + | Lapply _ as lid -> + let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in + Papply(path_f, path_arg) + +let lookup_value ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_value ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_value ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_type_full ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_type ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_type ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_type ~errors ~use ~loc lid env = + let (path, tda) = lookup_type_full ~errors ~use ~loc lid env in + path, tda.tda_declaration + +let lookup_modtype_lazy ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_modtype ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_modtype ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_modtype ~errors ~use ~loc lid env = + let (path, mt) = lookup_modtype_lazy ~errors ~use ~loc lid env in + path, Subst.Lazy.force_modtype_decl mt + +let lookup_class ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_class ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_class ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_cltype ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_cltype ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_all_labels ~errors ~use ~loc usage lid env = + match lid with + | Lident s -> lookup_all_ident_labels ~errors ~use ~loc usage s env + | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc usage l s env + | Lapply _ -> assert false + +let lookup_label ~errors ~use ~loc usage lid env = + match lookup_all_labels ~errors ~use ~loc usage lid env with + | [] -> assert false + | (desc, use) :: _ -> use (); desc + +let lookup_all_labels_from_type ~use ~loc usage ty_path env = + match find_type_descrs ty_path env with + | exception Not_found -> [] + | Type_variant _ | Type_abstract _ | Type_open -> [] + | Type_record (lbls, _) -> + List.map + (fun lbl -> + let use_fun () = use_label ~use ~loc usage env lbl in + (lbl, use_fun)) + lbls + +let lookup_all_constructors ~errors ~use ~loc usage lid env = + match lid with + | Lident s -> lookup_all_ident_constructors ~errors ~use ~loc usage s env + | Ldot(l, s) -> lookup_all_dot_constructors ~errors ~use ~loc usage l s env + | Lapply _ -> assert false + +let lookup_constructor ~errors ~use ~loc usage lid env = + match lookup_all_constructors ~errors ~use ~loc usage lid env with + | [] -> assert false + | (desc, use) :: _ -> use (); desc + +let lookup_all_constructors_from_type ~use ~loc usage ty_path env = + match find_type_descrs ty_path env with + | exception Not_found -> [] + | Type_record _ | Type_abstract _ | Type_open -> [] + | Type_variant (cstrs, _) -> + List.map + (fun cstr -> + let use_fun () = + use_constructor_desc ~use ~loc usage env cstr + in + (cstr, use_fun)) + cstrs + +(* Lookup functions that do not mark the item as used or + warn if it has alerts, and raise [Not_found] rather + than report errors *) + +let find_module_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_module ~errors:false ~use:false ~loc lid env + +let find_value_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_value ~errors:false ~use:false ~loc lid env + +let find_type_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_type ~errors:false ~use:false ~loc lid env + +let find_modtype_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_modtype ~errors:false ~use:false ~loc lid env + +let find_class_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_class ~errors:false ~use:false ~loc lid env + +let find_cltype_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_cltype ~errors:false ~use:false ~loc lid env + +let find_constructor_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_constructor ~errors:false ~use:false ~loc Positive lid env + +let find_label_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_label ~errors:false ~use:false ~loc Projection lid env + +(* Stable name lookup for printing *) + +let find_index_tbl ident tbl = + let lbs = IdTbl.find_all_idents (Ident.name ident) tbl in + let find_ident (n,p) = match p with + | Some id -> if Ident.same ident id then Some n else None + | _ -> None + in + Seq.find_map find_ident @@ Seq.mapi (fun i x -> i,x) lbs + +let find_value_index id env = find_index_tbl id env.values +let find_type_index id env = find_index_tbl id env.types +let find_module_index id env = find_index_tbl id env.modules +let find_modtype_index id env = find_index_tbl id env.modtypes +let find_class_index id env = find_index_tbl id env.classes +let find_cltype_index id env = find_index_tbl id env.cltypes + +(* Ordinary lookup functions *) + +let lookup_module_path ?(use=true) ~loc ~load lid env = + lookup_module_path ~errors:true ~use ~loc ~load lid env + +let lookup_module ?(use=true) ~loc lid env = + lookup_module ~errors:true ~use ~loc lid env + +let lookup_value ?(use=true) ~loc lid env = + check_value_name (Longident.last lid) loc; + lookup_value ~errors:true ~use ~loc lid env + +let lookup_type ?(use=true) ~loc lid env = + lookup_type ~errors:true ~use ~loc lid env + +let lookup_modtype ?(use=true) ~loc lid env = + lookup_modtype ~errors:true ~use ~loc lid env + +let lookup_modtype_path ?(use=true) ~loc lid env = + fst (lookup_modtype_lazy ~errors:true ~use ~loc lid env) + +let lookup_class ?(use=true) ~loc lid env = + lookup_class ~errors:true ~use ~loc lid env + +let lookup_cltype ?(use=true) ~loc lid env = + lookup_cltype ~errors:true ~use ~loc lid env + +let lookup_all_constructors ?(use=true) ~loc usage lid env = + match lookup_all_constructors ~errors:true ~use ~loc usage lid env with + | exception Error(Lookup_error(loc', env', err)) -> + (Error(loc', env', err) : _ result) + | cstrs -> Ok cstrs + +let lookup_constructor ?(use=true) ~loc lid env = + lookup_constructor ~errors:true ~use ~loc lid env + +let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env = + lookup_all_constructors_from_type ~use ~loc usage ty_path env + +let lookup_all_labels ?(use=true) ~loc usage lid env = + match lookup_all_labels ~errors:true ~use ~loc usage lid env with + | exception Error(Lookup_error(loc', env', err)) -> + (Error(loc', env', err) : _ result) + | lbls -> Ok lbls + +let lookup_label ?(use=true) ~loc lid env = + lookup_label ~errors:true ~use ~loc lid env + +let lookup_all_labels_from_type ?(use=true) ~loc usage ty_path env = + lookup_all_labels_from_type ~use ~loc usage ty_path env + +let lookup_instance_variable ?(use=true) ~loc name env = + match IdTbl.find_name wrap_value ~mark:use name env.values with + | (path, Val_bound vda) -> begin + let desc = vda.vda_description in + match desc.val_kind with + | Val_ivar(mut, cl_num) -> + use_value ~use ~loc path vda; + path, mut, cl_num, desc.val_type + | _ -> + lookup_error loc env (Not_an_instance_variable name) + end + | (_, Val_unbound Val_unbound_instance_variable) -> + lookup_error loc env (Masked_instance_variable (Lident name)) + | (_, Val_unbound Val_unbound_self) -> + lookup_error loc env (Not_an_instance_variable name) + | (_, Val_unbound Val_unbound_ancestor) -> + lookup_error loc env (Not_an_instance_variable name) + | (_, Val_unbound Val_unbound_ghost_recursive _) -> + lookup_error loc env (Unbound_instance_variable name) + | exception Not_found -> + lookup_error loc env (Unbound_instance_variable name) + +(* Checking if a name is bound *) + +let bound_module name env = + match IdTbl.find_name wrap_module ~mark:false name env.modules with + | _ -> true + | exception Not_found -> + if Current_unit.Name.is name then false + else begin + match find_pers_mod ~allow_hidden:false name with + | _ -> true + | exception Not_found -> false + end + +let bound wrap proj name env = + match IdTbl.find_name wrap ~mark:false name (proj env) with + | _ -> true + | exception Not_found -> false + +let bound_value name env = + bound wrap_value (fun env -> env.values) name env + +let bound_type name env = + bound wrap_identity (fun env -> env.types) name env + +let bound_modtype name env = + bound wrap_identity (fun env -> env.modtypes) name env + +let bound_class name env = + bound wrap_identity (fun env -> env.classes) name env + +let bound_cltype name env = + bound wrap_identity (fun env -> env.cltypes) name env + +(* Folding on environments *) + +let find_all wrap proj1 proj2 f lid env acc = + match lid with + | None -> + IdTbl.fold_name wrap + (fun name (p, data) acc -> f name p data acc) + (proj1 env) acc + | Some l -> + let p, desc = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in + begin match get_components desc with + | Structure_comps c -> + NameMap.fold + (fun s data acc -> f s (Pdot (p, s)) (wrap data) acc) + (proj2 c) acc + | Functor_comps _ -> + acc + end + +let find_all_simple_list proj1 proj2 f lid env acc = + match lid with + | None -> + TycompTbl.fold_name + (fun data acc -> f data acc) + (proj1 env) acc + | Some l -> + let (_p, desc) = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in + begin match get_components desc with + | Structure_comps c -> + NameMap.fold + (fun _s comps acc -> + match comps with + | [] -> acc + | data :: _ -> f data acc) + (proj2 c) acc + | Functor_comps _ -> + acc + end + +let fold_modules f lid env acc = + match lid with + | None -> + IdTbl.fold_name wrap_module + (fun name (p, entry) acc -> + match entry with + | Mod_unbound _ -> acc + | Mod_local mda -> + let md = + Subst.Lazy.force_module_decl mda.mda_declaration + in + f name p md acc + | Mod_persistent -> + match Persistent_env.find_in_cache !persistent_env name with + | None -> acc + | Some mda -> + let md = + Subst.Lazy.force_module_decl mda.mda_declaration + in + f name p md acc) + env.modules + acc + | Some l -> + let p, desc = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in + begin match get_components desc with + | Structure_comps c -> + NameMap.fold + (fun s mda acc -> + let md = + Subst.Lazy.force_module_decl mda.mda_declaration + in + f s (Pdot (p, s)) md acc) + c.comp_modules + acc + | Functor_comps _ -> + acc + end + +let fold_values f = + find_all wrap_value (fun env -> env.values) (fun sc -> sc.comp_values) + (fun k p ve acc -> + match ve with + | Val_unbound _ -> acc + | Val_bound vda -> f k p vda.vda_description acc) +and fold_constructors f = + find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) + (fun cda acc -> f cda.cda_description acc) +and fold_labels f = + find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f +and fold_types f = + find_all wrap_identity + (fun env -> env.types) (fun sc -> sc.comp_types) + (fun k p tda acc -> f k p tda.tda_declaration acc) +and fold_modtypes f = + let f l path data acc = f l path (Subst.Lazy.force_modtype_decl data) acc in + find_all wrap_identity + (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + (fun k p mta acc -> f k p mta.mtda_declaration acc) +and fold_classes f = + find_all wrap_identity (fun env -> env.classes) (fun sc -> sc.comp_classes) + (fun k p clda acc -> f k p clda.clda_declaration acc) +and fold_cltypes f = + find_all wrap_identity + (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) + (fun k p cltda acc -> f k p cltda.cltda_declaration acc) + +let filter_non_loaded_persistent f env = + let to_remove = + IdTbl.fold_name wrap_module + (fun name (_, entry) acc -> + match entry with + | Mod_local _ -> acc + | Mod_unbound _ -> acc + | Mod_persistent -> + match Persistent_env.find_in_cache !persistent_env name with + | Some _ -> acc + | None -> + if f (Ident.create_persistent name) then + acc + else + String.Set.add name acc) + env.modules + String.Set.empty + in + let remove_ids tbl ids = + String.Set.fold + (fun name tbl -> IdTbl.remove (Ident.create_persistent name) tbl) + ids + tbl + in + let rec filter_summary summary ids = + if String.Set.is_empty ids then + summary + else + match summary with + Env_persistent (s, id) when String.Set.mem (Ident.name id) ids -> + filter_summary s (String.Set.remove (Ident.name id) ids) + | Env_empty + | Env_value _ + | Env_type _ + | Env_extension _ + | Env_module _ + | Env_modtype _ + | Env_class _ + | Env_cltype _ + | Env_open _ + | Env_functor_arg _ + | Env_constraints _ + | Env_copy_types _ + | Env_persistent _ + | Env_value_unbound _ + | Env_module_unbound _ -> + map_summary (fun s -> filter_summary s ids) summary + in + { env with + modules = remove_ids env.modules to_remove; + summary = filter_summary env.summary to_remove; + } + +(* Return the environment summary *) + +let summary env = + if Path.Map.is_empty env.local_constraints then env.summary + else Env_constraints (env.summary, env.local_constraints) + +let last_env = s_ref empty +let last_reduced_env = s_ref empty + +let keep_only_summary env = + if !last_env == env then !last_reduced_env + else begin + let new_env = + { + empty with + summary = env.summary; + local_constraints = env.local_constraints; + flags = env.flags; + } + in + last_env := env; + last_reduced_env := new_env; + new_env + end + + +let env_of_only_summary env_from_summary env = + let new_env = env_from_summary env.summary Subst.identity in + { new_env with + local_constraints = env.local_constraints; + flags = env.flags; + } + +(* Error report *) + +open Format_doc + +(* Forward declarations *) + +let print_longident : Longident.t printer ref = ref (fun _ _ -> assert false) + +let pp_longident ppf l = !print_longident ppf l + +let print_path: Path.t printer ref = ref (fun _ _ -> assert false) +let pp_path ppf l = !print_path ppf l + +let spellcheck ppf extract env lid = + let choices ~path name = Misc.spellcheck (extract path env) name in + match lid with + | Longident.Lapply _ -> () + | Longident.Lident s -> + Misc.did_you_mean ppf (fun () -> choices ~path:None s) + | Longident.Ldot (r, s) -> + Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) + +let spellcheck_name ppf extract env name = + Misc.did_you_mean ppf + (fun () -> Misc.spellcheck (extract env) name) + +let extract_values path env = + fold_values (fun name _ _ acc -> name :: acc) path env [] +let extract_types path env = + fold_types (fun name _ _ acc -> name :: acc) path env [] +let extract_modules path env = + fold_modules (fun name _ _ acc -> name :: acc) path env [] +let extract_constructors path env = + fold_constructors (fun desc acc -> desc.cstr_name :: acc) path env [] +let extract_labels path env = + fold_labels (fun desc acc -> desc.lbl_name :: acc) path env [] +let extract_classes path env = + fold_classes (fun name _ _ acc -> name :: acc) path env [] +let extract_modtypes path env = + fold_modtypes (fun name _ _ acc -> name :: acc) path env [] +let extract_cltypes path env = + fold_cltypes (fun name _ _ acc -> name :: acc) path env [] +let extract_instance_variables env = + fold_values + (fun name _ descr acc -> + match descr.val_kind with + | Val_ivar _ -> name :: acc + | _ -> acc) None env [] + +module Style = Misc.Style + +let quoted_longident = Style.as_inline_code pp_longident + +let report_lookup_error_doc _loc env ppf = function + | Unbound_value(lid, hint) -> begin + fprintf ppf "Unbound value %a" quoted_longident lid; + spellcheck ppf extract_values env lid; + match hint with + | No_hint -> () + | Missing_rec def_loc -> + let (_, line, _) = + Location.get_pos_info def_loc.Location.loc_start + in + fprintf ppf + "@.@[@{Hint@}: If this is a recursive definition,@ \ + you should add the %a keyword on line %i@]" + Style.inline_code "rec" + line + end + | Unbound_type lid -> + fprintf ppf "Unbound type constructor %a" + quoted_longident lid; + spellcheck ppf extract_types env lid; + | Unbound_module lid -> begin + fprintf ppf "Unbound module %a" + quoted_longident lid; + match find_modtype_by_name lid env with + | exception Not_found -> spellcheck ppf extract_modules env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a module type named %a, %s@]" + quoted_longident lid + "but module types are not modules" + end + | Unbound_constructor lid -> + fprintf ppf "Unbound constructor %a" + quoted_longident lid; + spellcheck ppf extract_constructors env lid; + | Unbound_label lid -> + fprintf ppf "Unbound record field %a" + quoted_longident lid; + spellcheck ppf extract_labels env lid; + | Unbound_class lid -> begin + fprintf ppf "Unbound class %a" + quoted_longident lid; + match find_cltype_by_name lid env with + | exception Not_found -> spellcheck ppf extract_classes env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a class type named %a, %s@]" + quoted_longident lid + "but classes are not class types" + end + | Unbound_modtype lid -> begin + fprintf ppf "Unbound module type %a" + quoted_longident lid; + match find_module_by_name lid env with + | exception Not_found -> spellcheck ppf extract_modtypes env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a module named %a, %s@]" + quoted_longident lid + "but modules are not module types" + end + | Unbound_cltype lid -> + fprintf ppf "Unbound class type %a" + quoted_longident lid; + spellcheck ppf extract_cltypes env lid; + | Unbound_instance_variable s -> + fprintf ppf "Unbound instance variable %a" Style.inline_code s; + spellcheck_name ppf extract_instance_variables env s; + | Not_an_instance_variable s -> + fprintf ppf "The value %a is not an instance variable" + Style.inline_code s; + spellcheck_name ppf extract_instance_variables env s; + | Masked_instance_variable lid -> + fprintf ppf + "The instance variable %a@ \ + cannot be accessed from the definition of another instance variable" + quoted_longident lid + | Masked_self_variable lid -> + fprintf ppf + "The self variable %a@ \ + cannot be accessed from the definition of an instance variable" + quoted_longident lid + | Masked_ancestor_variable lid -> + fprintf ppf + "The ancestor variable %a@ \ + cannot be accessed from the definition of an instance variable" + quoted_longident lid + | Illegal_reference_to_recursive_module -> + fprintf ppf "Illegal recursive module reference" + | Structure_used_as_functor lid -> + fprintf ppf "@[The module %a is a structure, it cannot be applied@]" + quoted_longident lid + | Abstract_used_as_functor lid -> + fprintf ppf "@[The module %a is abstract, it cannot be applied@]" + quoted_longident lid + | Functor_used_as_structure lid -> + fprintf ppf "@[The module %a is a functor, \ + it cannot have any components@]" pp_longident lid + | Abstract_used_as_structure lid -> + fprintf ppf "@[The module %a is abstract, \ + it cannot have any components@]" + quoted_longident lid + | Generative_used_as_applicative lid -> + fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ + applied@ in@ type@ expressions@]" + quoted_longident lid + | Cannot_scrape_alias(lid, p) -> + let cause = + if Current_unit.Name.is_path p then "is the current compilation unit" + else "is missing" + in + fprintf ppf + "The module %a is an alias for module %a, which %s" + quoted_longident lid + (Style.as_inline_code pp_path) p cause + +let report_error_doc ppf = function + | Missing_module(_, path1, path2) -> + fprintf ppf "@[@["; + if Path.same path1 path2 then + fprintf ppf "Internal path@ %a@ is dangling." + Style.inline_code (Path.name path1) + else + fprintf ppf "Internal path@ %a@ expands to@ %a@ which is dangling." + Style.inline_code (Path.name path1) + Style.inline_code (Path.name path2); + fprintf ppf "@]@ @[%s@ %a@ %s.@]@]" + "The compiled interface for module" + Style.inline_code (Ident.name (Path.head path2)) + "was not found" + | Illegal_value_name(_loc, name) -> + fprintf ppf "%a is not a valid value identifier." + Style.inline_code name + | Lookup_error(loc, t, err) -> report_lookup_error_doc loc t ppf err + +let () = + Location.register_error_of_exn + (function + | Error err -> + let loc = + match err with + | Missing_module (loc, _, _) + | Illegal_value_name (loc, _) + | Lookup_error(loc, _, _) -> loc + in + let error_of_printer = + if loc = Location.none + then Location.error_of_printer_file + else Location.error_of_printer ~loc ?sub:None ?footnote:None + in + Some (error_of_printer report_error_doc err) + | _ -> + None + ) + +let report_lookup_error = Format_doc.compat2 report_lookup_error_doc +let report_error = Format_doc.compat report_error_doc diff --git a/upstream/ocaml_503/typing/env.mli b/upstream/ocaml_503/typing/env.mli new file mode 100644 index 000000000..f5f154507 --- /dev/null +++ b/upstream/ocaml_503/typing/env.mli @@ -0,0 +1,528 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Environment handling *) + +open Types +open Misc + +type value_unbound_reason = + | Val_unbound_instance_variable + | Val_unbound_self + | Val_unbound_ancestor + | Val_unbound_ghost_recursive of Location.t + +type module_unbound_reason = + | Mod_unbound_illegal_recursion + +type summary = + Env_empty + | Env_value of summary * Ident.t * value_description + | Env_type of summary * Ident.t * type_declaration + | Env_extension of summary * Ident.t * extension_constructor + | Env_module of summary * Ident.t * module_presence * module_declaration + | Env_modtype of summary * Ident.t * modtype_declaration + | Env_class of summary * Ident.t * class_declaration + | Env_cltype of summary * Ident.t * class_type_declaration + | Env_open of summary * Path.t + (** The string set argument of [Env_open] represents a list of module names + to skip, i.e. that won't be imported in the toplevel namespace. *) + | Env_functor_arg of summary * Ident.t + | Env_constraints of summary * type_declaration Path.Map.t + | Env_copy_types of summary + | Env_persistent of summary * Ident.t + | Env_value_unbound of summary * string * value_unbound_reason + | Env_module_unbound of summary * string * module_unbound_reason + +type address = + | Aident of Ident.t + | Adot of address * int + +type t + +val empty: t +val initial: t +val diff: t -> t -> Ident.t list + +(* approximation to the preimage equivalence class of [find_type] *) +val same_type_declarations: t -> t -> bool + +type type_descr_kind = + (label_description, constructor_description) type_kind + + (* alias for compatibility *) +type type_descriptions = type_descr_kind + +(* For short-paths *) +type iter_cont +val iter_types: + (Path.t -> Path.t * type_declaration -> unit) -> + t -> iter_cont +val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list +val same_types: t -> t -> bool +val used_persistent: unit -> Stdlib.String.Set.t +val find_shadowed_types: Path.t -> t -> Path.t list +val without_cmis: ('a -> 'b) -> 'a -> 'b +(* [without_cmis f arg] applies [f] to [arg], but does not + allow opening cmis during its execution *) + +(* Lookup by paths *) + +val find_value: Path.t -> t -> value_description +val find_type: Path.t -> t -> type_declaration +val find_type_descrs: Path.t -> t -> type_descriptions +val find_module: Path.t -> t -> module_declaration +val find_modtype: Path.t -> t -> modtype_declaration +val find_class: Path.t -> t -> class_declaration +val find_cltype: Path.t -> t -> class_type_declaration + +val find_strengthened_module: + aliasable:bool -> Path.t -> t -> module_type + +val find_ident_constructor: Ident.t -> t -> constructor_description +val find_ident_label: Ident.t -> t -> label_description + +val find_type_expansion: + Path.t -> t -> type_expr list * type_expr * int +val find_type_expansion_opt: + Path.t -> t -> type_expr list * type_expr * int +(* Find the manifest type information associated to a type for the sake + of the compiler's type-based optimisations. *) +val find_modtype_expansion: Path.t -> t -> module_type +val find_modtype_expansion_lazy: Path.t -> t -> Subst.Lazy.modtype + +val find_hash_type: Path.t -> t -> type_declaration +(* Find the "#t" type given the path for "t" *) + +val find_value_address: Path.t -> t -> address +val find_module_address: Path.t -> t -> address +val find_class_address: Path.t -> t -> address +val find_constructor_address: Path.t -> t -> address + +val shape_of_path: + namespace:Shape.Sig_component_kind.t -> t -> Path.t -> Shape.t + +val add_functor_arg: Ident.t -> t -> t +val is_functor_arg: Path.t -> t -> bool + +val normalize_module_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the path to a concrete module. + If the option is None, allow returning dangling paths. + Otherwise raise a Missing_module error, and may add forgotten + head as required global. *) + +val normalize_type_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the prefix part of the type path *) + +val normalize_value_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the prefix part of the value path *) + +val normalize_modtype_path: t -> Path.t -> Path.t +(* Normalize a module type path *) + +val reset_required_globals: unit -> unit +val get_required_globals: unit -> Ident.t list +val add_required_global: Ident.t -> unit + +val has_local_constraints: t -> bool + +(* Mark definitions as used *) +val mark_value_used: Uid.t -> unit +val mark_module_used: Uid.t -> unit +val mark_type_used: Uid.t -> unit + +type constructor_usage = Positive | Pattern | Exported_private | Exported +val mark_constructor_used: + constructor_usage -> constructor_declaration -> unit +val mark_extension_used: + constructor_usage -> extension_constructor -> unit + +type label_usage = + Projection | Mutation | Construct | Exported_private | Exported +val mark_label_used: + label_usage -> label_declaration -> unit + +(* Lookup by long identifiers *) + +(* Lookup errors *) + +type unbound_value_hint = + | No_hint + | Missing_rec of Location.t + +type lookup_error = + | Unbound_value of Longident.t * unbound_value_hint + | Unbound_type of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t + | Unbound_module of Longident.t + | Unbound_class of Longident.t + | Unbound_modtype of Longident.t + | Unbound_cltype of Longident.t + | Unbound_instance_variable of string + | Not_an_instance_variable of string + | Masked_instance_variable of Longident.t + | Masked_self_variable of Longident.t + | Masked_ancestor_variable of Longident.t + | Structure_used_as_functor of Longident.t + | Abstract_used_as_functor of Longident.t + | Functor_used_as_structure of Longident.t + | Abstract_used_as_structure of Longident.t + | Generative_used_as_applicative of Longident.t + | Illegal_reference_to_recursive_module + | Cannot_scrape_alias of Longident.t * Path.t + +val lookup_error: Location.t -> t -> lookup_error -> 'a + +(* The [lookup_foo] functions will emit proper error messages (by + raising [Error]) if the identifier cannot be found, whereas the + [find_foo_by_name] functions will raise [Not_found] instead. + + The [~use] parameters of the [lookup_foo] functions control + whether this lookup should be counted as a use for usage + warnings and alerts. + + [Longident.t]s in the program source should be looked up using + [lookup_foo ~use:true] exactly one time -- otherwise warnings may be + emitted the wrong number of times. *) + +val lookup_value: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * value_description +val lookup_type: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * type_declaration +val lookup_module: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * module_declaration +val lookup_modtype: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * modtype_declaration +val lookup_class: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * class_declaration +val lookup_cltype: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * class_type_declaration + +val lookup_module_path: + ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t +val lookup_modtype_path: + ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t + +val lookup_constructor: + ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> + constructor_description +val lookup_all_constructors: + ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> + ((constructor_description * (unit -> unit)) list, + Location.t * t * lookup_error) result +val lookup_all_constructors_from_type: + ?use:bool -> loc:Location.t -> constructor_usage -> Path.t -> t -> + (constructor_description * (unit -> unit)) list + +val lookup_label: + ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t -> + label_description +val lookup_all_labels: + ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t -> + ((label_description * (unit -> unit)) list, + Location.t * t * lookup_error) result +val lookup_all_labels_from_type: + ?use:bool -> loc:Location.t -> label_usage -> Path.t -> t -> + (label_description * (unit -> unit)) list + +val lookup_instance_variable: + ?use:bool -> loc:Location.t -> string -> t -> + Path.t * Asttypes.mutable_flag * string * type_expr + +val find_value_by_name: + Longident.t -> t -> Path.t * value_description +val find_type_by_name: + Longident.t -> t -> Path.t * type_declaration +val find_module_by_name: + Longident.t -> t -> Path.t * module_declaration +val find_modtype_by_name: + Longident.t -> t -> Path.t * modtype_declaration +val find_class_by_name: + Longident.t -> t -> Path.t * class_declaration +val find_cltype_by_name: + Longident.t -> t -> Path.t * class_type_declaration + +val find_constructor_by_name: + Longident.t -> t -> constructor_description +val find_label_by_name: + Longident.t -> t -> label_description + +(** The [find_*_index] functions computes a "namespaced" De Bruijn index + of an identifier in a given environment. In other words, it returns how many + times an identifier has been shadowed by a more recent identifiers with the + same name in a given environment. + Those functions return [None] when the identifier is not bound in the + environment. This behavior is there to facilitate the detection of + inconsistent printing environment, but should disappear in the long term. +*) +val find_value_index: Ident.t -> t -> int option +val find_type_index: Ident.t -> t -> int option +val find_module_index: Ident.t -> t -> int option +val find_modtype_index: Ident.t -> t -> int option +val find_class_index: Ident.t -> t -> int option +val find_cltype_index: Ident.t -> t -> int option + +(* Check if a name is bound *) + +val bound_value: string -> t -> bool +val bound_module: string -> t -> bool +val bound_type: string -> t -> bool +val bound_modtype: string -> t -> bool +val bound_class: string -> t -> bool +val bound_cltype: string -> t -> bool + +val make_copy_of_types: t -> (t -> t) + +(* Insertion by identifier *) + +val add_value: + ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t +val add_type: + check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t +val add_extension: + check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t -> + extension_constructor -> t -> t +val add_module: ?arg:bool -> ?shape:Shape.t -> + Ident.t -> module_presence -> module_type -> t -> t +val add_module_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t +val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> + Ident.t -> module_presence -> module_declaration -> t -> t +val add_module_declaration_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.module_decl -> t -> t +val add_modtype: Ident.t -> modtype_declaration -> t -> t +val add_modtype_lazy: update_summary:bool -> + Ident.t -> Subst.Lazy.modtype_declaration -> t -> t +val add_class: Ident.t -> class_declaration -> t -> t +val add_cltype: Ident.t -> class_type_declaration -> t -> t +val add_local_constraint: Path.t -> type_declaration -> t -> t + +(* Insertion of persistent signatures *) + +(* [add_persistent_structure id env] is an environment such that + module [id] points to the persistent structure contained in the + external compilation unit with the same name. + + The compilation unit itself is looked up in the load path when the + contents of the module is accessed. *) +val add_persistent_structure : Ident.t -> t -> t + + (* Returns the set of persistent structures found in the given + directory. *) +val persistent_structures_of_dir : Load_path.Dir.t -> Misc.Stdlib.String.Set.t + +(* [filter_non_loaded_persistent f env] removes all the persistent + structures that are not yet loaded and for which [f] returns + [false]. *) +val filter_non_loaded_persistent : (Ident.t -> bool) -> t -> t + +(* Insertion of all fields of a signature. *) + +val add_signature: signature -> t -> t + +(* Insertion of all fields of a signature, relative to the given path. + Used to implement open. Returns None if the path refers to a functor, + not a structure. *) +val open_signature: + ?used_slot:bool ref -> + ?loc:Location.t -> ?toplevel:bool -> + Asttypes.override_flag -> Path.t -> + t -> (t, [`Not_found | `Functor]) result + +val open_pers_signature: string -> t -> (t, [`Not_found]) result + +val remove_last_open: Path.t -> t -> t option + +(* Insertion by name *) + +val enter_value: + ?check:(string -> Warnings.t) -> + string -> value_description -> t -> Ident.t * t +val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t +val enter_extension: + scope:int -> rebind:bool -> string -> + extension_constructor -> t -> Ident.t * t +val enter_module: + scope:int -> ?arg:bool -> string -> module_presence -> + module_type -> t -> Ident.t * t +val enter_module_declaration: + scope:int -> ?arg:bool -> ?shape:Shape.t -> string -> module_presence -> + module_declaration -> t -> Ident.t * t +val enter_modtype: + scope:int -> string -> modtype_declaration -> t -> Ident.t * t +val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t +val enter_cltype: + scope:int -> string -> class_type_declaration -> t -> Ident.t * t + +(* Same as [add_signature] but refreshes (new stamp) and rescopes bound idents + in the process. *) +val enter_signature: ?mod_shape:Shape.t -> scope:int -> signature -> t -> + signature * t + +(* Same as [enter_signature] but also extends the shape map ([parent_shape]) + with all the the items from the signature, their shape being a projection + from the given shape. *) +val enter_signature_and_shape: scope:int -> parent_shape:Shape.Map.t -> + Shape.t -> signature -> t -> signature * Shape.Map.t * t + +val enter_unbound_value : string -> value_unbound_reason -> t -> t + +val enter_unbound_module : string -> module_unbound_reason -> t -> t + +(* Initialize the cache of in-core module interfaces. *) +val reset_cache: unit -> unit + +(* To be called before each toplevel phrase. *) +val reset_cache_toplevel: unit -> unit + +(* Remember the current compilation unit. *) +val set_current_unit: Unit_info.t -> unit +val get_current_unit : unit -> Unit_info.t option +val get_current_unit_name: unit -> string + +(* Read, save a signature to/from a file *) +val read_signature: Unit_info.Artifact.t -> signature + (* Arguments: module name, file name. Results: signature. *) +val save_signature: + alerts:alerts -> Types.signature -> Unit_info.Artifact.t + -> Cmi_format.cmi_infos + (* Arguments: signature, module name, file name. *) +val save_signature_with_imports: + alerts:alerts -> signature -> Unit_info.Artifact.t -> crcs + -> Cmi_format.cmi_infos + (* Arguments: signature, module name, file name, + imported units with their CRCs. *) + +(* Return the CRC of the interface of the given compilation unit *) +val crc_of_unit: modname -> Digest.t + +(* Return the set of compilation units imported, with their CRC *) +val imports: unit -> crcs + +(* may raise Persistent_env.Consistbl.Inconsistency *) +val import_crcs: source:string -> crcs -> unit + +(* [is_imported_opaque md] returns true if [md] is an opaque imported module *) +val is_imported_opaque: modname -> bool + +(* [register_import_as_opaque md] registers [md] as an opaque imported module *) +val register_import_as_opaque: modname -> unit + +(* Summaries -- compact representation of an environment, to be + exported in debugging information. *) + +val summary: t -> summary + +(* Return an equivalent environment where all fields have been reset, + except the summary. The initial environment can be rebuilt from the + summary, using Envaux.env_of_only_summary. *) + +val keep_only_summary : t -> t +val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t + +(* Error report *) + +type error = + | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string + | Lookup_error of Location.t * t * lookup_error + +exception Error of error + + +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer + +val report_lookup_error: + Location.t -> t -> lookup_error Format_doc.format_printer +val report_lookup_error_doc: + Location.t -> t -> lookup_error Format_doc.printer +val in_signature: bool -> t -> t + +val is_in_signature: t -> bool + +val set_value_used_callback: + value_description -> (unit -> unit) -> unit +val set_type_used_callback: + type_declaration -> ((unit -> unit) -> unit) -> unit + +(* Forward declaration to break mutual recursion with Includemod. *) +val check_functor_application: + (errors:bool -> loc:Location.t -> + lid_whole_app:Longident.t -> + f0_path:Path.t -> args:(Path.t * Types.module_type) list -> + arg_path:Path.t -> arg_mty:Types.module_type -> + param_mty:Types.module_type -> + t -> unit) ref +(* Forward declaration to break mutual recursion with Typemod. *) +val check_well_formed_module: + (t -> Location.t -> string -> module_type -> unit) ref +(* Forward declaration to break mutual recursion with Typecore. *) +val add_delayed_check_forward: ((unit -> unit) -> unit) ref +(* Forward declaration to break mutual recursion with Mtype. *) +val strengthen: + (aliasable:bool -> t -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) ref +(* Forward declaration to break mutual recursion with Ctype. *) +val same_constr: (t -> type_expr -> type_expr -> bool) ref +(* Forward declaration to break mutual recursion with Printtyp. *) +val print_longident: Longident.t Format_doc.printer ref +(* Forward declaration to break mutual recursion with Printtyp. *) +val print_path: Path.t Format_doc.printer ref + + +(** Folds *) + +val fold_values: + (string -> Path.t -> value_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_types: + (string -> Path.t -> type_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_constructors: + (constructor_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_labels: + (label_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + +(** Persistent structures are only traversed if they are already loaded. *) +val fold_modules: + (string -> Path.t -> module_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + +val fold_modtypes: + (string -> Path.t -> modtype_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_classes: + (string -> Path.t -> class_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_cltypes: + (string -> Path.t -> class_type_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + + +(** Utilities *) +val scrape_alias: t -> module_type -> module_type +val check_value_name: string -> Location.t -> unit + +val print_address : Format.formatter -> address -> unit diff --git a/upstream/ocaml_503/typing/envaux.ml b/upstream/ocaml_503/typing/envaux.ml new file mode 100644 index 000000000..df75c5d5b --- /dev/null +++ b/upstream/ocaml_503/typing/envaux.ml @@ -0,0 +1,119 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Env + +type error = + Module_not_found of Path.t + +exception Error of error + +let env_cache = + (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t) + +let reset_cache () = + Hashtbl.clear env_cache; + Env.reset_cache() + +let rec env_from_summary sum subst = + try + Hashtbl.find env_cache (sum, subst) + with Not_found -> + let env = + match sum with + Env_empty -> + Env.empty + | Env_value(s, id, desc) -> + Env.add_value id (Subst.value_description subst desc) + (env_from_summary s subst) + | Env_type(s, id, desc) -> + Env.add_type ~check:false id + (Subst.type_declaration subst desc) + (env_from_summary s subst) + | Env_extension(s, id, desc) -> + Env.add_extension ~check:false ~rebind:false id + (Subst.extension_constructor subst desc) + (env_from_summary s subst) + | Env_module(s, id, pres, desc) -> + Env.add_module_declaration ~check:false id pres + (Subst.module_declaration Keep subst desc) + (env_from_summary s subst) + | Env_modtype(s, id, desc) -> + Env.add_modtype id (Subst.modtype_declaration Keep subst desc) + (env_from_summary s subst) + | Env_class(s, id, desc) -> + Env.add_class id (Subst.class_declaration subst desc) + (env_from_summary s subst) + | Env_cltype (s, id, desc) -> + Env.add_cltype id (Subst.cltype_declaration subst desc) + (env_from_summary s subst) + | Env_open(s, path) -> + let env = env_from_summary s subst in + let path' = Subst.module_path subst path in + begin match Env.open_signature Asttypes.Override path' env with + | Ok env -> env + | Error `Functor -> assert false + | Error `Not_found -> raise (Error (Module_not_found path')) + end + | Env_functor_arg(Env_module(s, id, pres, desc), id') + when Ident.same id id' -> + Env.add_module_declaration ~check:false + id pres (Subst.module_declaration Keep subst desc) + ~arg:true (env_from_summary s subst) + | Env_functor_arg _ -> assert false + | Env_constraints(s, map) -> + Path.Map.fold + (fun path info -> + Env.add_local_constraint (Subst.type_path subst path) + (Subst.type_declaration subst info)) + map (env_from_summary s subst) + | Env_copy_types s -> + let env = env_from_summary s subst in + Env.make_copy_of_types env env + | Env_persistent (s, id) -> + let env = env_from_summary s subst in + Env.add_persistent_structure id env + | Env_value_unbound (s, str, reason) -> + let env = env_from_summary s subst in + Env.enter_unbound_value str reason env + | Env_module_unbound (s, str, reason) -> + let env = env_from_summary s subst in + Env.enter_unbound_module str reason env + in + Hashtbl.add env_cache (sum, subst) env; + env + +let env_of_only_summary env = + Env.env_of_only_summary env_from_summary env + +(* Error report *) + +open Format_doc +module Style = Misc.Style + +let report_error_doc ppf = function + | Module_not_found p -> + fprintf ppf "@[Cannot find module %a@].@." + (Style.as_inline_code Printtyp.Doc.path) p + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error_doc err) + | _ -> None + ) + +let report_error = Format_doc.compat report_error_doc diff --git a/upstream/ocaml_503/typing/envaux.mli b/upstream/ocaml_503/typing/envaux.mli new file mode 100644 index 000000000..5fbb8410b --- /dev/null +++ b/upstream/ocaml_503/typing/envaux.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Convert environment summaries to environments *) + +val env_from_summary : Env.summary -> Subst.t -> Env.t + +(* Empty the environment caches. To be called when load_path changes. *) + +val reset_cache: unit -> unit + +val env_of_only_summary : Env.t -> Env.t + +(* Error report *) + +type error = + Module_not_found of Path.t + +exception Error of error + +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer diff --git a/upstream/ocaml_503/typing/errortrace.ml b/upstream/ocaml_503/typing/errortrace.ml new file mode 100644 index 000000000..347e5c9a4 --- /dev/null +++ b/upstream/ocaml_503/typing/errortrace.ml @@ -0,0 +1,202 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* Antal Spector-Zabusky, Jane Street, New York *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types +open Format_doc + +type position = First | Second + +let swap_position = function + | First -> Second + | Second -> First + +let print_pos ppf = function + | First -> fprintf ppf "first" + | Second -> fprintf ppf "second" + +type expanded_type = { ty: type_expr; expanded: type_expr } + +let trivial_expansion ty = { ty; expanded = ty } + +type 'a diff = { got: 'a; expected: 'a } + +let map_diff f r = + (* ordering is often meaningful when dealing with type_expr *) + let got = f r.got in + let expected = f r.expected in + { got; expected } + +let swap_diff x = { got = x.expected; expected = x.got } + +type 'a escape_kind = + | Constructor of Path.t + | Univ of type_expr + (* The type_expr argument of [Univ] is always a [Tunivar _], + we keep a [type_expr] to track renaming in {!Printtyp} *) + | Self + | Module_type of Path.t + | Equation of 'a + | Constraint + +type 'a escape = + { kind : 'a escape_kind; + context : type_expr option } + +let map_escape f esc = + {esc with kind = match esc.kind with + | Equation eq -> Equation (f eq) + | (Constructor _ | Univ _ | Self | Module_type _ | Constraint) as c -> c} + +let explain trace f = + let rec explain = function + | [] -> None + | [h] -> f ~prev:None h + | h :: (prev :: _ as rem) -> + match f ~prev:(Some prev) h with + | Some _ as m -> m + | None -> explain rem in + explain (List.rev trace) + +(* Type indices *) +type unification = private Unification +type comparison = private Comparison + +type fixed_row_case = + | Cannot_be_closed + | Cannot_add_tags of string list + +type 'variety variant = + (* Common *) + | Incompatible_types_for : string -> _ variant + | No_tags : position * (Asttypes.label * row_field) list -> _ variant + (* Unification *) + | No_intersection : unification variant + | Fixed_row : + position * fixed_row_case * fixed_explanation -> unification variant + (* Equality & Moregen *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | Openness : position (* Always [Second] for Moregen *) -> comparison variant + +type 'variety obj = + (* Common *) + | Missing_field : position * string -> _ obj + | Abstract_row : position -> _ obj + (* Unification *) + | Self_cannot_be_closed : unification obj + +type first_class_module = + | Package_cannot_scrape of Path.t + | Package_inclusion of Format_doc.doc + | Package_coercion of Format_doc.doc + +type ('a, 'variety) elt = + (* Common *) + | Diff : 'a diff -> ('a, _) elt + | Variant : 'variety variant -> ('a, 'variety) elt + | Obj : 'variety obj -> ('a, 'variety) elt + | Escape : 'a escape -> ('a, _) elt + | Function_label_mismatch of Asttypes.arg_label diff + | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt + (* Could move [Incompatible_fields] into [obj] *) + | First_class_module: first_class_module -> ('a,_) elt + (* Unification & Moregen; included in Equality for simplicity *) + | Rec_occur : type_expr * type_expr -> ('a, _) elt + +type ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +let map_elt (type variety) f : ('a, variety) elt -> ('b, variety) elt = function + | Diff x -> Diff (map_diff f x) + | Escape {kind = Equation x; context} -> + Escape { kind = Equation (f x); context } + | Escape {kind = (Univ _ | Self | Constructor _ | Module_type _ | Constraint); + _} + | Variant _ | Obj _ | Function_label_mismatch _ | Incompatible_fields _ + | Rec_occur (_, _) | First_class_module _ as x -> x + +let map f t = List.map (map_elt f) t + +let incompatible_fields ~name ~got ~expected = + Incompatible_fields { name; diff={got; expected} } + +let swap_elt (type variety) : ('a, variety) elt -> ('a, variety) elt = function + | Diff x -> Diff (swap_diff x) + | Incompatible_fields { name; diff } -> + Incompatible_fields { name; diff = swap_diff diff} + | Obj (Missing_field(pos,s)) -> Obj (Missing_field(swap_position pos,s)) + | Obj (Abstract_row pos) -> Obj (Abstract_row (swap_position pos)) + | Variant (Fixed_row(pos,k,f)) -> + Variant (Fixed_row(swap_position pos,k,f)) + | Variant (No_tags(pos,f)) -> + Variant (No_tags(swap_position pos,f)) + | x -> x + +let swap_trace e = List.map swap_elt e + +type unification_error = { trace : unification error } [@@unboxed] + +type equality_error = + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = { trace : comparison error } [@@unboxed] + +let unification_error ~trace : unification_error = + assert (trace <> []); + { trace } + +let equality_error ~trace ~subst : equality_error = + assert (trace <> []); + { trace; subst } + +let moregen_error ~trace : moregen_error = + assert (trace <> []); + { trace } + +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +let swap_unification_error ({trace} : unification_error) = + ({trace = swap_trace trace} : unification_error) + +module Subtype = struct + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = + { trace : error_trace + ; unification_trace : unification error } + + let error ~trace ~unification_trace = + assert (trace <> []); + { trace; unification_trace } + + let map_elt f = function + | Diff x -> Diff (map_diff f x) + + let map f t = List.map (map_elt f) t +end diff --git a/upstream/ocaml_503/typing/errortrace.mli b/upstream/ocaml_503/typing/errortrace.mli new file mode 100644 index 000000000..6b42b66a3 --- /dev/null +++ b/upstream/ocaml_503/typing/errortrace.mli @@ -0,0 +1,175 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* Antal Spector-Zabusky, Jane Street, New York *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +type position = First | Second + +val swap_position : position -> position +val print_pos : position Format_doc.printer + +type expanded_type = { ty: type_expr; expanded: type_expr } + +(** [trivial_expansion ty] creates an [expanded_type] whose expansion is also + [ty]. Usually, you want [Ctype.expand_type] instead, since the expansion + carries useful information; however, in certain circumstances, the error is + about the expansion of the type, meaning that actually performing the + expansion produces more confusing or inaccurate output. *) +val trivial_expansion : type_expr -> expanded_type + +type 'a diff = { got: 'a; expected: 'a } + +(** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *) +val map_diff: ('a -> 'b) -> 'a diff -> 'b diff + +(** Scope escape related errors *) +type 'a escape_kind = + | Constructor of Path.t + | Univ of type_expr + (* The type_expr argument of [Univ] is always a [Tunivar _], + we keep a [type_expr] to track renaming in {!Printtyp} *) + | Self + | Module_type of Path.t + | Equation of 'a + | Constraint + +type 'a escape = + { kind : 'a escape_kind; + context : type_expr option } + +val map_escape : ('a -> 'b) -> 'a escape -> 'b escape + +val explain: 'a list -> + (prev:'a option -> 'a -> 'b option) -> + 'b option + +(** Type indices *) +type unification = private Unification +type comparison = private Comparison + +type fixed_row_case = + | Cannot_be_closed + | Cannot_add_tags of string list + +type 'variety variant = + (* Common *) + | Incompatible_types_for : string -> _ variant + | No_tags : position * (Asttypes.label * row_field) list -> _ variant + (* Unification *) + | No_intersection : unification variant + | Fixed_row : + position * fixed_row_case * fixed_explanation -> unification variant + (* Equality & Moregen *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | Openness : position (* Always [Second] for Moregen *) -> comparison variant + +type 'variety obj = + (* Common *) + | Missing_field : position * string -> _ obj + | Abstract_row : position -> _ obj + (* Unification *) + | Self_cannot_be_closed : unification obj + +type first_class_module = + | Package_cannot_scrape of Path.t + | Package_inclusion of Format_doc.doc + | Package_coercion of Format_doc.doc + +type ('a, 'variety) elt = + (* Common *) + | Diff : 'a diff -> ('a, _) elt + | Variant : 'variety variant -> ('a, 'variety) elt + | Obj : 'variety obj -> ('a, 'variety) elt + | Escape : 'a escape -> ('a, _) elt + | Function_label_mismatch of Asttypes.arg_label diff + | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt + | First_class_module: first_class_module -> ('a,_) elt + (* Unification & Moregen; included in Equality for simplicity *) + | Rec_occur : type_expr * type_expr -> ('a, _) elt + +type ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +val map : ('a -> 'b) -> ('a, 'variety) t -> ('b, 'variety) t + +val incompatible_fields : + name:string -> got:type_expr -> expected:type_expr -> (type_expr, _) elt + +val swap_trace : ('a, 'variety) t -> ('a, 'variety) t + +(** The traces (['variety t]) are the core error types. However, we bundle them + up into three "top-level" error types, which are used elsewhere: + [unification_error], [equality_error], and [moregen_error]. In the case of + [equality_error], this has to bundle in extra information; in general, it + distinguishes the three types of errors and allows us to distinguish traces + that are being built (or processed) from those that are complete and have + become the final error. These error types have the invariants that their + traces are nonempty; we ensure that through three smart constructors with + matching names. *) + +type unification_error = private { trace : unification error } [@@unboxed] + +type equality_error = private + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = private { trace : comparison error } [@@unboxed] + +val unification_error : trace:unification error -> unification_error + +val equality_error : + trace:comparison error -> subst:(type_expr * type_expr) list -> equality_error + +val moregen_error : trace:comparison error -> moregen_error + +(** Wraps up the two different kinds of [comparison] errors in one type *) +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +(** Lift [swap_trace] to [unification_error] *) +val swap_unification_error : unification_error -> unification_error + +module Subtype : sig + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + (** Just as outside [Subtype], we split traces, completed traces, and complete + errors. However, in a minor asymmetry, the name [Subtype.error_trace] + corresponds to the outside [error] type, and [Subtype.error] corresponds + to the outside [*_error] types (e.g., [unification_error]). This [error] + type has the invariant that the subtype trace is nonempty; note that no + such invariant is imposed on the unification trace. *) + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = private + { trace : error_trace + ; unification_trace : unification error } + + val error : + trace:error_trace -> unification_trace:unification_error_trace -> error + + val map : ('a -> 'b) -> 'a t -> 'b t +end diff --git a/upstream/ocaml_503/typing/errortrace_report.ml b/upstream/ocaml_503/typing/errortrace_report.ml new file mode 100644 index 000000000..03012f7d8 --- /dev/null +++ b/upstream/ocaml_503/typing/errortrace_report.ml @@ -0,0 +1,590 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Trace-specific printing *) + +(* A configuration type that controls which trace we print. This could be + exposed, but we instead expose three separate + [{unification,equality,moregen}] functions. This also lets us + give the unification case an extra optional argument without adding it to the + equality and moregen cases. *) +type 'variety trace_format = + | Unification : Errortrace.unification trace_format + | Equality : Errortrace.comparison trace_format + | Moregen : Errortrace.comparison trace_format + +let incompatibility_phrase (type variety) : variety trace_format -> string = + function + | Unification -> "is not compatible with type" + | Equality -> "is not equal to type" + | Moregen -> "is not compatible with type" + +(* Print a unification error *) +open Out_type +open Format_doc +module Fmt = Format_doc +module Style = Misc.Style + +type 'a diff = 'a Out_type.diff = Same of 'a | Diff of 'a * 'a + +let trees_of_trace mode = + List.map (Errortrace.map_diff (trees_of_type_expansion mode)) + +let rec trace fst txt ppf = function + | {Errortrace.got; expected} :: rem -> + if not fst then fprintf ppf "@,"; + fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" + pp_type_expansion got txt pp_type_expansion expected + (trace false txt) rem + | _ -> () + +type printing_status = + | Discard + | Keep + | Optional_refinement + (** An [Optional_refinement] printing status is attributed to trace + elements that are focusing on a new subpart of a structural type. + Since the whole type should have been printed earlier in the trace, + we only print those elements if they are the last printed element + of a trace, and there is no explicit explanation for the + type error. + *) + +let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; + expected = {ty = t2; expanded = t2'} } = + if Btype.is_constr_row ~allow_ident:true t1' + || Btype.is_constr_row ~allow_ident:true t2' + then Discard + else if same_path t1 t1' && same_path t2 t2' then Optional_refinement + else Keep + +let printing_status = function + | Errortrace.Diff d -> diff_printing_status d + | Errortrace.Escape {kind = Constraint} -> Keep + | _ -> Keep + +(** Flatten the trace and remove elements that are always discarded + during printing *) + +(* Takes [printing_status] to change behavior for [Subtype] *) +let prepare_any_trace printing_status tr = + let clean_trace x l = match printing_status x with + | Keep -> x :: l + | Optional_refinement when l = [] -> [x] + | Optional_refinement | Discard -> l + in + match tr with + | [] -> [] + | elt :: rem -> elt :: List.fold_right clean_trace rem [] + +let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.map f tr) + +(** Keep elements that are [Diff _ ] and split the the last element if it is + optionally elidable, require a prepared trace *) +let rec filter_trace = function + | [] -> [], None + | [Errortrace.Diff d as elt] + when printing_status elt = Optional_refinement -> [], Some d + | Errortrace.Diff d :: rem -> + let filtered, last = filter_trace rem in + d :: filtered, last + | _ :: rem -> filter_trace rem + +let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = + match Types.get_desc expanded with + Tvariant _ | Tobject _ when compact -> + Variable_names.reserve ty; Errortrace.{ty; expanded = ty} + | _ -> prepare_expansion ty_exp + +let print_path p = + Fmt.dprintf "%a" !Oprint.out_ident (namespaced_tree_of_path Type p) + +let print_tag ppf s = Style.inline_code ppf ("`" ^ s) + +let print_tags ppf tags = + Fmt.(pp_print_list ~pp_sep:comma) print_tag ppf tags + +let is_unit env ty = + match Types.get_desc (Ctype.expand_head env ty) with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + +let unifiable env ty1 ty2 = + let snap = Btype.snapshot () in + let res = + try Ctype.unify env ty1 ty2; true + with Ctype.Unify _ -> false + in + Btype.backtrack snap; + res + +let explanation_diff env t3 t4 = + match Types.get_desc t3, Types.get_desc t4 with + | Tarrow (_, ty1, ty2, _), _ + when is_unit env ty1 && unifiable env ty2 t4 -> + Some (doc_printf + "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" + Style.inline_code "()" + ) + | _, Tarrow (_, ty1, ty2, _) + when is_unit env ty1 && unifiable env t3 ty2 -> + Some (doc_printf + "@,@[@{Hint@}: Did you forget to wrap the expression using \ + %a?@]" + Style.inline_code "fun () ->" + ) + | _ -> + None + +let explain_fixed_row_case = function + | Errortrace.Cannot_be_closed -> doc_printf "it cannot be closed" + | Errortrace.Cannot_add_tags tags -> + doc_printf "it may not allow the tag(s) %a" + print_tags tags + +let pp_path ppf p = + Style.as_inline_code Printtyp.Doc.path ppf p + +let explain_fixed_row pos expl = match expl with + | Types.Fixed_private -> + doc_printf "The %a variant type is private" Errortrace.print_pos pos + | Types.Univar x -> + Variable_names.reserve x; + doc_printf "The %a variant type is bound to the universal type variable %a" + Errortrace.print_pos pos + (Style.as_inline_code type_expr_with_reserved_names) x + | Types.Reified p -> + doc_printf "The %a variant type is bound to %a" + Errortrace.print_pos pos + (Style.as_inline_code + (fun ppf p -> + Internal_names.add p; + print_path p ppf)) + p + | Types.Rigid -> Format_doc.Doc.empty + +let explain_variant (type variety) : variety Errortrace.variant -> _ = function + (* Common *) + | Errortrace.Incompatible_types_for s -> + Some(doc_printf "@,Types for tag %a are incompatible" + print_tag s + ) + (* Unification *) + | Errortrace.No_intersection -> + Some(doc_printf "@,These two variant types have no intersection") + | Errortrace.No_tags(pos,fields) -> Some( + doc_printf + "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" + Errortrace.print_pos pos + print_tags (List.map fst fields) + ) + | Errortrace.Fixed_row (pos, + k, + (Univar _ | Reified _ | Fixed_private as e)) -> + Some ( + doc_printf "@,@[%a,@ %a@]" pp_doc (explain_fixed_row pos e) + pp_doc (explain_fixed_row_case k) + ) + | Errortrace.Fixed_row (_,_, Rigid) -> + (* this case never happens *) + None + (* Equality & Moregen *) + | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( + doc_printf + "@,@[The tag %a is guaranteed to be present in the %a variant type,\ + @ but not in the %a@]" + print_tag s + Errortrace.print_pos (Errortrace.swap_position pos) + Errortrace.print_pos pos + ) + | Errortrace.Openness pos -> + Some(doc_printf "@,The %a variant type is open and the %a is not" + Errortrace.print_pos pos + Errortrace.print_pos (Errortrace.swap_position pos)) + +let explain_escape pre = function + | Errortrace.Univ u -> + Variable_names.reserve u; + Some( + doc_printf "%a@,The universal variable %a would escape its scope" + pp_doc pre + (Style.as_inline_code type_expr_with_reserved_names) u + ) + | Errortrace.Constructor p -> Some( + doc_printf + "%a@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + pp_doc pre pp_path p + ) + | Errortrace.Module_type p -> Some( + doc_printf + "%a@,@[The module type@;<1 2>%a@ would escape its scope@]" + pp_doc pre pp_path p + ) + | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> + Variable_names.reserve t; + Some( + doc_printf "%a@ @[This instance of %a is ambiguous:@ %s@]" + pp_doc pre + (Style.as_inline_code type_expr_with_reserved_names) t + "it would escape the scope of its equation" + ) + | Errortrace.Self -> + Some (doc_printf "%a@,Self type cannot escape its class" pp_doc pre) + | Errortrace.Constraint -> + None + +let explain_object (type variety) : variety Errortrace.obj -> _ = function + | Errortrace.Missing_field (pos,f) -> Some( + doc_printf "@,@[The %a object type has no method %a@]" + Errortrace.print_pos pos Style.inline_code f + ) + | Errortrace.Abstract_row pos -> Some( + doc_printf + "@,@[The %a object type has an abstract row, it cannot be closed@]" + Errortrace.print_pos pos + ) + | Errortrace.Self_cannot_be_closed -> + Some (doc_printf + "@,Self type cannot be unified with a closed object type" + ) + +let explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = + Variable_names.reserve diff.got; + Variable_names.reserve diff.expected; + doc_printf "@,@[The method %a has type@ %a,@ \ + but the expected method type was@ %a@]" + Style.inline_code name + (Style.as_inline_code type_expr_with_reserved_names) diff.got + (Style.as_inline_code type_expr_with_reserved_names) diff.expected + + +let explain_label_mismatch ~got ~expected = + let quoted_label ppf l = Style.inline_code ppf (Asttypes.string_of_label l) in + match got, expected with + | Asttypes.Nolabel, Asttypes.(Labelled _ | Optional _ ) -> + doc_printf "@,@[A label@ %a@ was expected@]" + quoted_label expected + | Asttypes.(Labelled _|Optional _), Asttypes.Nolabel -> + doc_printf + "@,@[The first argument is labeled@ %a,@ \ + but an unlabeled argument was expected@]" + quoted_label got + | Asttypes.Labelled g, Asttypes.Optional e when g = e -> + doc_printf + "@,@[The label@ %a@ was expected to be optional@]" + quoted_label got + | Asttypes.Optional g, Asttypes.Labelled e when g = e -> + doc_printf + "@,@[The label@ %a@ was expected to not be optional@]" + quoted_label got + | Asttypes.(Labelled _ | Optional _), Asttypes.(Labelled _ | Optional _) -> + doc_printf "@,@[Labels %a@ and@ %a do not match@]" + quoted_label got + quoted_label expected + | Asttypes.Nolabel, Asttypes.Nolabel -> + (* Two empty labels cannot be mismatched*) + assert false + + +let explain_first_class_module = function + | Errortrace.Package_cannot_scrape p -> Some( + doc_printf "@,@[The module alias %a could not be expanded@]" + pp_path p + ) + | Errortrace.Package_inclusion pr -> + Some(doc_printf "@,@[%a@]" Fmt.pp_doc pr) + | Errortrace.Package_coercion pr -> + Some(doc_printf "@,@[%a@]" Fmt.pp_doc pr) + +let explanation (type variety) intro prev env + : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function + | Errortrace.Diff {got; expected} -> + explanation_diff env got.expanded expected.expanded + | Errortrace.Escape {kind; context} -> + let pre = + match context, kind, prev with + | Some ctx, _, _ -> + Variable_names.reserve ctx; + doc_printf "@[%a@;<1 2>%a@]" pp_doc intro + (Style.as_inline_code type_expr_with_reserved_names) ctx + | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> + explain_incompatible_fields name diff + | _ -> Format_doc.Doc.empty + in + explain_escape pre kind + | Errortrace.Incompatible_fields { name; diff} -> + Some(explain_incompatible_fields name diff) + | Errortrace.Function_label_mismatch diff -> + Some(explain_label_mismatch ~got:diff.got ~expected:diff.expected) + | Errortrace.Variant v -> + explain_variant v + | Errortrace.Obj o -> + explain_object o + | Errortrace.First_class_module fm -> + explain_first_class_module fm + | Errortrace.Rec_occur(x,y) -> + add_type_to_preparation x; + add_type_to_preparation y; + begin match Types.get_desc x with + | Tvar _ | Tunivar _ -> + Some( + doc_printf "@,@[The type variable %a occurs inside@ %a@]" + (Style.as_inline_code prepared_type_expr) x + (Style.as_inline_code prepared_type_expr) y + ) + | _ -> + (* We had a delayed unification of the type variable with + a non-variable after the occur check. *) + Some Format_doc.Doc.empty + (* There is no need to search further for an explanation, but + we don't want to print a message of the form: + {[ The type int occurs inside int list -> 'a |} + *) + end + +let mismatch intro env trace = + Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) + +let warn_on_missing_def env ppf t = + match Types.get_desc t with + | Tconstr (p,_,_) -> + begin match Env.find_type p env with + | exception Not_found -> + fprintf ppf + "@,@[Type %a is abstract because@ no corresponding\ + @ cmi file@ was found@ in path.@]" pp_path p + | { type_manifest = Some _; _ } -> () + | { type_manifest = None; _ } as decl -> + match Btype.type_origin decl with + | Rec_check_regularity -> + fprintf ppf + "@,@[Type %a was considered abstract@ when checking\ + @ constraints@ in this@ recursive type definition.@]" + pp_path p + | Definition | Existential _ -> () + end + | _ -> () + +let prepare_expansion_head empty_tr = function + | Errortrace.Diff d -> + Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) + | _ -> None + +let head_error_printer mode txt_got txt_but = function + | None -> Format_doc.Doc.empty + | Some d -> + let d = Errortrace.map_diff (trees_of_type_expansion mode) d in + doc_printf "%a@;<1 2>%a@ %a@;<1 2>%a" + pp_doc txt_got pp_type_expansion d.Errortrace.got + pp_doc txt_but pp_type_expansion d.Errortrace.expected + +let warn_on_missing_defs env ppf = function + | None -> () + | Some Errortrace.{got = {ty=te1; expanded=_}; + expected = {ty=te2; expanded=_} } -> + warn_on_missing_def env ppf te1; + warn_on_missing_def env ppf te2 + +(* [subst] comes out of equality, and is [[]] otherwise *) +let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = + reset (); + (* We want to substitute in the opposite order from [Eqtype] *) + Variable_names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); + let tr = + prepare_trace + (fun ty_exp -> + Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) + tr + in + match tr with + | [] -> assert false + | (elt :: tr) as full_trace -> + with_labels (not !Clflags.classic) (fun () -> + let tr, last = filter_trace tr in + let head = prepare_expansion_head (tr=[] && last=None) elt in + let tr = List.map (Errortrace.map_diff prepare_expansion) tr in + let last = Option.map (Errortrace.map_diff prepare_expansion) last in + let head_error = head_error_printer mode txt1 txt2 head in + let tr = trees_of_trace mode tr in + let last = + Option.map (Errortrace.map_diff (trees_of_type_expansion mode)) last in + let mis = mismatch txt1 env full_trace in + let tr = match mis, last with + | None, Some elt -> tr @ [elt] + | Some _, _ | _, None -> tr + in + fprintf ppf + "@[\ + @[%a%a@]%a%a\ + @]" + pp_doc head_error + pp_doc ty_expect_explanation + (trace false (incompatibility_phrase trace_format)) tr + (pp_print_option pp_doc) mis; + if env <> Env.empty + then warn_on_missing_defs env ppf head; + Internal_names.print_explanations env ppf; + Ident_conflicts.err_print ppf + ) + +let report_error trace_format ppf mode env tr + ?(subst = []) + ?(type_expected_explanation = Fmt.Doc.empty) + txt1 txt2 = + wrap_printing_env ~error:true env (fun () -> + error trace_format mode subst env tr txt1 ppf txt2 + type_expected_explanation) + +let unification + ppf env ({trace} : Errortrace.unification_error) = + report_error Unification ppf Type env + ?subst:None trace + +let equality + ppf mode env ({subst; trace} : Errortrace.equality_error) = + report_error Equality ppf mode env + ~subst ?type_expected_explanation:None trace + +let moregen + ppf mode env ({trace} : Errortrace.moregen_error) = + report_error Moregen ppf mode env + ?subst:None ?type_expected_explanation:None trace + +let comparison ppf mode env = function + | Errortrace.Equality_error error -> equality ppf mode env error + | Errortrace.Moregen_error error -> moregen ppf mode env error + +module Subtype = struct + (* There's a frustrating amount of code duplication between this module and + the outside code, particularly in [prepare_trace] and [filter_trace]. + Unfortunately, [Subtype] is *just* similar enough to have code duplication, + while being *just* different enough (it's only [Diff]) for the abstraction + to be nonobvious. Someday, perhaps... *) + + let printing_status = function + | Errortrace.Subtype.Diff d -> diff_printing_status d + + let prepare_unification_trace = prepare_trace + + let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.Subtype.map f tr) + + let trace filter_trace get_diff fst keep_last txt ppf tr = + with_labels (not !Clflags.classic) (fun () -> + match tr with + | elt :: tr' -> + let diffed_elt = get_diff elt in + let tr, last = filter_trace tr' in + let tr = match keep_last, last with + | true, Some last -> tr @ [last] + | _ -> tr + in + let tr = + trees_of_trace Type + @@ List.map (Errortrace.map_diff prepare_expansion) tr in + let tr = + match fst, diffed_elt with + | true, Some elt -> elt :: tr + | _, _ -> tr + in + trace fst txt ppf tr + | _ -> () + ) + + let rec filter_subtype_trace = function + | [] -> [], None + | [Errortrace.Subtype.Diff d as elt] + when printing_status elt = Optional_refinement -> + [], Some d + | Errortrace.Subtype.Diff d :: rem -> + let ftr, last = filter_subtype_trace rem in + d :: ftr, last + + let unification_get_diff = function + | Errortrace.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + | _ -> None + + let subtype_get_diff = function + | Errortrace.Subtype.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + + let error + ppf + env + (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) + txt1 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tr_sub = prepare_trace prepare_expansion tr_sub in + let tr_unif = prepare_unification_trace prepare_expansion tr_unif in + let keep_first = match tr_unif with + | [Obj _ | Variant _ | Escape _ ] | [] -> true + | _ -> false in + fprintf ppf "@[%a" + (trace filter_subtype_trace subtype_get_diff true keep_first txt1) + tr_sub; + if tr_unif = [] then fprintf ppf "@]" else + let mis = mismatch (doc_printf "Within this type") env tr_unif in + fprintf ppf "%a%a%t@]" + (trace filter_trace unification_get_diff false + (mis = None) "is not compatible with type") tr_unif + (pp_print_option pp_doc) mis + Ident_conflicts.err_print + ) +end + +let subtype = Subtype.error + +let quoted_ident ppf t = + Style.as_inline_code !Oprint.out_ident ppf t + +let type_path_expansion ppf = function + | Same p -> quoted_ident ppf p + | Diff(p,p') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + quoted_ident p + quoted_ident p' + +let trees_of_type_path_expansion (tp,tp') = + let path_tree = namespaced_tree_of_path Type in + if Path.same tp tp' then Same(path_tree tp) else + Diff(path_tree tp, path_tree tp) + +let type_path_list ppf l = + Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.pp_print_break ppf 2 0) + type_path_expansion ppf l + +let ambiguous_type ppf env tp0 tpl txt1 txt2 txt3 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tp0 = trees_of_type_path_expansion tp0 in + match tpl with + [] -> assert false + | [tp] -> + fprintf ppf + "@[%a@;<1 2>%a@ \ + %a@;<1 2>%a\ + @]" + pp_doc txt1 type_path_expansion (trees_of_type_path_expansion tp) + pp_doc txt3 type_path_expansion tp0 + | _ -> + fprintf ppf + "@[%a@;<1 2>@[%a@]\ + @ %a@;<1 2>%a\ + @]" + pp_doc txt2 type_path_list (List.map trees_of_type_path_expansion tpl) + pp_doc txt3 type_path_expansion tp0) diff --git a/upstream/ocaml_503/typing/errortrace_report.mli b/upstream/ocaml_503/typing/errortrace_report.mli new file mode 100644 index 000000000..bb6f0ea9e --- /dev/null +++ b/upstream/ocaml_503/typing/errortrace_report.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Functions for reporting core level type errors. *) + +open Format_doc + +val ambiguous_type: + formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> + Format_doc.t -> Format_doc.t -> Format_doc.t -> unit + +val unification : + formatter -> + Env.t -> Errortrace.unification_error -> + ?type_expected_explanation:Format_doc.t -> Format_doc.t -> Format_doc.t -> + unit + +val equality : + formatter -> + Out_type.type_or_scheme -> + Env.t -> Errortrace.equality_error -> + Format_doc.t -> Format_doc.t -> + unit + +val moregen : + formatter -> + Out_type.type_or_scheme -> + Env.t -> Errortrace.moregen_error -> + Format_doc.t -> Format_doc.t -> + unit + +val comparison : + formatter -> + Out_type.type_or_scheme -> + Env.t -> Errortrace.comparison_error -> + Format_doc.t -> Format_doc.t -> + unit + +val subtype : + formatter -> + Env.t -> + Errortrace.Subtype.error -> + string -> + unit diff --git a/upstream/ocaml_503/typing/gprinttyp.ml b/upstream/ocaml_503/typing/gprinttyp.ml new file mode 100644 index 000000000..0056efb93 --- /dev/null +++ b/upstream/ocaml_503/typing/gprinttyp.ml @@ -0,0 +1,912 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +(* Print a raw type expression, with sharing *) +open Format + +module String_set = Set.Make(String) + +module Decoration = struct + type color = + | Named of string + | HSL of {h:float;s:float;l:float} + + let red = Named "red" + let blue = Named "blue" + let green = Named "green" + let purple = Named "purple" + let lightgrey = Named "lightgrey" + let hsl ~h ~s ~l = HSL {h;s;l} + + type style = + | Filled of color option + | Dotted + | Dash + + type shape = + | Ellipse + | Circle + | Diamond + + type property = + | Color of color + | Font_color of color + | Style of style + | Label of string list + | Shape of shape + + let filled c = Style (Filled (Some c)) + + type r = { + color: color option; + font_color:color option; + style: style option; + label: string list; + shape: shape option; + } + + let update r l = match l with + | Color c -> { r with color = Some c} + | Style s -> { r with style = Some s} + | Label s -> { r with label = s} + | Font_color c -> { r with font_color = Some c} + | Shape s -> { r with shape = Some s } + + let none = { color=None; font_color=None; style=None; shape=None; label = [] } + + let make l = List.fold_left update none l + + let label r = if r.label = [] then None else Some (Label r.label) + let color r = Option.map (fun x -> Color x) r.color + let font_color r = Option.map (fun x -> Font_color x) r.font_color + let style r = Option.map (fun x -> Style x) r.style + let shape r = Option.map (fun x -> Shape x) r.shape + + let decompose r = + let (@?) x l = match x with + | None -> l + | Some x -> x :: l + in + label r @? color r @? font_color r @? style r @? shape r @? [] + + let alt x y = match x with + | None -> y + | Some _ -> x + + let merge_label l r = + let r' = String_set.of_list r in + let l' = String_set.of_list l in + List.filter (fun x -> not (String_set.mem x r') ) l + @ List.filter (fun x -> not (String_set.mem x l') ) r + + let merge l r = + { color = alt l.color r.color; + style = alt l.style r.style; + label = merge_label l.label r.label; + font_color = alt l.font_color r.font_color; + shape = alt l.shape r.shape; + } + let txt t = Label [t] + +end +type decoration = Decoration.r + +type dir = Toward | From + +let txt = Decoration.txt +let std = Decoration.none +let dotted = Decoration.(make [Style Dotted]) +let memo = Decoration.(make [txt "expand"; Style Dash] ) + + +type params = { + short_ids:bool; + elide_links:bool; + expansion_as_hyperedge:bool; + colorize:bool; + follow_expansions:bool; +} + +let elide_links ty = + let rec follow_safe visited t = + let t = Types.Transient_expr.coerce t in + if List.memq t visited then t + else match t.Types.desc with + | Tlink t' -> follow_safe (t::visited) t' + | _ -> t + in + follow_safe [] ty + +let repr params ty = + if params.elide_links then elide_links ty + else Types.Transient_expr.coerce ty + +module Index: sig + type t = private + | Main of int + | Synthetic of int + | Named_subnode of { id:int; synth:bool; name:string } + val subnode: name:string -> t -> t + val either_ext: Types.row_field_cell -> t + val split: + params -> Types.type_expr -> t * Decoration.color option * Types.type_desc + val colorize: params -> t -> Decoration.color option +end = struct + type t = + | Main of int + | Synthetic of int + | Named_subnode of { id:int; synth:bool; name:string } + + type name_map = { + (* We keep the main and synthetic and index space separate to avoid index + collision when we use the typechecker provided [id]s as main indices *) + main_last: int ref; + synthetic_last: int ref; + either_cell_ids: (Types.row_field_cell * int) list ref; + tbl: (int,int) Hashtbl.t; + } + + let id_map = { + main_last = ref 0; + synthetic_last = ref 0; + either_cell_ids = ref []; + tbl = Hashtbl.create 20; + } + + let fresh_main_id () = + incr id_map.main_last; + !(id_map.main_last) + + let fresh_synthetic_id () = + incr id_map.synthetic_last; + !(id_map.synthetic_last) + + let stable_id = function + | Main id | Synthetic id | Named_subnode {id;_} -> id + + let pretty_id params id = + if not params.short_ids then Main id else + match Hashtbl.find_opt id_map.tbl id with + | Some x -> Main x + | None -> + let last = fresh_main_id () in + Hashtbl.replace id_map.tbl id last; + Main last + + (** Generate color from the node id to keep the color stable inbetween + different calls to the typechecker on the same input. *) + let colorize_id params id = + if not params.colorize then None + else + (* Generate pseudo-random color by cycling over 200 hues while keeping + pastel level of saturation and lightness *) + let nhues = 200 in + (* 17 and 200 are relatively prime, thus 17 is of order 200 in Z/200Z. A + step size around 20 makes it relatively easy to spot different hues. *) + let h = float_of_int (17 * id mod nhues) /. float_of_int nhues in + (* Add a modulation of period 3 and 7 to the saturation and lightness *) + let s = match id mod 3 with + | 0 -> 0.3 + | 1 -> 0.5 + | 2 | _ -> 0.7 + in + let l = match id mod 7 with + | 0 -> 0.5 + | 1 -> 0.55 + | 2 -> 0.60 + | 3 -> 0.65 + | 4 -> 0.70 + | 5 -> 0.75 + | 6 | _ -> 0.8 + in + (* With 3, 7 and 200 relatively prime, we cycle over the full parameter + space with 4200 different colors. *) + Some (Decoration.hsl ~h ~s ~l) + + let colorize params index = colorize_id params (stable_id index) + + let split params x = + let x = repr params x in + let color = colorize_id params x.id in + pretty_id params x.id, color, x.desc + + let subnode ~name x = match x with + | Main id -> Named_subnode {id;name;synth=false} + | Named_subnode r -> Named_subnode {r with name} + | Synthetic id -> Named_subnode {id;name;synth=true} + + let either_ext r = + let either_ids = !(id_map.either_cell_ids) in + match List.assq_opt r either_ids with + | Some n -> Synthetic n + | None -> + let n = fresh_synthetic_id () in + id_map.either_cell_ids := (r,n) :: either_ids; + Synthetic n + +end + + +type index = Index.t +module Node_set = Set.Make(struct + type t = Index.t + let compare = Stdlib.compare +end) + +module Edge_set = Set.Make(struct + type t = Index.t * Index.t + let compare = Stdlib.compare +end) + +module Hyperedge_set = Set.Make(struct + type t = (dir * Decoration.r * index) list + let compare = Stdlib.compare +end) + +type subgraph = + { + nodes: Node_set.t; + edges: Edge_set.t; + hyperedges: Hyperedge_set.t; + subgraphes: (Decoration.r * subgraph) list; + } + + +let empty_subgraph= + { nodes = Node_set.empty; + edges=Edge_set.empty; + hyperedges = Hyperedge_set.empty; + subgraphes = []; + } + + +type 'index elt = + | Node of 'index + | Edge of 'index * 'index + | Hyperedge of (dir * Decoration.r * 'index) list +type element = Types.type_expr elt + + +module Elt_map = Map.Make(struct + type t = Index.t elt + let compare = Stdlib.compare + end) +let (.%()) map e = + Option.value ~default:Decoration.none @@ + Elt_map.find_opt e map + +type digraph = { + elts: Decoration.r Elt_map.t; + graph: subgraph +} + +module Pp = struct + + let semi ppf () = fprintf ppf ";@ " + let space ppf () = fprintf ppf "@ " + let empty ppf () = fprintf ppf "" + let string =pp_print_string + let list ~sep = pp_print_list ~pp_sep:sep + let seq ~sep = pp_print_seq ~pp_sep:sep + let rec longident ppf = function + | Longident.Lident s -> fprintf ppf "%s" s + | Longident.Ldot (l,s) -> fprintf ppf "%a.%s" longident l s + | Longident.Lapply(f,x) -> fprintf ppf "%a(%a)" longident f longident x + + let color ppf = function + | Decoration.Named s -> fprintf ppf "%s" s + | Decoration.HSL r -> fprintf ppf "%1.3f %1.3f %1.3f" r.h r.s r.l + + let style ppf = function + | Decoration.Filled _ -> fprintf ppf "filled" + | Decoration.Dash -> fprintf ppf "dashed" + | Decoration.Dotted -> fprintf ppf "dotted" + + let shape ppf = function + | Decoration.Circle -> fprintf ppf "circle" + | Decoration.Diamond -> fprintf ppf "diamond" + | Decoration.Ellipse -> fprintf ppf "ellipse" + + let property ppf = function + | Decoration.Color c -> fprintf ppf {|color="%a"|} color c + | Decoration.Font_color c -> fprintf ppf {|fontcolor="%a"|} color c + | Decoration.Style s -> + fprintf ppf {|style="%a"|} style s; + begin match s with + | Filled (Some c) -> fprintf ppf {|;@ fillcolor="%a"|} color c; + | _ -> () + end; + | Decoration.Shape s -> fprintf ppf {|shape="%a"|} shape s + | Decoration.Label s -> + fprintf ppf {|label=<%a>|} (list ~sep:space string) s + + let inline_decoration ppf r = + match Decoration.decompose r with + | [] -> () + | l -> fprintf ppf "@[%a@]" (list ~sep:semi property) l + + let decoration ppf r = + match Decoration.decompose r with + | [] -> () + | l -> fprintf ppf "[@[%a@]]" (list ~sep:semi property) l + + let row_fixed ppf = function + | None -> fprintf ppf "" + | Some Types.Fixed_private -> fprintf ppf "private" + | Some Types.Rigid -> fprintf ppf "rigid" + | Some Types.Univar _t -> fprintf ppf "univar" + | Some Types.Reified _p -> fprintf ppf "reified" + + let field_kind ppf v = + match Types.field_kind_repr v with + | Fpublic -> fprintf ppf "public" + | Fabsent -> fprintf ppf "absent" + | Fprivate -> fprintf ppf "private" + + let index ppf = function + | Index.Main id -> fprintf ppf "i%d" id + | Index.Synthetic id -> fprintf ppf "s%d" id + | Index.Named_subnode r -> + fprintf ppf "%s%dRF%s" (if r.synth then "s" else "i") r.id r.name + + let prettier_index ppf = function + | Index.Main id -> fprintf ppf "%d" id + | Index.Synthetic id -> fprintf ppf "[%d]" id + | Index.Named_subnode r -> fprintf ppf "%d(%s)" r.id r.name + + let hyperedge_id ppf l = + let sep ppf () = fprintf ppf "h" in + let elt ppf (_,_,x) = index ppf x in + fprintf ppf "h%a" (list ~sep elt) l + + let node graph ppf x = + let d = graph.%(Node x) in + fprintf ppf "%a%a;@ " index x decoration d + + let edge graph ppf (x,y) = + let d = graph.%(Edge (x,y)) in + fprintf ppf "%a->%a%a;@ " index x index y decoration d + + let hyperedge graph ppf l = + let d = graph.%(Hyperedge l) in + fprintf ppf "%a%a;@ " hyperedge_id l decoration d; + List.iter (fun (dir,d,x) -> + match dir with + | From -> + fprintf ppf "%a->%a%a;@ " index x hyperedge_id l decoration d + | Toward -> + fprintf ppf "%a->%a%a;@ " hyperedge_id l index x decoration d + ) l + + let cluster_counter = ref 0 + let pp_cluster ppf = + incr cluster_counter; + fprintf ppf "cluster_%d" !cluster_counter + + let exponent_of_label ppf = function + | Asttypes.Nolabel -> () + | Asttypes.Labelled s -> fprintf ppf "%s" s + | Asttypes.Optional s -> fprintf ppf "?%s" s + + let pretty_var ppf name = + let name = Option.value ~default:"_" name in + let name' = + match name with + | "a" -> "𝛼" + | "b" -> "𝛽" + | "c" -> "𝛾" + | "d" -> "𝛿" + | "e" -> "𝜀" + | "f" -> "𝜑" + | "t" -> "𝜏" + | "r" -> "𝜌" + | "s" -> "𝜎" + | "p" -> "𝜋" + | "i" -> "𝜄" + | "h" -> "𝜂" + | "k" -> "𝜅" + | "l" -> "𝜆" + | "m" -> "𝜇" + | "x" -> "𝜒" + | "n" -> "𝜐" + | "o" -> "𝜔" + | name -> name + in + if name = name' then + fprintf ppf "'%s" name + else pp_print_string ppf name' + + let rec subgraph elts ppf (d,sg) = + fprintf ppf + "@[subgraph %t {@,\ + %a;@ \ + %a%a%a%a}@]@." + pp_cluster + inline_decoration d + (seq ~sep:empty (node elts)) (Node_set.to_seq sg.nodes) + (seq ~sep:empty (edge elts)) (Edge_set.to_seq sg.edges) + (seq ~sep:empty (hyperedge elts)) (Hyperedge_set.to_seq sg.hyperedges) + (list ~sep:empty (subgraph elts)) sg.subgraphes + + let graph ppf {elts;graph} = + fprintf ppf "@[digraph {@,%a%a%a%a}@]@." + (seq ~sep:empty (node elts)) (Node_set.to_seq graph.nodes) + (seq ~sep:empty (edge elts)) (Edge_set.to_seq graph.edges) + (seq ~sep:empty (hyperedge elts)) (Hyperedge_set.to_seq graph.hyperedges) + (list ~sep:empty (subgraph elts)) graph.subgraphes + +end + + +module Digraph = struct + + type t = digraph = { + elts: Decoration.r Elt_map.t; + graph: subgraph + } + + let empty = { elts = Elt_map.empty; graph = empty_subgraph } + + let add_to_subgraph s = function + | Node ty -> + let nodes = Node_set.add ty s.nodes in + { s with nodes } + | Edge (x,y) -> + let edges = Edge_set.add (x,y) s.edges in + { s with edges } + | Hyperedge l -> + let hyperedges = Hyperedge_set.add l s.hyperedges in + { s with hyperedges } + + let add_subgraph sub g = + { g with subgraphes = sub :: g.subgraphes } + + let add ?(override=false) d entry dg = + match Elt_map.find_opt entry dg.elts with + | Some d' -> + let d = + if override then Decoration.merge d d' + else Decoration.merge d' d + in + { dg with elts = Elt_map.add entry d dg.elts } + | None -> + let elts = Elt_map.add entry d dg.elts in + { elts; graph = add_to_subgraph dg.graph entry } + + let rec hyperedges_of_memo ty params id abbrev dg = + match abbrev with + | Types.Mnil -> dg + | Types.Mcons (_priv, _p, t1, t2, rem) -> + let s, dg = ty params t1 dg in + let exp, dg = ty params t2 dg in + dg |> + add memo + (Hyperedge + [From, dotted, id; + Toward, dotted, s; + Toward, Decoration.make [txt "expand"], exp + ]) + |> hyperedges_of_memo ty params id rem + | Types.Mlink rem -> hyperedges_of_memo ty params id !rem dg + + let rec edges_of_memo ty params abbrev dg = + match abbrev with + | Types.Mnil -> dg + | Types.Mcons (_priv, _p, t1, t2, rem) -> + let x, dg = ty params t1 dg in + let y, dg = ty params t2 dg in + dg |> add memo (Edge (x,y)) |> edges_of_memo ty params rem + | Types.Mlink rem -> edges_of_memo ty params !rem dg + + let expansions ty params id memo dg = + if params.expansion_as_hyperedge then + hyperedges_of_memo ty params id memo dg + else + edges_of_memo ty params memo dg + + let labelk k fmt = kasprintf (fun s -> k [txt s]) fmt + let labelf fmt = labelk Fun.id fmt + let labelr fmt = labelk Decoration.make fmt + + let add_node explicit_d color id tynode dg = + let d = labelf "%a" Pp.prettier_index id in + let d = match color with + | None -> Decoration.make d + | Some x -> Decoration.(make (filled x :: d)) + in + let d = Decoration.merge explicit_d d in + add d tynode dg + + let field_node color lbl rf = + let col = match color with + | None -> [] + | Some c -> [Decoration.Color c] + in + let pr_lbl ppf = match lbl with + | None -> () + | Some lbl -> fprintf ppf "`%s" lbl + in + let lbl = + Types.match_row_field + ~absent:(fun _ -> labelf "`-%t" pr_lbl) + ~present:(fun _ -> labelf ">%t" pr_lbl) + ~either:(fun c _tl m _e -> + labelf "%s%t%s" + (if m then "?" else "") + pr_lbl + (if c then "(∅)" else "") + ) + rf + in + Decoration.(make (Shape Diamond::col@lbl)) + + let group ty id0 lbl l dg = + match l with + | [] -> dg + | first :: l -> + let sub = { dg with graph = empty_subgraph } in + let id, sub = ty first sub in + let sub = List.fold_left (fun dg t -> snd (ty t dg)) sub l in + let dg = { sub with graph = add_subgraph (lbl,sub.graph) dg.graph } in + dg |> add std (Edge(id0,id)) + + let split_fresh_typ params ty0 g = + let (id, color, desc) = Index.split params ty0 in + let tynode = Node id in + if Elt_map.mem tynode g then id, None else id, Some (tynode,color,desc) + + let pp_path = Format_doc.compat Path.print + + let rec inject_typ params ty0 dg = + let id, next = split_fresh_typ params ty0 dg.elts in + match next with + | None -> id, dg + | Some (tynode,color,desc) -> + id, node params color id tynode desc dg + and edge params id0 lbl ty gh = + let id, gh = inject_typ params ty gh in + add lbl (Edge(id0,id)) gh + and poly_edge ~color params id0 gh ty = + let id, gh = inject_typ params ty gh in + match color with + | None -> add (labelr "bind") (Edge (id0,id)) gh + | Some c -> + let d = Decoration.(make [txt "bind"; Color c]) in + let gh = add d (Edge (id0,id)) gh in + add ~override:true Decoration.(make [filled c]) (Node id) gh + and numbered_edge params id0 (i,gh) ty = + let l = labelr "%d" i in + i + 1, edge params id0 l ty gh + and numbered_edges params id0 l gh = + snd @@ List.fold_left + (numbered_edge params id0) + (0,gh) l + and node params color id tynode desc dg = + let add_tynode l = add_node l color id tynode dg in + let mk fmt = labelk (fun l -> add_tynode (Decoration.make l)) fmt in + let numbered = numbered_edges params id in + let edge = edge params id in + let std_edge = edge std in + match desc with + | Types.Tvar name -> mk "%a" Pp.pretty_var name + | Types.Tarrow(l,t1,t2,_) -> + mk "→%a" Pp.exponent_of_label l |> numbered [t1; t2] + | Types.Ttuple tl -> + mk "*" |> numbered tl + | Types.Tconstr (p,tl,abbrevs) -> + let constr = mk "%a" pp_path p |> numbered tl in + if not params.follow_expansions then + constr + else + expansions inject_typ params id !abbrevs constr + | Types.Tobject (t, name) -> + let dg = + begin match !name with + | None -> mk "[obj]" + | Some (p,[]) -> (* invalid format *) + mk "[obj(%a)]" pp_path p + | Some (p, (rv_or_nil :: tl)) -> + match Types.get_desc rv_or_nil with + | Tnil -> + mk "[obj(%a)]" pp_path p |> std_edge t |> numbered tl + | _ -> + mk "[obj(#%a)]" pp_path p + |> edge (labelr "row variable") rv_or_nil + |> numbered tl + end + in + begin match split_fresh_typ params t dg.elts with + | _, None -> dg + | next_id, Some (_, color, desc) -> + group_fields ~params ~prev_id:id + dg.elts dg.graph empty_subgraph + ~id:next_id ~color ~desc + end + | Types.Tfield _ -> + group_fields ~params ~prev_id:id + dg.elts dg.graph empty_subgraph + ~color ~id ~desc + | Types.Tnil -> mk "[Nil]" + | Types.Tlink t -> add_tynode Decoration.(make [Style Dash]) |> std_edge t + | Types.Tsubst (t, o) -> + let dg = add_tynode (labelr "[Subst]") |> std_edge t in + begin match o with + | None -> dg + | Some row -> edge (labelr "parent polyvar") row dg + end + | Types.Tunivar name -> + mk "%a∀" Pp.pretty_var name + | Types.Tpoly (t, tl) -> + let dg = mk "∀" |> std_edge t in + List.fold_left (poly_edge ~color params id) dg tl + | Types.Tvariant row -> + let Row {fields; more; name; fixed; closed} = Types.row_repr row in + let closed = if closed then "closed" else "" in + let dg = match name with + | None -> mk "[Row%s]" closed + | Some (p,tl) -> + mk "[Row %a%s]" pp_path p closed + |> numbered tl + in + let more_lbl = labelr "%a row variable" Pp.row_fixed fixed in + let dg = dg |> edge more_lbl more in + let elts, main, fields = + List.fold_left (variant params id) + (dg.elts, dg.graph, empty_subgraph) + fields + in + { elts; graph = add_subgraph (labelr "polyvar", fields) main } + | Types.Tpackage (p, fl) -> + let types = List.map snd fl in + mk "[mod %a with %a]" + pp_path p + Pp.(list ~sep:semi longident) (List.map fst fl) + |> numbered types + and variant params id0 (elts,main,fields) (name,rf) = + let id = Index.subnode ~name id0 in + let fnode = Node id in + let color = Index.colorize params id in + let fgraph = { elts; graph=fields } in + let fgraph = add (field_node color (Some name) rf) fnode fgraph in + let { elts; graph=fields} = add dotted (Edge(id0,id)) fgraph in + let mgraph = { elts; graph=main } in + let {elts; graph=main} = + variant_inside params id rf mgraph + in + elts, main, fields + and variant_inside params id rf dg = + Types.match_row_field + ~absent:(fun () -> dg) + ~present:(function + | None -> dg + | Some arg -> numbered_edges params id [arg] dg + ) + ~either:(fun _ tl _ (cell,e) -> + let dg = match tl with + | [] -> dg + | [x] -> edge params id std x dg + | _ :: _ as tls -> + let label = Decoration.(make [txt "⋀"; filled lightgrey]) in + group (inject_typ params) id label tls dg + in + match e with + | None -> dg + | Some f -> + let id_ext = Index.either_ext cell in + let color = Index.colorize params id_ext in + let dg = add (field_node color None f) (Node id_ext) dg in + let dg = add std (Edge(id,id_ext)) dg in + variant_inside params id_ext f dg + ) + rf + and group_fields ~params ~prev_id elts main fields + ~color ~id ~desc = + let add_tynode dg l = add_node l color id (Node id) dg in + let mk dg fmt = labelk (fun l -> add_tynode dg (Decoration.make l)) fmt in + let merge elts ~main ~fields = + {elts; graph= add_subgraph (labelr "fields", fields) main } + in + match desc with + | Types.Tfield (f, k,typ, next) -> + let fgraph = { elts; graph=fields } in + let fgraph = mk fgraph "%s%a" f Pp.field_kind k in + let {elts; graph=fields} = add dotted (Edge (prev_id,id)) fgraph in + let {elts; graph=main} = + edge params id (labelr "method type") typ + {elts; graph= main} + in + let id_next, next = split_fresh_typ params next elts in + begin match next with + | None -> {elts; graph=main} + | Some (_,color,desc) -> + group_fields ~params ~prev_id:id + elts main fields + ~id:id_next ~desc ~color + end + | Types.Tvar name -> + let dg = mk {elts; graph= fields } "%a" Pp.pretty_var name in + let {elts; graph=fields} = + add (labelr "row variable") (Edge(prev_id,id)) dg + in + merge elts ~main ~fields + | Types.Tnil -> merge elts ~main ~fields + | _ -> + let dg = merge elts ~main ~fields in + node params color id (Node id) desc dg +end + +let params + ?(elide_links=true) + ?(expansion_as_hyperedge=false) + ?(short_ids=true) + ?(colorize=true) + ?(follow_expansions=true) + () = + { + expansion_as_hyperedge; + short_ids; + elide_links; + colorize; + follow_expansions; + } + +let update_params ?elide_links + ?expansion_as_hyperedge + ?short_ids + ?colorize + ?follow_expansions + params = + { + elide_links = Option.value ~default:params.elide_links elide_links; + expansion_as_hyperedge = + Option.value ~default:params.expansion_as_hyperedge + expansion_as_hyperedge; + short_ids = Option.value ~default:params.short_ids short_ids; + colorize = Option.value ~default:params.colorize colorize; + follow_expansions = + Option.value ~default:params.follow_expansions follow_expansions; + } + + +let translate params dg (label,entry) = + let node, dg = match entry with + | Node ty -> + let id, dg = Digraph.inject_typ params ty dg in + Node id, dg + | Edge (ty,ty') -> + let id, dg = Digraph.inject_typ params ty dg in + let id', dg = Digraph.inject_typ params ty' dg in + Edge(id,id'), dg + | Hyperedge l -> + let l, dg = List.fold_left (fun (l,dg) (d,lbl,ty) -> + let id, dg = Digraph.inject_typ params ty dg in + (d,lbl,id)::l, dg + ) ([],dg) l + in + Hyperedge l, dg + in + Digraph.add ~override:true label node dg + +let add params ts dg = + List.fold_left (translate params) dg ts + + +let make params ts = + add params ts Digraph.empty +let pp = Pp.graph + +let add_subgraph params d elts dg = + let sub = add params elts { dg with graph = empty_subgraph } in + { sub with graph = Digraph.add_subgraph (d,sub.graph) dg.graph } + +let group_nodes (decoration, {graph=sub; elts=_}) ({elts;graph=main} as gmain) = + let nodes = Node_set.inter sub.nodes main.nodes in + if Node_set.cardinal nodes > 1 then + let sub = { empty_subgraph with nodes } in + let graph = + { main with + nodes = Node_set.diff main.nodes sub.nodes; + subgraphes = (decoration,sub) :: main.subgraphes + } + in { graph; elts} + else gmain + +let file_counter = ref 0 + +let compact_loc ppf (loc:Warnings.loc) = + let startline = loc.loc_start.pos_lnum in + let endline = loc.loc_end.pos_lnum in + let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in + let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in + if startline = endline then + fprintf ppf "l%d[%d-%d]" startline startchar endchar + else + fprintf ppf "l%d-%d[%d-%d]" startline endline startchar endchar + +type 'a context = 'a option ref * (Format.formatter -> 'a -> unit) + +let set_context (r,_pr) x = r := Some x +let pp_context (r,pr) ppf = match !r with + | None -> () + | Some x -> fprintf ppf "%a" pr x + +let with_context (r,_) x f = + let old = !r in + r:= Some x; + Fun.protect f ~finally:(fun () -> r := old) + +let global = ref None, pp_print_string +let loc = ref None, compact_loc +let context = [pp_context global; pp_context loc] +let dash ppf () = fprintf ppf "-" + +let node_register = ref [] +let register_type (label,ty) = + node_register := (label,Node ty) :: !node_register + +let subgraph_register = ref [] +let default_style = Decoration.(make [filled lightgrey]) +let register_subgraph params ?(decoration=default_style) tys = + let node x = Decoration.none, Node x in + let subgraph = make params (List.map node tys) in + subgraph_register := (decoration, subgraph) :: !subgraph_register + +let forget () = + node_register := []; + subgraph_register := [] + +let node x = Node x +let edge x y = Edge(x,y) +let hyperedge l = Hyperedge l + +let nodes ~title params ts = + incr file_counter; + let filename = + match !Clflags.dump_dir with + | None -> asprintf "%04d-%s.dot" !file_counter title + | Some d -> + asprintf "%s%s%04d-%s-%a.dot" + d Filename.dir_sep + !file_counter + title + Pp.(list ~sep:dash (fun ppf pr -> pr ppf)) context + in + Out_channel.with_open_bin filename (fun ch -> + let ppf = Format.formatter_of_out_channel ch in + let ts = List.map (fun (l,t) -> l, t) ts in + let g = make params (ts @ !node_register) in + let g = + List.fold_left (fun g sub -> group_nodes sub g) g !subgraph_register + in + Pp.graph ppf g + ) + +let types ~title params ts = + nodes ~title params (List.map (fun (lbl,ty) -> lbl, Node ty) ts) + +let make params elts = make params elts +let add params elts = add params elts + + +(** Debugging hooks *) +let debug_on = ref (fun () -> false) +let debug f = if !debug_on () then f () + +let debug_off f = + let old = !debug_on in + debug_on := Fun.const false; + Fun.protect f + ~finally:(fun () -> debug_on := old) diff --git a/upstream/ocaml_503/typing/gprinttyp.mli b/upstream/ocaml_503/typing/gprinttyp.mli new file mode 100644 index 000000000..1feef0c2c --- /dev/null +++ b/upstream/ocaml_503/typing/gprinttyp.mli @@ -0,0 +1,325 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) +(** + This module provides function for printing type expressions as digraph using + graphviz format. This is mostly aimed at providing a better representation + of type expressions during debugging session. +*) +(** +A type node is printed as +{[ + .------------. + | id |----> + | |---> + .------------. +]} +where the description part might be: +- a path: [list/8!] +- a type variable: ['name], [α], [β], [γ] +- [*] for tuples +- [→] for arrows type +- an universal type variable: [[β]∀], ['name ∀], ... +- [[mod X with ...]] for a first class module + +- [∀] for a universal type binder + +The more complex encoding for polymorphic variants and object types uses nodes +as head of the subgraph representing those types + +- [[obj...]] for the head of an object subgraph +- [[Nil]] for the end of an object subgraph +- [[Row...]] for the head of a polymorphic variant subgraph + +- [[Subst]] for a temporary substitution node + +Then each nodes is relied by arrows to any of its children types. + +- Type variables, universal type variables, [Nil], and [Subst] nodes don't have + children. + +- For tuples, the children types are the elements of the tuple. For instance, + [int * float] is represented as +{[ + .------. 0 .-------. + | * 1 |-------->| int! 2| + .------. .-------. + | + | 1 + v + .----------. + | float! 3 | + .----------. +]} + +- For arrows, the children types are the type of the argument and the result + type. For instance, for [int -> float]: +{[ + .------. 0 .-------. + | → 4 |-------->| int! 2| + .------. .-------. + | + | 1 + v + .----------. + | float! 3 | + .----------. +]} + +- For type constructor, like list the main children nodes are the argument + types. For instance, [(int,float) result] is represented as: + +{[ + .-------------. 0 .-------. + | Result.t 5 |-------->| int! 2| + .-------------. .-------. + | + | 1 + v + .----------. + | float! 3 | + .----------. +]} + +Moreover, type abbreviations might be linked to the expanded nodes. +If I define: [type 'a pair = 'a * 'a], a type expression [int pair] might +correspond to the nodes: + +{[ + .--------. 0 .--------. + | pair 6 |------> | int! 2 | + .--------. .--------. + ┆ ^ + ┆ expand | + ┆ | + .------. 0 + 1 | + | * 7 |------>-------. + .------. +]} + +- Universal type binders have two kind of children: bound variables, + and the main body. For instance, ['a. 'a -> 'a] is represented as +{[ + + .------. bind .-------. + | ∀ 8 |----------> | 𝛼 10 | + .------. .------. + | ^ + | | + v | + .------. 0 + 1 | + | → 9 |------>-------. + .------. + +]} + +- [[Subst]] node are children are the type graph guarded by the + substitution node, and an eventual link to the parent row variable. + +- The children of first-class modules are the type expressions that may appear + in the right hand side of constraints. + For instance, [module M with type t = 'a and type u = 'b] is represented as +{[ + .----------------------. 0 .-----. + | [mod M with t, u] 11 |-------->| 𝛼 12| + .----------------------. .----- + | + | 1 + v + .------. + | 𝛽 13 | + .------. +]} + + +- The children of [obj] (resp. [row]) are the methods (resp. constructor) of the + object type (resp. polymorphic variant). Each method is then linked to its + type. To make them easier to read they are grouped inside graphviz cluster. + For instance, [ as 'self] will be represented as: + +{[ + + .----------------. + | .----------. | + | | [obj] 14 |<------<-----<-----. + | .----------. | | + | ┆ | | + | .-------------. | .------. | .-------. + | | a public 15 |----->| ∀ 18 |----->| int! 2 | + | .-------------. | .------. | .-------. + | ┆ | | + | .-------------. | .------. | + | | m public 16 |-----| ∀ 19 |>--| + | .------------. | .------. + | ┆ | + | ┆ row var | + | ┆ | + | .-------. | + | | '_ 17 | | + | .-------. | + .-----------------. + +]} +*) + +type digraph +(** Digraph with nodes, edges, hyperedges and subgraphes *) + +type params +(** Various possible choices on how to represent types, see the {!params} + functions for more detail.*) + +type element +(** Graph element, see the {!node}, {!edge} and {!hyperedge} function *) + +type decoration +(** Visual decoration on graph elements, see the {!Decoration} module.*) + + +val types: title:string -> params -> (decoration * Types.type_expr) list -> unit +(** Print a graph to the file + [asprintf "%s/%04d-%s-%a.dot" + dump_dir + session_unique_id + title + pp_context context + ] + + If the [dump_dir] flag is not set, the local directory is used. + See the {!context} type on how and why to setup the context. *) + +(** Full version of {!types} that allow to print any kind of graph element *) +val nodes: title:string -> params -> (decoration * element) list -> unit + +val params: + ?elide_links:bool -> + ?expansion_as_hyperedge:bool -> + ?short_ids:bool -> + ?colorize:bool -> + ?follow_expansions:bool -> + unit -> params +(** Choice of details for printing type graphes: + - if [elide_links] is [true] link nodes are not displayed (default:[true]) + - with [expansion_as_hyperedge], memoized constructor expansion are + displayed as a hyperedge between the node storing the memoized expansion, + the expanded node and the expansion (default:[false]). + - with [short_ids], we use an independent counter for node ids, in order to + have shorter ids for small digraphs (default:[true]). + - with [colorize] nodes are colorized according to their typechecker ids + (default:[true]). + - with [follow_expansions], we add memoized type constructor expansions to + the digraph (default:[true]). +*) + +(** Update an existing [params] with new values. *) +val update_params: + ?elide_links:bool -> + ?expansion_as_hyperedge:bool -> + ?short_ids:bool -> + ?colorize:bool -> + ?follow_expansions:bool -> + params -> params + +val node: Types.type_expr -> element +val edge: Types.type_expr -> Types.type_expr -> element + +type dir = Toward | From +val hyperedge: (dir * decoration * Types.type_expr) list -> element +(** Edges between more than two elements. *) + +(** {1 Node and decoration types} *) +module Decoration: sig + type color = + | Named of string + | HSL of {h:float;s:float;l:float} + + val green: color + val blue: color + val red:color + val purple:color + val hsl: h:float -> s:float -> l:float -> color + + type style = + | Filled of color option + | Dotted + | Dash + + type shape = + | Ellipse + | Circle + | Diamond + + type property = + | Color of color + | Font_color of color + | Style of style + | Label of string list + | Shape of shape + val filled: color -> property + val txt: string -> property + val make: property list -> decoration +end + +(** {1 Digraph construction and printing}*) + +val make: params -> (decoration * element) list -> digraph +val add: params -> (decoration * element) list -> digraph -> digraph + +(** add a subgraph to a digraph, only fresh nodes are added to the subgraph *) +val add_subgraph: + params -> decoration -> (decoration * element) list -> digraph -> digraph + +(** groups existing nodes inside a subgraph *) +val group_nodes: decoration * digraph -> digraph -> digraph + +val pp: Format.formatter -> digraph -> unit + + +(** {1 Debugging helper functions } *) + +(** {2 Generic print debugging function} *) + +(** Conditional graph printing *) +val debug_on: (unit -> bool) ref + +(** [debug_off f] switches off debugging before running [f]. *) +val debug_off: (unit -> 'a) -> 'a + +(** [debug f] runs [f] when [!debug_on ()]*) +val debug: (unit -> unit) -> unit + +(** {2 Node tracking functions }*) + +(** [register_type (lbl,ty)] adds the type [t] to all graph printed until + {!forget} is called *) +val register_type: decoration * Types.type_expr -> unit + +(** [register_subgraph params tys] groups together all types reachable from + [tys] at this point in printed digraphs, until {!forget} is called *) +val register_subgraph: + params -> ?decoration:decoration -> Types.type_expr list -> unit + +(** Forget all recorded context types *) +val forget : unit -> unit + +(** {2 Contextual information} + + Those functions can be used to modify the filename of the generated digraphs. + Use those functions to provide contextual information on a graph emitted + during an execution trace.*) +type 'a context +val global: string context +val loc: Warnings.loc context +val set_context: 'a context -> 'a -> unit +val with_context: 'a context -> 'a -> (unit -> 'b) -> 'b diff --git a/upstream/ocaml_503/typing/ident.ml b/upstream/ocaml_503/typing/ident.ml new file mode 100644 index 000000000..9a736abed --- /dev/null +++ b/upstream/ocaml_503/typing/ident.ml @@ -0,0 +1,392 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Local_store + +let lowest_scope = 0 +let highest_scope = 100_000_000 + (* assumed to fit in 27 bits, see Types.scope_field *) + +type t = + | Local of { name: string; stamp: int } + | Scoped of { name: string; stamp: int; scope: int } + | Global of string + | Predef of { name: string; stamp: int } + (* the stamp is here only for fast comparison, but the name of + predefined identifiers is always unique. *) + +(* A stamp of 0 denotes a persistent identifier *) + +let currentstamp = s_ref 0 +let predefstamp = s_ref 0 + +let create_scoped ~scope s = + incr currentstamp; + Scoped { name = s; stamp = !currentstamp; scope } + +let create_local s = + incr currentstamp; + Local { name = s; stamp = !currentstamp } + +let create_predef s = + incr predefstamp; + Predef { name = s; stamp = !predefstamp } + +let create_persistent s = + Global s + +let name = function + | Local { name; _ } + | Scoped { name; _ } + | Global name + | Predef { name; _ } -> name + +let rename = function + | Local { name; stamp = _ } + | Scoped { name; stamp = _; scope = _ } -> + incr currentstamp; + Local { name; stamp = !currentstamp } + | id -> + Misc.fatal_errorf "Ident.rename %s" (name id) + +let unique_name = function + | Local { name; stamp } + | Scoped { name; stamp } -> name ^ "_" ^ Int.to_string stamp + | Global name -> + (* we're adding a fake stamp, because someone could have named his unit + [Foo_123] and since we're using unique_name to produce symbol names, + we might clash with an ident [Local { "Foo"; 123 }]. *) + name ^ "_0" + | Predef { name; _ } -> + (* we know that none of the predef names (currently) finishes in + "_", and that their name is unique. *) + name + +let unique_toplevel_name = function + | Local { name; stamp } + | Scoped { name; stamp } -> name ^ "/" ^ Int.to_string stamp + | Global name + | Predef { name; _ } -> name + +let persistent = function + | Global _ -> true + | _ -> false + +let equal i1 i2 = + match i1, i2 with + | Local { name = name1; _ }, Local { name = name2; _ } + | Scoped { name = name1; _ }, Scoped { name = name2; _ } + | Global name1, Global name2 -> + name1 = name2 + | Predef { stamp = s1; _ }, Predef { stamp = s2 } -> + (* if they don't have the same stamp, they don't have the same name *) + s1 = s2 + | _ -> + false + +let same i1 i2 = + match i1, i2 with + | Local { stamp = s1; _ }, Local { stamp = s2; _ } + | Scoped { stamp = s1; _ }, Scoped { stamp = s2; _ } + | Predef { stamp = s1; _ }, Predef { stamp = s2 } -> + s1 = s2 + | Global name1, Global name2 -> + name1 = name2 + | _ -> + false + +let stamp = function + | Local { stamp; _ } + | Scoped { stamp; _ } -> stamp + | _ -> 0 + +let compare_stamp id1 id2 = + compare (stamp id1) (stamp id2) + +let scope = function + | Scoped { scope; _ } -> scope + | Local _ -> highest_scope + | Global _ | Predef _ -> lowest_scope + +let reinit_level = ref (-1) + +let reinit () = + if !reinit_level < 0 + then reinit_level := !currentstamp + else currentstamp := !reinit_level + +let global = function + | Local _ + | Scoped _ -> false + | Global _ + | Predef _ -> true + +let is_predef = function + | Predef _ -> true + | _ -> false + +let print ~with_scope ppf = + let open Format_doc in + function + | Global name -> fprintf ppf "%s!" name + | Predef { name; stamp = n } -> + fprintf ppf "%s%s!" name + (if !Clflags.unique_ids then asprintf "/%i" n else "") + | Local { name; stamp = n } -> + fprintf ppf "%s%s" name + (if !Clflags.unique_ids then asprintf "/%i" n else "") + | Scoped { name; stamp = n; scope } -> + fprintf ppf "%s%s%s" name + (if !Clflags.unique_ids then asprintf "/%i" n else "") + (if with_scope then asprintf "[%i]" scope else "") + +let print_with_scope ppf id = print ~with_scope:true ppf id + +let doc_print ppf id = print ~with_scope:false ppf id +let print ppf id = Format_doc.compat doc_print ppf id +(* For the documentation of ['a Ident.tbl], see ident.mli. + + The implementation is a copy-paste specialization of + a balanced-tree implementation similar to Map. + ['a tbl] + is a slightly more compact version of + [(Ident.t * 'a) list Map.Make(String)] + + This implementation comes from Caml Light where duplication was + unavoidable in absence of functors. It works well enough, and so + far we have not had strong incentives to do the deduplication work + (implementation, tests, benchmarks, etc.). +*) +type 'a tbl = + Empty + | Node of 'a tbl * 'a data * 'a tbl * int + +and 'a data = + { ident: t; + data: 'a; + previous: 'a data option } + +let empty = Empty + +(* Inline expansion of height for better speed + * let height = function + * Empty -> 0 + * | Node(_,_,_,h) -> h + *) + +let mknode l d r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h + and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1)) + +let balance l d r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h + and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + if hl > hr + 1 then + match l with + | Node (ll, ld, lr, _) + when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >= + (match lr with Empty -> 0 | Node(_,_,_,h) -> h) -> + mknode ll ld (mknode lr d r) + | Node (ll, ld, Node(lrl, lrd, lrr, _), _) -> + mknode (mknode ll ld lrl) lrd (mknode lrr d r) + | _ -> assert false + else if hr > hl + 1 then + match r with + | Node (rl, rd, rr, _) + when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >= + (match rl with Empty -> 0 | Node(_,_,_,h) -> h) -> + mknode (mknode l d rl) rd rr + | Node (Node (rll, rld, rlr, _), rd, rr, _) -> + mknode (mknode l d rll) rld (mknode rlr rd rr) + | _ -> assert false + else + mknode l d r + +let rec add id data = function + Empty -> + Node(Empty, {ident = id; data = data; previous = None}, Empty, 1) + | Node(l, k, r, h) -> + let c = String.compare (name id) (name k.ident) in + if c = 0 then + Node(l, {ident = id; data = data; previous = Some k}, r, h) + else if c < 0 then + balance (add id data l) k r + else + balance l k (add id data r) + +let rec min_binding = function + Empty -> raise Not_found + | Node (Empty, d, _, _) -> d + | Node (l, _, _, _) -> min_binding l + +let rec remove_min_binding = function + Empty -> invalid_arg "Map.remove_min_elt" + | Node (Empty, _, r, _) -> r + | Node (l, d, r, _) -> balance (remove_min_binding l) d r + +let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let d = min_binding t2 in + balance t1 d (remove_min_binding t2) + +let rec remove id = function + Empty -> + Empty + | (Node (l, k, r, h) as m) -> + let c = String.compare (name id) (name k.ident) in + if c = 0 then + match k.previous with + | None -> merge l r + | Some k -> Node (l, k, r, h) + else if c < 0 then + let ll = remove id l in if l == ll then m else balance ll k r + else + let rr = remove id r in if r == rr then m else balance l k rr + +let rec find_previous id = function + None -> + raise Not_found + | Some k -> + if same id k.ident then k.data else find_previous id k.previous + +let rec find_same id = function + Empty -> + raise Not_found + | Node(l, k, r, _) -> + let c = String.compare (name id) (name k.ident) in + if c = 0 then + if same id k.ident + then k.data + else find_previous id k.previous + else + find_same id (if c < 0 then l else r) + +let rec find_name n = function + Empty -> + raise Not_found + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + k.ident, k.data + else + find_name n (if c < 0 then l else r) + +let rec get_all = function + | None -> [] + | Some k -> (k.ident, k.data) :: get_all k.previous + +let rec find_all n = function + Empty -> + [] + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + (k.ident, k.data) :: get_all k.previous + else + find_all n (if c < 0 then l else r) + +let get_all_seq k () = + Seq.unfold (Option.map (fun k -> (k.ident, k.data), k.previous)) + k () + +let rec find_all_seq n tbl () = + match tbl with + | Empty -> Seq.Nil + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + Seq.Cons((k.ident, k.data), get_all_seq k.previous) + else + find_all_seq n (if c < 0 then l else r) () + + +let rec fold_aux f stack accu = function + Empty -> + begin match stack with + [] -> accu + | a :: l -> fold_aux f l accu a + end + | Node(l, k, r, _) -> + fold_aux f (l :: stack) (f k accu) r + +let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl + +let rec fold_data f d accu = + match d with + None -> accu + | Some k -> f k.ident k.data (fold_data f k.previous accu) + +let fold_all f tbl accu = + fold_aux (fun k -> fold_data f (Some k)) [] accu tbl + +(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *) + +let rec iter f = function + Empty -> () + | Node(l, k, r, _) -> + iter f l; f k.ident k.data; iter f r + +(* Idents for sharing keys *) + +(* They should be 'totally fresh' -> neg numbers *) +let key_name = "" + +let make_key_generator () = + let c = ref 1 in + function + | Local _ + | Scoped _ -> + let stamp = !c in + decr c ; + Local { name = key_name; stamp = stamp } + | global_id -> + Misc.fatal_errorf "Ident.make_key_generator () %s" (name global_id) + +let compare x y = + match x, y with + | Local x, Local y -> + let c = x.stamp - y.stamp in + if c <> 0 then c + else compare x.name y.name + | Local _, _ -> 1 + | _, Local _ -> (-1) + | Scoped x, Scoped y -> + let c = x.stamp - y.stamp in + if c <> 0 then c + else compare x.name y.name + | Scoped _, _ -> 1 + | _, Scoped _ -> (-1) + | Global x, Global y -> compare x y + | Global _, _ -> 1 + | _, Global _ -> (-1) + | Predef { stamp = s1; _ }, Predef { stamp = s2; _ } -> compare s1 s2 + +let output oc id = output_string oc (unique_name id) +let hash i = (Char.code (name i).[0]) lxor (stamp i) + +let original_equal = equal +include Identifiable.Make (struct + type nonrec t = t + let compare = compare + let output = output + let print = print + let hash = hash + let equal = same +end) +let equal = original_equal diff --git a/upstream/ocaml_503/typing/ident.mli b/upstream/ocaml_503/typing/ident.mli new file mode 100644 index 000000000..588123242 --- /dev/null +++ b/upstream/ocaml_503/typing/ident.mli @@ -0,0 +1,115 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Identifiers (unique names) *) + +type t + +include Identifiable.S with type t := t +(* Notes: + - [equal] compares identifiers by name + - [compare x y] is 0 if [same x y] is true. + - [compare] compares identifiers by binding location +*) + +val doc_print: t Format_doc.printer +val print_with_scope : t Format_doc.printer + (** Same as {!print} except that it will also add a "[n]" suffix + if the scope of the argument is [n]. *) + + +val create_scoped: scope:int -> string -> t +val create_local: string -> t +val create_persistent: string -> t +val create_predef: string -> t + +val rename: t -> t + (** Creates an identifier with the same name as the input, a fresh + stamp, and no scope. + @raise [Fatal_error] if called on a persistent / predef ident. *) + +val name: t -> string +val unique_name: t -> string +val unique_toplevel_name: t -> string +val persistent: t -> bool +val same: t -> t -> bool + (** Compare identifiers by binding location. + Two identifiers are the same either if they are both + non-persistent and have been created by the same call to + [create_*], or if they are both persistent and have the same + name. *) + +val compare_stamp: t -> t -> int + (** Compare only the internal stamps, 0 if absent *) + +val compare: t -> t -> int + (** Compare identifiers structurally, including the name *) + +val global: t -> bool +val is_predef: t -> bool + +val scope: t -> int + +val lowest_scope : int +val highest_scope: int + +val reinit: unit -> unit + +type 'a tbl +(** ['a tbl] represents association tables from identifiers to values + of type ['a]. + + ['a tbl] plays the role of map, but bindings can be looked up + from either the full Ident using [find_same], or just its + user-visible name using [find_name]. In general the two lookups may + not return the same result, as an identifier may have been shadowed + in the environment by a distinct identifier with the same name. + + [find_all] returns the bindings for all idents of a given name, + most recently introduced first. + + In other words, + ['a tbl] + corresponds to + [(Ident.t * 'a) list Map.Make(String)] + and the implementation is very close to that representation. + + Note in particular that searching among idents of the same name + takes linear time, and that [add] simply extends the list without + checking for duplicates. So it is not a good idea to implement + union by repeated [add] calls, which may result in many duplicated + identifiers and poor [find_same] performance. It is even possible + to build overly large same-name lists such that non-recursive + functions like [find_all] or [fold_all] blow the stack. + + You should probably use [Map.Make(Ident)] instead, unless you + really need to query bindings by user-visible name, not just by + unique identifiers. +*) + +val empty: 'a tbl +val add: t -> 'a -> 'a tbl -> 'a tbl +val find_same: t -> 'a tbl -> 'a +val find_name: string -> 'a tbl -> t * 'a +val find_all: string -> 'a tbl -> (t * 'a) list +val find_all_seq: string -> 'a tbl -> (t * 'a) Seq.t +val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val iter: (t -> 'a -> unit) -> 'a tbl -> unit +val remove: t -> 'a tbl -> 'a tbl + +(* Idents for sharing keys *) + +val make_key_generator : unit -> (t -> t) diff --git a/upstream/ocaml_503/typing/includeclass.ml b/upstream/ocaml_503/typing/includeclass.ml new file mode 100644 index 000000000..dfdc686ad --- /dev/null +++ b/upstream/ocaml_503/typing/includeclass.ml @@ -0,0 +1,114 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the class language *) + +open Types + +let class_types env cty1 cty2 = + Ctype.match_class_types env cty1 cty2 + +let class_type_declarations ~loc env cty1 cty2 = + Builtin_attributes.check_alerts_inclusion + ~def:cty1.clty_loc + ~use:cty2.clty_loc + loc + cty1.clty_attributes cty2.clty_attributes + (Path.last cty1.clty_path); + Ctype.match_class_declarations env + cty1.clty_params cty1.clty_type + cty2.clty_params cty2.clty_type + +let class_declarations env cty1 cty2 = + match cty1.cty_new, cty2.cty_new with + None, Some _ -> + [Ctype.CM_Virtual_class] + | _ -> + Ctype.match_class_declarations env + cty1.cty_params cty1.cty_type + cty2.cty_params cty2.cty_type + +open Format_doc +open Ctype +module Printtyp=Printtyp.Doc + +(* +let rec hide_params = function + Tcty_arrow ("*", _, cty) -> hide_params cty + | cty -> cty +*) + +let include_err mode ppf = + let msg fmt = Format_doc.Doc.msg fmt in + function + | CM_Virtual_class -> + fprintf ppf "A class cannot be changed from virtual to concrete" + | CM_Parameter_arity_mismatch _ -> + fprintf ppf + "The classes do not have the same number of type parameters" + | CM_Type_parameter_mismatch (n, env, err) -> + Errortrace_report.equality ppf mode env err + (msg "The %d%s type parameter has type" + n (Misc.ordinal_suffix n)) + (msg "but is expected to have type") + | CM_Class_type_mismatch (env, cty1, cty2) -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + fprintf ppf + "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]" + Printtyp.class_type cty1 + "is not matched by the class type" + Printtyp.class_type cty2) + | CM_Parameter_mismatch (n, env, err) -> + Errortrace_report.moregen ppf mode env err + (msg "The %d%s parameter has type" + n (Misc.ordinal_suffix n)) + (msg "but is expected to have type") + | CM_Val_type_mismatch (lab, env, err) -> + Errortrace_report.comparison ppf mode env err + (msg "The instance variable %s@ has type" lab) + (msg "but is expected to have type") + | CM_Meth_type_mismatch (lab, env, err) -> + Errortrace_report.comparison ppf mode env err + (msg "The method %s@ has type" lab) + (msg "but is expected to have type") + | CM_Non_mutable_value lab -> + fprintf ppf + "@[The non-mutable instance variable %s cannot become mutable@]" lab + | CM_Non_concrete_value lab -> + fprintf ppf + "@[The virtual instance variable %s cannot become concrete@]" lab + | CM_Missing_value lab -> + fprintf ppf "@[The first class type has no instance variable %s@]" lab + | CM_Missing_method lab -> + fprintf ppf "@[The first class type has no method %s@]" lab + | CM_Hide_public lab -> + fprintf ppf "@[The public method %s cannot be hidden@]" lab + | CM_Hide_virtual (k, lab) -> + fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab + | CM_Public_method lab -> + fprintf ppf "@[The public method %s cannot become private@]" lab + | CM_Virtual_method lab -> + fprintf ppf "@[The virtual method %s cannot become concrete@]" lab + | CM_Private_method lab -> + fprintf ppf "@[The private method %s cannot become public@]" lab + +let report_error_doc mode ppf = function + | [] -> () + | err :: errs -> + let print_errs ppf errs = + List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in + fprintf ppf "@[%a%a@]" (include_err mode) err print_errs errs + +let report_error mode = Format_doc.compat (report_error_doc mode) diff --git a/upstream/ocaml_503/typing/includeclass.mli b/upstream/ocaml_503/typing/includeclass.mli new file mode 100644 index 000000000..a4d4d8588 --- /dev/null +++ b/upstream/ocaml_503/typing/includeclass.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the class language *) + +open Types +open Ctype + +val class_types: + Env.t -> class_type -> class_type -> class_match_failure list +val class_type_declarations: + loc:Location.t -> + Env.t -> class_type_declaration -> class_type_declaration -> + class_match_failure list +val class_declarations: + Env.t -> class_declaration -> class_declaration -> + class_match_failure list + +val report_error : + Out_type.type_or_scheme -> class_match_failure list Format_doc.format_printer +val report_error_doc : + Out_type.type_or_scheme -> class_match_failure list Format_doc.printer diff --git a/upstream/ocaml_503/typing/includecore.ml b/upstream/ocaml_503/typing/includecore.ml new file mode 100644 index 000000000..e23315f1e --- /dev/null +++ b/upstream/ocaml_503/typing/includecore.ml @@ -0,0 +1,1074 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the core language *) + +open Asttypes +open Path +open Types +open Typedtree + +type position = Errortrace.position = First | Second + +(* Inclusion between value descriptions *) + +type primitive_mismatch = + | Name + | Arity + | No_alloc of position + | Native_name + | Result_repr + | Argument_repr of int + +let native_repr_args nra1 nra2 = + let rec loop i nra1 nra2 = + match nra1, nra2 with + | [], [] -> None + | [], _ :: _ -> assert false + | _ :: _, [] -> assert false + | nr1 :: nra1, nr2 :: nra2 -> + if not (Primitive.equal_native_repr nr1 nr2) then Some (Argument_repr i) + else loop (i+1) nra1 nra2 + in + loop 1 nra1 nra2 + +let primitive_descriptions pd1 pd2 = + let open Primitive in + if not (String.equal pd1.prim_name pd2.prim_name) then + Some Name + else if not (Int.equal pd1.prim_arity pd2.prim_arity) then + Some Arity + else if (not pd1.prim_alloc) && pd2.prim_alloc then + Some (No_alloc First) + else if pd1.prim_alloc && (not pd2.prim_alloc) then + Some (No_alloc Second) + else if not (String.equal pd1.prim_native_name pd2.prim_native_name) then + Some Native_name + else if not + (Primitive.equal_native_repr + pd1.prim_native_repr_res pd2.prim_native_repr_res) then + Some Result_repr + else + native_repr_args pd1.prim_native_repr_args pd2.prim_native_repr_args + +type value_mismatch = + | Primitive_mismatch of primitive_mismatch + | Not_a_primitive + | Type of Errortrace.moregen_error + +exception Dont_match of value_mismatch + +(* A value description [vd1] is consistent with the value description [vd2] if + there is a context E such that [E |- vd1 <: vd2] for the ordinary subtyping. + For values, this is the case as soon as the kind of [vd1] is a subkind of the + [vd2] kind. *) +let value_descriptions_consistency env vd1 vd2 = + match (vd1.val_kind, vd2.val_kind) with + | (Val_prim p1, Val_prim p2) -> begin + match primitive_descriptions p1 p2 with + | None -> Tcoerce_none + | Some err -> raise (Dont_match (Primitive_mismatch err)) + end + | (Val_prim p, _) -> + let pc = + { pc_desc = p; pc_type = vd2.Types.val_type; + pc_env = env; pc_loc = vd1.Types.val_loc; } + in + Tcoerce_primitive pc + | (_, Val_prim _) -> raise (Dont_match Not_a_primitive) + | (_, _) -> Tcoerce_none + +let value_descriptions ~loc env name + (vd1 : Types.value_description) + (vd2 : Types.value_description) = + Builtin_attributes.check_alerts_inclusion + ~def:vd1.val_loc + ~use:vd2.val_loc + loc + vd1.val_attributes vd2.val_attributes + name; + match Ctype.moregeneral env true vd1.val_type vd2.val_type with + | exception Ctype.Moregen err -> raise (Dont_match (Type err)) + | () -> value_descriptions_consistency env vd1 vd2 + +(* Inclusion between manifest types (particularly for private row types) *) + +let is_absrow env ty = + match get_desc ty with + | Tconstr(Pident _, _, _) -> + (* This function is checking for an abstract row on the side that is being + included into (usually numbered with "2" in this file). In this case, + the abstract row variable has been substituted for an object or variant + type. *) + begin match get_desc (Ctype.expand_head env ty) with + | Tobject _|Tvariant _ -> true + | _ -> false + end + | _ -> false + +(* Inclusion between type declarations *) + +let choose ord first second = + match ord with + | First -> first + | Second -> second + +let choose_other ord first second = + match ord with + | First -> choose Second first second + | Second -> choose First first second + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +let of_kind = function + | Type_abstract _ -> Kind_abstract + | Type_record (_, _) -> Kind_record + | Type_variant (_, _) -> Kind_variant + | Type_open -> Kind_open + +type kind_mismatch = type_kind * type_kind + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration, Types.label_declaration, label_mismatch) + Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * Types.extension_constructor + * Types.extension_constructor + * constructor_mismatch + +type private_variant_mismatch = + | Only_outer_closed (* It's only dangerous in one direction *) + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type variant_change = + (Types.constructor_declaration as 'l, 'l, constructor_mismatch) + Diffing_with_keys.change + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind of kind_mismatch + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | Private_variant of type_expr * type_expr * private_variant_mismatch + | Private_object of type_expr * type_expr * private_object_mismatch + | Variance + | Record_mismatch of record_mismatch + | Variant_mismatch of variant_change list + | Unboxed_representation of position + | Immediate of Type_immediacy.Violation.t + +module Style = Misc.Style +module Fmt = Format_doc +module Printtyp = Printtyp.Doc + +let report_primitive_mismatch first second ppf err = + let pr fmt = Fmt.fprintf ppf fmt in + match (err : primitive_mismatch) with + | Name -> + pr "The names of the primitives are not the same" + | Arity -> + pr "The syntactic arities of these primitives were not the same.@ \ + (They must have the same number of arrows present in the source.)" + | No_alloc ord -> + pr "%s primitive is %a but %s is not" + (String.capitalize_ascii (choose ord first second)) + Style.inline_code "[@@noalloc]" + (choose_other ord first second) + | Native_name -> + pr "The native names of the primitives are not the same" + | Result_repr -> + pr "The two primitives' results have different representations" + | Argument_repr n -> + pr "The two primitives' %d%s arguments have different representations" + n (Misc.ordinal_suffix n) + +let report_value_mismatch first second env ppf err = + let pr fmt = Fmt.fprintf ppf fmt in + pr "@ "; + match (err : value_mismatch) with + | Primitive_mismatch pm -> + report_primitive_mismatch first second ppf pm + | Not_a_primitive -> + pr "The implementation is not a primitive." + | Type trace -> + let msg = Fmt.Doc.msg in + Errortrace_report.moregen ppf Type_scheme env trace + (msg "The type") + (msg "is not compatible with the type") + +let report_type_inequality env ppf err = + let msg = Fmt.Doc.msg in + Errortrace_report.equality ppf Type_scheme env err + (msg "The type") + (msg "is not equal to the type") + +let report_privacy_mismatch ppf err = + let singular, item = + match err with + | Private_type_abbreviation -> true, "type abbreviation" + | Private_variant_type -> false, "variant constructor(s)" + | Private_record_type -> true, "record constructor" + | Private_extensible_variant -> true, "extensible variant" + | Private_row_type -> true, "row type" + in Format_doc.fprintf ppf "%s %s would be revealed." + (if singular then "A private" else "Private") + item + +let report_label_mismatch first second env ppf err = + match (err : label_mismatch) with + | Type err -> + report_type_inequality env ppf err + | Mutability ord -> + Format_doc.fprintf ppf "%s is mutable and %s is not." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + +let pp_record_diff first second prefix decl env ppf (x : record_change) = + match x with + | Delete cd -> + Fmt.fprintf ppf "%aAn extra field, %a, is provided in %s %s." + prefix x Style.inline_code (Ident.name cd.delete.ld_id) first decl + | Insert cd -> + Fmt.fprintf ppf "%aA field, %a, is missing in %s %s." + prefix x Style.inline_code (Ident.name cd.insert.ld_id) first decl + | Change Type {got=lbl1; expected=lbl2; reason} -> + Fmt.fprintf ppf + "@[%aFields do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + (Style.as_inline_code Printtyp.label) lbl1 + (Style.as_inline_code Printtyp.label) lbl2 + (report_label_mismatch first second env) reason + | Change Name n -> + Fmt.fprintf ppf "%aFields have different names, %a and %a." + prefix x + Style.inline_code n.got + Style.inline_code n.expected + | Swap sw -> + Fmt.fprintf ppf "%aFields %a and %a have been swapped." + prefix x + Style.inline_code sw.first + Style.inline_code sw.last + | Move {name; got; expected } -> + Fmt.fprintf ppf + "@[<2>%aField %a has been moved@ from@ position %d@ to %d.@]" + prefix x Style.inline_code name expected got + +let report_patch pr_diff first second decl env ppf patch = + let nl ppf () = Fmt.fprintf ppf "@," in + let no_prefix _ppf _ = () in + match patch with + | [ elt ] -> + Fmt.fprintf ppf "@[%a@]" + (pr_diff first second no_prefix decl env) elt + | _ -> + let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in + Fmt.fprintf ppf "@[%a@]" + (Fmt.pp_print_list ~pp_sep:nl pp_diff) patch + +let report_record_mismatch first second decl env ppf err = + let pr fmt = Fmt.fprintf ppf fmt in + match err with + | Label_mismatch patch -> + report_patch pp_record_diff first second decl env ppf patch + | Unboxed_float_representation ord -> + pr "@[Their internal representations differ:@ %s %s %s.@]" + (choose ord first second) decl + "uses unboxed float representation" + +let report_constructor_mismatch first second decl env ppf err = + let pr fmt = Fmt.fprintf ppf fmt in + match (err : constructor_mismatch) with + | Type err -> report_type_inequality env ppf err + | Arity -> pr "They have different arities." + | Inline_record err -> + report_patch pp_record_diff first second decl env ppf err + | Kind ord -> + pr "%s uses inline records and %s doesn't." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + | Explicit_return_type ord -> + pr "%s has explicit return type and %s doesn't." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + +let pp_variant_diff first second prefix decl env ppf (x : variant_change) = + match x with + | Delete cd -> + Fmt.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s." + prefix x Style.inline_code (Ident.name cd.delete.cd_id) first decl + | Insert cd -> + Fmt.fprintf ppf "%aA constructor, %a, is missing in %s %s." + prefix x Style.inline_code (Ident.name cd.insert.cd_id) first decl + | Change Type {got; expected; reason} -> + Fmt.fprintf ppf + "@[%aConstructors do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + (Style.as_inline_code Printtyp.constructor) got + (Style.as_inline_code Printtyp.constructor) expected + (report_constructor_mismatch first second decl env) reason + | Change Name n -> + Fmt.fprintf ppf + "%aConstructors have different names, %a and %a." + prefix x + Style.inline_code n.got + Style.inline_code n.expected + | Swap sw -> + Fmt.fprintf ppf + "%aConstructors %a and %a have been swapped." + prefix x + Style.inline_code sw.first + Style.inline_code sw.last + | Move {name; got; expected} -> + Fmt.fprintf ppf + "@[<2>%aConstructor %a has been moved@ from@ position %d@ to %d.@]" + prefix x Style.inline_code name expected got + +let report_extension_constructor_mismatch first second decl env ppf err = + let pr fmt = Fmt.fprintf ppf fmt in + match (err : extension_constructor_mismatch) with + | Constructor_privacy -> + pr "Private extension constructor(s) would be revealed." + | Constructor_mismatch (id, ext1, ext2, err) -> + let constructor = + Style.as_inline_code (Printtyp.extension_only_constructor id) + in + pr "@[Constructors do not match:@;<1 2>%a@ is not the same as:\ + @;<1 2>%a@ %a@]" + constructor ext1 + constructor ext2 + (report_constructor_mismatch first second decl env) err + + +let report_private_variant_mismatch first second decl env ppf err = + let pr fmt = Fmt.fprintf ppf fmt in + let pp_tag ppf x = Fmt.fprintf ppf "`%s" x in + match (err : private_variant_mismatch) with + | Only_outer_closed -> + (* It's only dangerous in one direction, so we don't have a position *) + pr "%s is private and closed, but %s is not closed" + (String.capitalize_ascii second) first + | Missing (ord, name) -> + pr "The constructor %a is only present in %s %s." + Style.inline_code name (choose ord first second) decl + | Presence s -> + pr "The tag %a is present in the %s %s,@ but might not be in the %s" + (Style.as_inline_code pp_tag) s second decl first + | Incompatible_types_for s -> pr "Types for tag `%s are incompatible" s + | Types err -> + report_type_inequality env ppf err + +let report_private_object_mismatch env ppf err = + let pr fmt = Fmt.fprintf ppf fmt in + match (err : private_object_mismatch) with + | Missing s -> + pr "The implementation is missing the method %a" Style.inline_code s + | Types err -> report_type_inequality env ppf err + +let report_kind_mismatch first second ppf (kind1, kind2) = + let pr fmt = Fmt.fprintf ppf fmt in + let kind_to_string = function + | Kind_abstract -> "abstract" + | Kind_record -> "a record" + | Kind_variant -> "a variant" + | Kind_open -> "an extensible variant" in + pr "%s is %s, but %s is %s." + (String.capitalize_ascii first) + (kind_to_string kind1) + second + (kind_to_string kind2) + +let report_type_mismatch first second decl env ppf err = + let pr fmt = Fmt.fprintf ppf fmt in + pr "@ "; + match err with + | Arity -> + pr "They have different arities." + | Privacy err -> + report_privacy_mismatch ppf err + | Kind err -> + report_kind_mismatch first second ppf err + | Constraint err -> + (* This error can come from implicit parameter disagreement or from + explicit `constraint`s. Both affect the parameters, hence this choice + of explanatory text *) + pr "Their parameters differ@,"; + report_type_inequality env ppf err + | Manifest err -> + report_type_inequality env ppf err + | Private_variant (_ty1, _ty2, mismatch) -> + report_private_variant_mismatch first second decl env ppf mismatch + | Private_object (_ty1, _ty2, mismatch) -> + report_private_object_mismatch env ppf mismatch + | Variance -> + pr "Their variances do not agree." + | Record_mismatch err -> + report_record_mismatch first second decl env ppf err + | Variant_mismatch err -> + report_patch pp_variant_diff first second decl env ppf err + | Unboxed_representation ord -> + pr "Their internal representations differ:@ %s %s %s." + (choose ord first second) decl + "uses unboxed representation" + | Immediate violation -> + let first = StringLabels.capitalize_ascii first in + match violation with + | Type_immediacy.Violation.Not_always_immediate -> + pr "%s is not an immediate type." first + | Type_immediacy.Violation.Not_always_immediate_on_64bits -> + pr "%s is not a type that is always immediate on 64 bit platforms." + first + +module Record_diffing = struct + + let compare_labels env params1 params2 + (ld1 : Types.label_declaration) + (ld2 : Types.label_declaration) = + if ld1.ld_mutable <> ld2.ld_mutable + then + let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in + Some (Mutability ord) + else + let tl1 = params1 @ [ld1.ld_type] in + let tl2 = params2 @ [ld2.ld_type] in + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Type err : label_mismatch) + | () -> None + + let rec equal ~loc env params1 params2 + (labels1 : Types.label_declaration list) + (labels2 : Types.label_declaration list) = + match labels1, labels2 with + | [], [] -> true + | _ :: _ , [] | [], _ :: _ -> false + | ld1 :: rem1, ld2 :: rem2 -> + if Ident.name ld1.ld_id <> Ident.name ld2.ld_id + then false + else begin + Builtin_attributes.check_deprecated_mutable_inclusion + ~def:ld1.ld_loc + ~use:ld2.ld_loc + loc + ld1.ld_attributes ld2.ld_attributes + (Ident.name ld1.ld_id); + match compare_labels env params1 params2 ld1 ld2 with + | Some _ -> false + (* add arguments to the parameters, cf. PR#7378 *) + | None -> + equal ~loc env + (ld1.ld_type::params1) (ld2.ld_type::params2) + rem1 rem2 + end + + module Defs = struct + type left = Types.label_declaration + type right = left + type diff = label_mismatch + type state = type_expr list * type_expr list + end + module Diff = Diffing_with_keys.Define(Defs) + + let update (d:Diff.change) (params1,params2 as st) = + match d with + | Insert _ | Change _ | Delete _ -> st + | Keep (x,y,_) -> + (* We need to add equality between existential type parameters + (in inline records) *) + x.data.ld_type::params1, y.data.ld_type::params2 + + let test _loc env (params1,params2) + ({pos; data=lbl1}: Diff.left) + ({data=lbl2; _ }: Diff.right) + = + let name1, name2 = Ident.name lbl1.ld_id, Ident.name lbl2.ld_id in + if name1 <> name2 then + let types_match = + match compare_labels env params1 params2 lbl1 lbl2 with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_labels env params1 params2 lbl1 lbl2 with + | Some reason -> + Error ( + Diffing_with_keys.Type {pos; got=lbl1; expected=lbl2; reason} + ) + | None -> Ok () + + let weight: Diff.change -> _ = function + | Insert _ | Delete _ -> + (* Insertion and deletion are symmetrical for definitions *) + 100 + | Keep _ -> 0 + (* [Keep] must have the smallest weight. *) + | Change (_,_,c) -> + (* Constraints: + - [ Change < Insert + Delete ], otherwise [Change] are never optimal + + - [ Swap < Move ] => [ 2 Change < Insert + Delete ] => + [ Change < Delete ], in order to favour consecutive [Swap]s + over [Move]s. + + - For some D and a large enough R, + [Delete^D Keep^R Insert^D < Change^(D+R)] + => [ Change > (2 D)/(D+R) Delete ]. + Note that the case [D=1,R=1] is incompatible with the inequation + above. If we choose [R = D + 1] for [D<5], we can specialize the + inequation to [ Change > 10 / 11 Delete ]. *) + match c with + (* With [Type + if t.types_match then 98 else 99 + | Diffing_with_keys.Type _ -> 50 + (* With the uniqueness constraint on keys, the only relevant constraint + is [Type-only change < Name change]. Indeed, names can only match at + one position. In other words, if a [ Type ] patch is admissible, the + only admissible patches at this position are of the form [Delete^D + Name_change]. And with the constranit [Type_change < Name_change], + we have [Type_change Delete^D < Delete^D Name_change]. *) + + let key (x: Defs.left) = Ident.name x.ld_id + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let module Compute = Diff.Simple(struct + let key_left = key + let key_right = key + let update = update + let test = test loc env + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + + let compare_with_representation ~loc env params1 params2 l r rep1 rep2 = + if not (equal ~loc env params1 params2 l r) then + let patch = diffing loc env params1 params2 l r in + Some (Record_mismatch (Label_mismatch patch)) + else + match rep1, rep2 with + | Record_unboxed _, Record_unboxed _ -> None + | Record_unboxed _, _ -> Some (Unboxed_representation First) + | _, Record_unboxed _ -> Some (Unboxed_representation Second) + + | Record_float, Record_float -> None + | Record_float, _ -> + Some (Record_mismatch (Unboxed_float_representation First)) + | _, Record_float -> + Some (Record_mismatch (Unboxed_float_representation Second)) + + | Record_regular, Record_regular + | Record_inlined _, Record_inlined _ + | Record_extension _, Record_extension _ -> None + | (Record_regular|Record_inlined _|Record_extension _), + (Record_regular|Record_inlined _|Record_extension _) -> + assert false + +end + + +module Variant_diffing = struct + + let compare_constructor_arguments ~loc env params1 params2 arg1 arg2 = + match arg1, arg2 with + | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> + if List.length arg1 <> List.length arg2 then + Some (Arity : constructor_mismatch) + else begin + (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *) + match Ctype.equal env true (params1 @ arg1) (params2 @ arg2) with + | exception Ctype.Equality err -> Some (Type err) + | () -> None + end + | Types.Cstr_record l1, Types.Cstr_record l2 -> + Option.map + (fun rec_err -> Inline_record rec_err) + (Record_diffing.compare env ~loc params1 params2 l1 l2) + | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch) + | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch) + + let compare_constructors ~loc env params1 params2 res1 res2 args1 args2 = + match res1, res2 with + | Some r1, Some r2 -> + begin match Ctype.equal env true [r1] [r2] with + | exception Ctype.Equality err -> Some (Type err) + | () -> compare_constructor_arguments ~loc env [r1] [r2] args1 args2 + end + | Some _, None -> Some (Explicit_return_type First) + | None, Some _ -> Some (Explicit_return_type Second) + | None, None -> + compare_constructor_arguments ~loc env params1 params2 args1 args2 + + let equal ~loc env params1 params2 + (cstrs1 : Types.constructor_declaration list) + (cstrs2 : Types.constructor_declaration list) = + List.length cstrs1 = List.length cstrs2 && + List.for_all2 (fun (cd1:Types.constructor_declaration) + (cd2:Types.constructor_declaration) -> + Ident.name cd1.cd_id = Ident.name cd2.cd_id + && + begin + Builtin_attributes.check_alerts_inclusion + ~def:cd1.cd_loc + ~use:cd2.cd_loc + loc + cd1.cd_attributes cd2.cd_attributes + (Ident.name cd1.cd_id) + ; + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some _ -> false + | None -> true + end) cstrs1 cstrs2 + + module Defs = struct + type left = Types.constructor_declaration + type right = left + type diff = constructor_mismatch + type state = type_expr list * type_expr list + end + module D = Diffing_with_keys.Define(Defs) + + let update _ st = st + + let weight: D.change -> _ = function + | Insert _ | Delete _ -> 100 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name c) -> + if c.types_match then 98 else 99 + | Change (_,_,Diffing_with_keys.Type _) -> 50 + (** See {!Variant_diffing.weight} for an explanation *) + + let test loc env (params1,params2) + ({pos; data=cd1}: D.left) + ({data=cd2; _}: D.right) = + let name1, name2 = Ident.name cd1.cd_id, Ident.name cd2.cd_id in + if name1 <> name2 then + let types_match = + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some reason -> + Error (Diffing_with_keys.Type {pos; got=cd1; expected=cd2; reason}) + | None -> Ok () + + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let key (x:Defs.left) = Ident.name x.cd_id in + let module Compute = D.Simple(struct + let key_left = key + let key_right = key + let test = test loc env + let update = update + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + let compare_with_representation ~loc env params1 params2 + cstrs1 cstrs2 rep1 rep2 + = + let err = compare ~loc env params1 params2 cstrs1 cstrs2 in + match err, rep1, rep2 with + | None, Variant_regular, Variant_regular + | None, Variant_unboxed, Variant_unboxed -> + None + | Some err, _, _ -> + Some (Variant_mismatch err) + | None, Variant_unboxed, Variant_regular -> + Some (Unboxed_representation First) + | None, Variant_regular, Variant_unboxed -> + Some (Unboxed_representation Second) +end + +(* Inclusion between "private" annotations *) +let privacy_mismatch env decl1 decl2 = + match decl1.type_private, decl2.type_private with + | Private, Public -> begin + match decl1.type_kind, decl2.type_kind with + | Type_record _, Type_record _ -> Some Private_record_type + | Type_variant _, Type_variant _ -> Some Private_variant_type + | Type_open, Type_open -> Some Private_extensible_variant + | Type_abstract _, Type_abstract _ + when Option.is_some decl2.type_manifest -> begin + match decl1.type_manifest with + | Some ty1 -> begin + let ty1 = Ctype.expand_head env ty1 in + match get_desc ty1 with + | Tvariant row when Btype.is_constr_row ~allow_ident:true + (row_more row) -> + Some Private_row_type + | Tobject (fi, _) when Btype.is_constr_row ~allow_ident:true + (snd (Ctype.flatten_fields fi)) -> + Some Private_row_type + | _ -> + Some Private_type_abbreviation + end + | None -> + None + end + | _, _ -> + None + end + | _, _ -> + None + +let private_variant env row1 params1 row2 params2 = + let r1, r2, pairs = + Ctype.merge_row_fields (row_fields row1) (row_fields row2) + in + let row1_closed = row_closed row1 in + let row2_closed = row_closed row2 in + let err = + if row2_closed && not row1_closed then Some Only_outer_closed + else begin + match row2_closed, Ctype.filter_row_fields false r1 with + | true, (s, _) :: _ -> + Some (Missing (Second, s) : private_variant_mismatch) + | _, _ -> None + end + in + if err <> None then err else + let err = + let missing = + List.find_opt + (fun (_,f) -> + match row_field_repr f with + | Rabsent | Reither _ -> false + | Rpresent _ -> true) + r2 + in + match missing with + | None -> None + | Some (s, _) -> Some (Missing (First, s) : private_variant_mismatch) + in + if err <> None then err else + let rec loop tl1 tl2 pairs = + match pairs with + | [] -> begin + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Types err : private_variant_mismatch) + | () -> None + end + | (s, f1, f2) :: pairs -> begin + match row_field_repr f1, row_field_repr f2 with + | Rpresent to1, Rpresent to2 -> begin + match to1, to2 with + | Some t1, Some t2 -> + loop (t1 :: tl1) (t2 :: tl2) pairs + | None, None -> + loop tl1 tl2 pairs + | Some _, None | None, Some _ -> + Some (Incompatible_types_for s) + end + | Rpresent to1, Reither(const2, ts2, _) -> begin + match to1, const2, ts2 with + | Some t1, false, [t2] -> loop (t1 :: tl1) (t2 :: tl2) pairs + | None, true, [] -> loop tl1 tl2 pairs + | _, _, _ -> Some (Incompatible_types_for s) + end + | Rpresent _, Rabsent -> + Some (Missing (Second, s) : private_variant_mismatch) + | Reither(const1, ts1, _), Reither(const2, ts2, _) -> + if const1 = const2 && List.length ts1 = List.length ts2 then + loop (ts1 @ tl1) (ts2 @ tl2) pairs + else + Some (Incompatible_types_for s) + | Reither _, Rpresent _ -> + Some (Presence s) + | Reither _, Rabsent -> + Some (Missing (Second, s) : private_variant_mismatch) + | Rabsent, (Reither _ | Rabsent) -> + loop tl1 tl2 pairs + | Rabsent, Rpresent _ -> + Some (Missing (First, s) : private_variant_mismatch) + end + in + loop params1 params2 pairs + +let private_object env fields1 params1 fields2 params2 = + let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in + let err = + match miss2 with + | [] -> None + | (f, _, _) :: _ -> Some (Missing f) + in + if err <> None then err else + let tl1, tl2 = + List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) + in + begin + match Ctype.equal env true (params1 @ tl1) (params2 @ tl2) with + | exception Ctype.Equality err -> Some (Types err) + | () -> None + end + +let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = + let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in + match get_desc ty1', get_desc ty2' with + | Tvariant row1, Tvariant row2 + when is_absrow env (row_more row2) -> begin + assert (Ctype.is_equal env true (ty1::params1) (row_more row2::params2)); + match private_variant env row1 params1 row2 params2 with + | None -> None + | Some err -> Some (Private_variant(ty1, ty2, err)) + end + | Tobject (fi1, _), Tobject (fi2, _) + when is_absrow env (snd (Ctype.flatten_fields fi2)) -> begin + let (fields2,rest2) = Ctype.flatten_fields fi2 in + let (fields1,_) = Ctype.flatten_fields fi1 in + assert (Ctype.is_equal env true (ty1::params1) (rest2::params2)); + match private_object env fields1 params1 fields2 params2 with + | None -> None + | Some err -> Some (Private_object(ty1, ty2, err)) + end + | _ -> begin + let is_private_abbrev_2 = + match priv2, kind2 with + | Private, Type_abstract _ -> begin + (* Same checks as the [when] guards from above, inverted *) + match get_desc ty2' with + | Tvariant row -> + not (is_absrow env (row_more row)) + | Tobject (fi, _) -> + not (is_absrow env (snd (Ctype.flatten_fields fi))) + | _ -> true + end + | _, _ -> false + in + match + if is_private_abbrev_2 then + Ctype.equal_private env params1 ty1 params2 ty2 + else + Ctype.equal env true (params1 @ [ty1]) (params2 @ [ty2]) + with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> None + end + +(* A type declarations [td1] is consistent with the type declaration [td2] if + there is a context E such E |- td1 <: td2 for the ordinary subtyping. For + types, this is the case as soon as the two type declarations share the same + arity and the privacy of [td1] is less than the privacy of [td2] (consider a + context E where all type constructors are equal). *) +let type_declarations_consistency env decl1 decl2 = + if decl1.type_arity <> decl2.type_arity then Some Arity + else match privacy_mismatch env decl1 decl2 with + | Some err -> Some (Privacy err) + | None -> None + +let type_declarations ?(equality = false) ~loc env ~mark name + decl1 path decl2 = + Builtin_attributes.check_alerts_inclusion + ~def:decl1.type_loc + ~use:decl2.type_loc + loc + decl1.type_attributes decl2.type_attributes + name; + let err = type_declarations_consistency env decl1 decl2 in + if err <> None then err else + let err = match (decl1.type_manifest, decl2.type_manifest) with + (_, None) -> + begin + match Ctype.equal env true decl1.type_params decl2.type_params with + | exception Ctype.Equality err -> Some (Constraint err) + | () -> None + end + | (Some ty1, Some ty2) -> + type_manifest env ty1 decl1.type_params ty2 decl2.type_params + decl2.type_private decl2.type_kind + | (None, Some ty2) -> + let ty1 = + Btype.newgenty (Tconstr(path, decl2.type_params, ref Mnil)) + in + match Ctype.equal env true decl1.type_params decl2.type_params with + | exception Ctype.Equality err -> Some (Constraint err) + | () -> + match Ctype.equal env false [ty1] [ty2] with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> None + in + if err <> None then err else + let err = match (decl1.type_kind, decl2.type_kind) with + (_, Type_abstract _) -> None + | (Type_variant (cstrs1, rep1), Type_variant (cstrs2, rep2)) -> + if mark then begin + let mark usage cstrs = + List.iter (Env.mark_constructor_used usage) cstrs + in + let usage : Env.constructor_usage = + if decl2.type_private = Public then Env.Exported + else Env.Exported_private + in + mark usage cstrs1; + if equality then mark Env.Exported cstrs2 + end; + Variant_diffing.compare_with_representation ~loc env + decl1.type_params + decl2.type_params + cstrs1 + cstrs2 + rep1 + rep2 + | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> + if mark then begin + let mark usage lbls = + List.iter (Env.mark_label_used usage) lbls + in + let usage : Env.label_usage = + if decl2.type_private = Public then Env.Exported + else Env.Exported_private + in + mark usage labels1; + if equality then mark Env.Exported labels2 + end; + Record_diffing.compare_with_representation ~loc env + decl1.type_params decl2.type_params + labels1 labels2 + rep1 rep2 + | (Type_open, Type_open) -> None + | (_, _) -> Some (Kind (of_kind decl1.type_kind, of_kind decl2.type_kind)) + in + if err <> None then err else + let abstr = Btype.type_kind_is_abstract decl2 && decl2.type_manifest = None in + (* If attempt to assign a non-immediate type (e.g. string) to a type that + * must be immediate, then we error *) + let err = + if not abstr then + None + else + match + Type_immediacy.coerce decl1.type_immediate ~as_:decl2.type_immediate + with + | Ok () -> None + | Error violation -> Some (Immediate violation) + in + if err <> None then err else + let need_variance = + abstr || decl1.type_private = Private || decl1.type_kind = Type_open in + if not need_variance then None else + let abstr = abstr || decl2.type_private = Private in + let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in + let constrained ty = not (Btype.is_Tvar ty) in + if List.for_all2 + (fun ty (v1,v2) -> + let open Variance in + let imp a b = not a || b in + let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in + (if abstr then (imp co1 co2 && imp cn1 cn2) + else if opn || constrained ty then (co1 = co2 && cn1 = cn2) + else true) && + let (p1,n1,j1) = get_lower v1 and (p2,n2,j2) = get_lower v2 in + imp abstr (imp p2 p1 && imp n2 n1 && imp j2 j1)) + decl2.type_params (List.combine decl1.type_variance decl2.type_variance) + then None else Some Variance + +(* Inclusion between extension constructors *) + +let extension_constructors ~loc env ~mark id ext1 ext2 = + if mark then begin + let usage : Env.constructor_usage = + if ext2.ext_private = Public then Env.Exported + else Env.Exported_private + in + Env.mark_extension_used usage ext1 + end; + let ty1 = + Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) + in + let ty2 = + Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil)) + in + let tl1 = ty1 :: ext1.ext_type_params in + let tl2 = ty2 :: ext2.ext_type_params in + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Constructor_mismatch (id, ext1, ext2, Type err)) + | () -> + let r = + Variant_diffing.compare_constructors ~loc env + ext1.ext_type_params ext2.ext_type_params + ext1.ext_ret_type ext2.ext_ret_type + ext1.ext_args ext2.ext_args + in + match r with + | Some r -> Some (Constructor_mismatch (id, ext1, ext2, r)) + | None -> + match ext1.ext_private, ext2.ext_private with + | Private, Public -> Some Constructor_privacy + | _, _ -> None diff --git a/upstream/ocaml_503/typing/includecore.mli b/upstream/ocaml_503/typing/includecore.mli new file mode 100644 index 000000000..bed53fb03 --- /dev/null +++ b/upstream/ocaml_503/typing/includecore.mli @@ -0,0 +1,154 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the core language *) + +open Typedtree +open Types + +type position = Errortrace.position = First | Second + +type primitive_mismatch = + | Name + | Arity + | No_alloc of position + | Native_name + | Result_repr + | Argument_repr of int + +type value_mismatch = + | Primitive_mismatch of primitive_mismatch + | Not_a_primitive + | Type of Errortrace.moregen_error + +exception Dont_match of value_mismatch + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +type kind_mismatch = type_kind * type_kind + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration as 'ld, 'ld, label_mismatch) Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * extension_constructor + * extension_constructor + * constructor_mismatch +type variant_change = + (Types.constructor_declaration as 'cd, 'cd, constructor_mismatch) + Diffing_with_keys.change + +type private_variant_mismatch = + | Only_outer_closed + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind of kind_mismatch + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | Private_variant of type_expr * type_expr * private_variant_mismatch + | Private_object of type_expr * type_expr * private_object_mismatch + | Variance + | Record_mismatch of record_mismatch + | Variant_mismatch of variant_change list + | Unboxed_representation of position + | Immediate of Type_immediacy.Violation.t + +val value_descriptions: + loc:Location.t -> Env.t -> string -> + value_description -> value_description -> module_coercion + +val type_declarations: + ?equality:bool -> + loc:Location.t -> + Env.t -> mark:bool -> string -> + type_declaration -> Path.t -> type_declaration -> type_mismatch option + +val extension_constructors: + loc:Location.t -> Env.t -> mark:bool -> Ident.t -> + extension_constructor -> extension_constructor -> + extension_constructor_mismatch option + +(** The functions [value_descriptions_consistency] and + [type_declarations_consistency] check if two declaration are consistent. + Declarations are consistent when there exists an environment such that the + first declaration is a subtype of the second one. + + Notably, if a type declaration [td1] is consistent with [td2] then a type + expression [te] which is well-formed with the [td2] declaration in scope + is still well-formed with the [td1] declaration: [E, td2 |- te] => [E, td1 + |- te]. *) +val value_descriptions_consistency: + Env.t -> value_description -> value_description -> module_coercion +val type_declarations_consistency: + Env.t -> type_declaration -> type_declaration -> type_mismatch option + +(* +val class_types: + Env.t -> class_type -> class_type -> bool +*) + +val report_value_mismatch : + string -> string -> + Env.t -> + value_mismatch Format_doc.printer + +val report_type_mismatch : + string -> string -> string -> + Env.t -> + type_mismatch Format_doc.printer + +val report_extension_constructor_mismatch : + string -> string -> string -> + Env.t -> + extension_constructor_mismatch Format_doc.printer diff --git a/upstream/ocaml_503/typing/includemod.ml b/upstream/ocaml_503/typing/includemod.ml new file mode 100644 index 000000000..393b9e3ee --- /dev/null +++ b/upstream/ocaml_503/typing/includemod.ml @@ -0,0 +1,1311 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the module language *) + +open Misc +open Typedtree +open Types + +type symptom = + Missing_field of Ident.t * Location.t * string (* kind *) + | Value_descriptions of Ident.t * value_description * value_description + * Includecore.value_mismatch + | Type_declarations of Ident.t * type_declaration + * type_declaration * Includecore.type_mismatch + | Extension_constructors of Ident.t * extension_constructor + * extension_constructor * Includecore.extension_constructor_mismatch + | Module_types of module_type * module_type + | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration + | Modtype_permutation of Types.module_type * Typedtree.module_coercion + | Interface_mismatch of string * string + | Class_type_declarations of + Ident.t * class_type_declaration * class_type_declaration * + Ctype.class_match_failure list + | Class_declarations of + Ident.t * class_declaration * class_declaration * + Ctype.class_match_failure list + | Unbound_module_path of Path.t + | Invalid_module_alias of Path.t + +type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of functor_parameter + | Body of functor_parameter + + +module Error = struct + + type functor_arg_descr = + | Anonymous + | Named of Path.t + | Unit + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module *) + + type ('a,'b) diff = {got:'a; expected:'a; symptom:'b} + type 'a core_diff =('a,unit) diff + let diff x y s = {got=x;expected=y; symptom=s} + let sdiff x y = {got=x; expected=y; symptom=()} + + type core_sigitem_symptom = + | Value_descriptions of (value_description, Includecore.value_mismatch) diff + | Type_declarations of (type_declaration, Includecore.type_mismatch) diff + | Extension_constructors of + (extension_constructor, Includecore.extension_constructor_mismatch) diff + | Class_type_declarations of + (class_type_declaration, Ctype.class_match_failure list) diff + | Class_declarations of + (class_declaration, Ctype.class_match_failure list) diff + + type core_module_type_symptom = + | Not_an_alias + | Not_an_identifier + | Incompatible_aliases + | Abstract_module_type + | Unbound_module_path of Path.t + + type module_type_symptom = + | Mt_core of core_module_type_symptom + | Signature of signature_symptom + | Functor of functor_symptom + | Invalid_module_alias of Path.t + | After_alias_expansion of module_type_diff + + + and module_type_diff = (module_type, module_type_symptom) diff + + and functor_symptom = + | Params of functor_params_diff + | Result of module_type_diff + + and ('arg,'path) functor_param_symptom = + | Incompatible_params of 'arg * functor_parameter + | Mismatch of module_type_diff + + and arg_functor_param_symptom = + (functor_parameter, Ident.t) functor_param_symptom + + and functor_params_diff = (functor_parameter list * module_type) core_diff + + and signature_symptom = { + env: Env.t; + missings: signature_item list; + incompatibles: (Ident.t * sigitem_symptom) list; + oks: (int * module_coercion) list; + leftovers: (signature_item * signature_item * int) list; + } + and sigitem_symptom = + | Core of core_sigitem_symptom + | Module_type_declaration of + (modtype_declaration, module_type_declaration_symptom) diff + | Module_type of module_type_diff + + and module_type_declaration_symptom = + | Illegal_permutation of Typedtree.module_coercion + | Not_greater_than of module_type_diff + | Not_less_than of module_type_diff + | Incomparable of + {less_than:module_type_diff; greater_than: module_type_diff} + + + type all = + | In_Compilation_unit of (string, signature_symptom) diff + | In_Signature of signature_symptom + | In_Module_type of module_type_diff + | In_Module_type_substitution of + Ident.t * (Types.module_type,module_type_declaration_symptom) diff + | In_Type_declaration of Ident.t * core_sigitem_symptom + | In_Expansion of core_module_type_symptom + +end + +type mark = + | Mark_both + | Mark_positive + | Mark_negative + | Mark_neither + +let negate_mark = function + | Mark_both -> Mark_both + | Mark_positive -> Mark_negative + | Mark_negative -> Mark_positive + | Mark_neither -> Mark_neither + +let mark_positive = function + | Mark_both | Mark_positive -> true + | Mark_negative | Mark_neither -> false + +module Core_inclusion = struct + (* All functions "blah env x1 x2" check that x1 is included in x2, + i.e. that x1 is the type of an implementation that fulfills the + specification x2. If not, Error is raised with a backtrace of the error. *) + + (* Inclusion between value descriptions *) + + let value_descriptions ~loc env ~mark subst id vd1 vd2 = + Cmt_format.record_value_dependency vd1 vd2; + if mark_positive mark then + Env.mark_value_used vd1.val_uid; + let vd2 = Subst.value_description subst vd2 in + try + Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2) + with Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) + + (* Inclusion between type declarations *) + + let type_declarations ~loc env ~mark subst id decl1 decl2 = + let mark = mark_positive mark in + if mark then + Env.mark_type_used decl1.type_uid; + let decl2 = Subst.type_declaration subst decl2 in + match + Includecore.type_declarations ~loc env ~mark + (Ident.name id) decl1 (Path.Pident id) decl2 + with + | None -> Ok Tcoerce_none + | Some err -> + Error Error.(Core(Type_declarations (diff decl1 decl2 err))) + + (* Inclusion between extension constructors *) + + let extension_constructors ~loc env ~mark subst id ext1 ext2 = + let mark = mark_positive mark in + let ext2 = Subst.extension_constructor subst ext2 in + match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with + | None -> Ok Tcoerce_none + | Some err -> + Error Error.(Core(Extension_constructors(diff ext1 ext2 err))) + + (* Inclusion between class declarations *) + + let class_type_declarations ~loc env ~mark:_ subst _id decl1 decl2 = + let decl2 = Subst.cltype_declaration subst decl2 in + match Includeclass.class_type_declarations ~loc env decl1 decl2 with + [] -> Ok Tcoerce_none + | reason -> + Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason))) + + let class_declarations ~loc:_ env ~mark:_ subst _id decl1 decl2 = + let decl2 = Subst.class_declaration subst decl2 in + match Includeclass.class_declarations env decl1 decl2 with + [] -> Ok Tcoerce_none + | reason -> + Error Error.(Core(Class_declarations(diff decl1 decl2 reason))) +end + +(* Expand a module type identifier when possible *) + +let expand_modtype_path env path = + match Env.find_modtype_expansion path env with + | exception Not_found -> None + | x -> Some x + +let expand_module_alias ~strengthen env path = + match + if strengthen then Env.find_strengthened_module ~aliasable:true path env + else (Env.find_module path env).md_type + with + | x -> Ok x + | exception Not_found -> Error (Error.Unbound_module_path path) + +(* Extract name, kind and ident from a signature item *) + +type field_kind = + | Field_value + | Field_type + | Field_exception + | Field_typext + | Field_module + | Field_modtype + | Field_class + | Field_classtype + + + +type field_desc = { name: string; kind: field_kind } + +let kind_of_field_desc fd = match fd.kind with + | Field_value -> "value" + | Field_type -> "type" + | Field_exception -> "exception" + | Field_typext -> "extension constructor" + | Field_module -> "module" + | Field_modtype -> "module type" + | Field_class -> "class" + | Field_classtype -> "class type" + +let field_desc kind id = { kind; name = Ident.name id } + +(** Map indexed by both field types and names. + This avoids name clashes between different sorts of fields + such as values and types. *) +module FieldMap = Map.Make(struct + type t = field_desc + let compare = Stdlib.compare + end) + +let item_ident_name = function + Sig_value(id, d, _) -> (id, d.val_loc, field_desc Field_value id) + | Sig_type(id, d, _, _) -> (id, d.type_loc, field_desc Field_type id ) + | Sig_typext(id, d, _, _) -> + let kind = + if Path.same d.ext_type_path Predef.path_exn + then Field_exception + else Field_typext + in + (id, d.ext_loc, field_desc kind id) + | Sig_module(id, _, d, _, _) -> (id, d.md_loc, field_desc Field_module id) + | Sig_modtype(id, d, _) -> (id, d.mtd_loc, field_desc Field_modtype id) + | Sig_class(id, d, _, _) -> (id, d.cty_loc, field_desc Field_class id) + | Sig_class_type(id, d, _, _) -> + (id, d.clty_loc, field_desc Field_classtype id) + +let is_runtime_component = function + | Sig_value(_,{val_kind = Val_prim _}, _) + | Sig_type(_,_,_,_) + | Sig_module(_,Mp_absent,_,_,_) + | Sig_modtype(_,_,_) + | Sig_class_type(_,_,_,_) -> false + | Sig_value(_,_,_) + | Sig_typext(_,_,_,_) + | Sig_module(_,Mp_present,_,_,_) + | Sig_class(_,_,_,_) -> true + +(* Print a coercion *) + +let rec print_list pr ppf = function + [] -> () + | [a] -> pr ppf a + | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l +let print_list pr ppf l = + Format.fprintf ppf "[@[%a@]]" (print_list pr) l + +let rec print_coercion ppf c = + let pr fmt = Format.fprintf ppf fmt in + match c with + Tcoerce_none -> pr "id" + | Tcoerce_structure (fl, nl) -> + pr "@[<2>struct@ %a@ %a@]" + (print_list print_coercion2) fl + (print_list print_coercion3) nl + | Tcoerce_functor (inp, out) -> + pr "@[<2>functor@ (%a)@ (%a)@]" + print_coercion inp + print_coercion out + | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> + pr "prim %s@ (%a)" pc_desc.Primitive.prim_name + Rawprinttyp.type_expr pc_type + | Tcoerce_alias (_, p, c) -> + pr "@[<2>alias %a@ (%a)@]" + Printtyp.path p + print_coercion c +and print_coercion2 ppf (n, c) = + Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c +and print_coercion3 ppf (i, n, c) = + Format.fprintf ppf "@[%s, %d,@ %a@]" + (Ident.unique_name i) n print_coercion c + +(* Simplify a structure coercion *) + +let equal_module_paths env p1 subst p2 = + Path.same p1 p2 + || Path.same (Env.normalize_module_path None env p1) + (Env.normalize_module_path None env + (Subst.module_path subst p2)) + +let equal_modtype_paths env p1 subst p2 = + Path.same p1 p2 + || Path.same (Env.normalize_modtype_path env p1) + (Env.normalize_modtype_path env + (Subst.modtype_path subst p2)) + +let simplify_structure_coercion cc id_pos_list = + let rec is_identity_coercion pos = function + | [] -> + true + | (n, c) :: rem -> + n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in + if is_identity_coercion 0 cc + then Tcoerce_none + else Tcoerce_structure (cc, id_pos_list) + +let retrieve_functor_params env mty = + let rec retrieve_functor_params before env = + function + | Mty_ident p as res -> + begin match expand_modtype_path env p with + | Some mty -> retrieve_functor_params before env mty + | None -> List.rev before, res + end + | Mty_alias p as res -> + begin match expand_module_alias ~strengthen:false env p with + | Ok mty -> retrieve_functor_params before env mty + | Error _ -> List.rev before, res + end + | Mty_functor (p, res) -> retrieve_functor_params (p :: before) env res + | Mty_signature _ as res -> List.rev before, res + in + retrieve_functor_params [] env mty + +(* Inclusion between module types. + Return the restriction that transforms a value of the smaller type + into a value of the bigger type. *) + +(* When computing a signature difference, we need to distinguish between + recoverable errors at the value level and unrecoverable errors at the type + level that require us to stop the computation of the difference due to + incoherent types. +*) +type 'a recoverable_error = { error: 'a; recoverable:bool } +let mark_error_as_recoverable r = + Result.map_error (fun error -> { error; recoverable=true}) r +let mark_error_as_unrecoverable r = + Result.map_error (fun error -> { error; recoverable=false}) r + + +module Sign_diff = struct + type t = { + runtime_coercions: (int * Typedtree.module_coercion) list; + shape_map: Shape.Map.t; + deep_modifications:bool; + errors: (Ident.t * Error.sigitem_symptom) list; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + } + + let empty = { + runtime_coercions = []; + shape_map = Shape.Map.empty; + deep_modifications = false; + errors = []; + leftovers = [] + } + + let merge x y = + { + runtime_coercions = x.runtime_coercions @ y.runtime_coercions; + shape_map = y.shape_map; + (* the shape map is threaded the map during the difference computation, + the last shape map contains all previous elements. *) + deep_modifications = x.deep_modifications || y.deep_modifications; + errors = x.errors @ y.errors; + leftovers = x.leftovers @ y.leftovers + } +end + +(** Core type system subtyping-like relation that we want to lift at the module + level. We have two relations that we want to lift: + + - the normal subtyping relation [<:]. + - the coarse-grain consistency relation [C], which is defined by + [d1 C d2] if there is an environment [E] such that [E |- d1 <: d2]. *) +type 'a core_incl = + loc:Location.t -> Env.t -> mark:mark -> Subst.t -> Ident.t -> + 'a -> 'a -> (module_coercion, Error.sigitem_symptom) result + +type core_relation = { + value_descriptions: Types.value_description core_incl; + type_declarations: Types.type_declaration core_incl; + extension_constructors: Types.extension_constructor core_incl; + class_declarations: Types.class_declaration core_incl; + class_type_declarations: Types.class_type_declaration core_incl; +} + +(** + In the group of mutual functions below, the [~in_eq] argument is [true] when + we are in fact checking equality of module types. + + The module subtyping relation [A <: B] checks that [A.T = B.T] when [A] + and [B] define a module type [T]. The relation [A.T = B.T] is equivalent + to [(A.T <: B.T) and (B.T <: A.T)], but checking both recursively would lead + to an exponential slowdown (see #10598 and #10616). + To avoid this issue, when [~in_eq] is [true], we compute a coarser relation + [A << B] which is the same as [A <: B] except that module types [T] are + checked only for [A.T << B.T] and not the reverse. + Thus, we can implement a cheap module type equality check [A.T = B.T] by + computing [(A.T << B.T) and (B.T << A.T)], avoiding the exponential slowdown + described above. +*) + +let rec modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape = + match try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape with + | Ok _ as ok -> ok + | Error reason -> + let mty2 = Subst.modtype Make_local subst mty2 in + Error Error.(diff mty1 mty2 reason) + +and try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = + match mty1, mty2 with + | (Mty_alias p1, Mty_alias p2) -> + if Env.is_functor_arg p2 env then + Error (Error.Invalid_module_alias p2) + else if not (equal_module_paths env p1 subst p2) then + Error Error.(Mt_core Incompatible_aliases) + else Ok (Tcoerce_none, orig_shape) + | (Mty_alias p1, _) -> begin + match + Env.normalize_module_path (Some Location.none) env p1 + with + | exception Env.Error (Env.Missing_module (_, _, path)) -> + Error Error.(Mt_core(Unbound_module_path path)) + | p1 -> + begin match expand_module_alias ~strengthen:false env p1 with + | Error e -> Error (Error.Mt_core e) + | Ok mty1 -> + match strengthened_modtypes ~core ~in_eq ~loc ~aliasable:true env + ~mark subst mty1 p1 mty2 orig_shape + with + | Ok _ as x -> x + | Error reason -> Error (Error.After_alias_expansion reason) + end + end + | (Mty_ident p1, Mty_ident p2) -> + let p1 = Env.normalize_modtype_path env p1 in + let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in + if Path.same p1 p2 then Ok (Tcoerce_none, orig_shape) + else + begin match expand_modtype_path env p1, expand_modtype_path env p2 with + | Some mty1, Some mty2 -> + try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape + | None, _ | _, None -> Error (Error.Mt_core Abstract_module_type) + end + | (Mty_ident p1, _) -> + let p1 = Env.normalize_modtype_path env p1 in + begin match expand_modtype_path env p1 with + | Some p1 -> + try_modtypes ~core ~in_eq ~loc env ~mark subst p1 mty2 orig_shape + | None -> Error (Error.Mt_core Abstract_module_type) + end + | (_, Mty_ident p2) -> + let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in + begin match expand_modtype_path env p2 with + | Some p2 -> + try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 p2 orig_shape + | None -> + begin match mty1 with + | Mty_functor _ -> + let params1 = retrieve_functor_params env mty1 in + let d = Error.sdiff params1 ([],mty2) in + Error Error.(Functor (Params d)) + | _ -> Error Error.(Mt_core Not_an_identifier) + end + end + | (Mty_signature sig1, Mty_signature sig2) -> + begin match + signatures ~core ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape + with + | Ok _ as ok -> ok + | Error e -> Error (Error.Signature e) + end + | Mty_functor (param1, res1), Mty_functor (param2, res2) -> + let cc_arg, env, subst = + functor_param ~core ~in_eq ~loc env ~mark:(negate_mark mark) + subst param1 param2 + in + let var, res_shape = + match Shape.decompose_abs orig_shape with + | Some (var, res_shape) -> var, res_shape + | None -> + (* Using a fresh variable with a placeholder uid here is fine: users + will never try to jump to the definition of that variable. If + they try to jump to the parameter from inside the functor, they + will use the variable shape that is stored in the local + environment. *) + let var, shape_var = + Shape.fresh_var Uid.internal_not_actually_unique + in + var, Shape.app orig_shape ~arg:shape_var + in + let cc_res = + modtypes ~core ~in_eq ~loc env ~mark subst res1 res2 res_shape + in + begin match cc_arg, cc_res with + | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_none, final_shape) + | Ok cc_arg, Ok (cc_res, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_functor(cc_arg, cc_res), final_shape) + | _, Error {Error.symptom = Error.Functor Error.Params res; _} -> + let got_params, got_res = res.got in + let expected_params, expected_res = res.expected in + let d = Error.sdiff + (param1::got_params, got_res) + (param2::expected_params, expected_res) in + Error Error.(Functor (Params d)) + | Error _, _ -> + let params1, res1 = retrieve_functor_params env res1 in + let params2, res2 = retrieve_functor_params env res2 in + let d = Error.sdiff (param1::params1, res1) (param2::params2, res2) in + Error Error.(Functor (Params d)) + | Ok _, Error res -> + Error Error.(Functor (Result res)) + end + | Mty_functor _, _ + | _, Mty_functor _ -> + let params1 = retrieve_functor_params env mty1 in + let params2 = retrieve_functor_params env mty2 in + let d = Error.sdiff params1 params2 in + Error Error.(Functor (Params d)) + | _, Mty_alias _ -> + Error (Error.Mt_core Error.Not_an_alias) + +(* Functor parameters *) + +and functor_param ~core ~in_eq ~loc env ~mark subst param1 param2 = + match param1, param2 with + | Unit, Unit -> + Ok Tcoerce_none, env, subst + | Named (name1, arg1), Named (name2, arg2) -> + let arg2' = Subst.modtype Keep subst arg2 in + let cc_arg = + match + modtypes ~core ~in_eq ~loc env ~mark Subst.identity arg2' arg1 + Shape.dummy_mod + with + | Ok (cc, _) -> Ok cc + | Error err -> Error (Error.Mismatch err) + in + let env, subst = equate_one_functor_param subst env arg2' name1 name2 in + cc_arg, env, subst + | _, _ -> + Error (Error.Incompatible_params (param1, param2)), env, subst + +and equate_one_functor_param subst env arg2' name1 name2 = + match name1, name2 with + | Some id1, Some id2 -> + (* two matching abstract parameters: we add one identifier to the + environment and record the equality between the two identifiers + in the substitution *) + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | None, Some id2 -> + let id1 = Ident.rename id2 in + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | Some id1, None -> + Env.add_module id1 Mp_present arg2' env, subst + | None, None -> + env, subst + +and strengthened_modtypes ~core ~in_eq ~loc ~aliasable env ~mark + subst mty1 path1 mty2 shape = + match mty1, mty2 with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in + modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape + +and strengthened_module_decl ~core ~loc ~aliasable env ~mark + subst md1 path1 md2 shape = + match md1.md_type, md2.md_type with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in + modtypes ~core ~in_eq:false ~loc env ~mark subst + md1.md_type md2.md_type shape + +(* Inclusion between signatures *) + +and signatures ~core ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = + (* Environment used to check inclusion of components *) + let new_env = + Env.add_signature sig1 (Env.in_signature true env) in + (* Keep ids for module aliases *) + let (id_pos_list,_) = + List.fold_left + (fun (l,pos) -> function + Sig_module (id, Mp_present, _, _, _) -> + ((id,pos,Tcoerce_none)::l , pos+1) + | item -> (l, if is_runtime_component item then pos+1 else pos)) + ([], 0) sig1 in + (* Build a table of the components of sig1, along with their positions. + The table is indexed by kind and name of component *) + let rec build_component_table nb_exported pos tbl = function + [] -> nb_exported, pos, tbl + | item :: rem -> + let pos, nextpos = + if is_runtime_component item then pos, pos + 1 + else -1, pos + in + match item_visibility item with + | Hidden -> + (* do not pair private items. *) + build_component_table nb_exported nextpos tbl rem + | Exported -> + let (id, _loc, name) = item_ident_name item in + build_component_table (nb_exported + 1) nextpos + (FieldMap.add name (id, item, pos) tbl) rem + in + let exported_len1, runtime_len1, comps1 = + build_component_table 0 0 FieldMap.empty sig1 + in + let exported_len2, runtime_len2 = + List.fold_left (fun (el, rl) i -> + let el = match item_visibility i with Hidden -> el | Exported -> el + 1 in + let rl = if is_runtime_component i then rl + 1 else rl in + el, rl + ) (0, 0) sig2 + in + (* Pair each component of sig2 with a component of sig1, + identifying the names along the way. + Return a coercion list indicating, for all run-time components + of sig2, the position of the matching run-time components of sig1 + and the coercion to be applied to it. *) + let rec pair_components ~core subst paired unpaired = function + [] -> + let open Sign_diff in + let d = + signature_components ~core ~in_eq ~loc env ~mark new_env subst + mod_shape Shape.Map.empty + (List.rev paired) + in + begin match unpaired, d.errors, d.runtime_coercions, d.leftovers with + | [], [], cc, [] -> + let shape = + if not d.deep_modifications && exported_len1 = exported_len2 + then mod_shape + else Shape.str ?uid:mod_shape.Shape.uid d.shape_map + in + if runtime_len1 = runtime_len2 then (* see PR#5098 *) + Ok (simplify_structure_coercion cc id_pos_list, shape) + else + Ok (Tcoerce_structure (cc, id_pos_list), shape) + | missings, incompatibles, runtime_coercions, leftovers -> + Error { + Error.env=new_env; + missings; + incompatibles; + oks=runtime_coercions; + leftovers; + } + end + | item2 :: rem -> + let (id2, _loc, name2) = item_ident_name item2 in + let name2, report = + match item2, name2 with + Sig_type (_, {type_manifest=None}, _, _), {name=s; kind=Field_type} + when Btype.is_row_name s -> + (* Do not report in case of failure, + as the main type will generate an error *) + { kind=Field_type; name=String.sub s 0 (String.length s - 4) }, + false + | _ -> name2, true + in + begin match FieldMap.find name2 comps1 with + | (id1, item1, pos1) -> + let new_subst = + match item2 with + Sig_type _ -> + Subst.add_type id2 (Path.Pident id1) subst + | Sig_module _ -> + Subst.add_module id2 (Path.Pident id1) subst + | Sig_modtype _ -> + Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst + | Sig_value _ | Sig_typext _ + | Sig_class _ | Sig_class_type _ -> + subst + in + pair_components ~core new_subst + ((item1, item2, pos1) :: paired) unpaired rem + | exception Not_found -> + let unpaired = + if report then + item2 :: unpaired + else unpaired in + pair_components ~core subst paired unpaired rem + end in + (* Do the pairing and checking, and return the final coercion *) + pair_components ~core subst [] [] sig2 + +(* Inclusion between signature components *) + +and signature_components ~core ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map paired = + match paired with + | [] -> Sign_diff.{ empty with shape_map } + | (sigi1, sigi2, pos) :: rem -> + let shape_modified = ref false in + let id, item, shape_map, present_at_runtime = + match sigi1, sigi2 with + | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) -> + let item = + core.value_descriptions ~loc env ~mark subst id1 + valdecl1 valdecl2 + in + let item = mark_error_as_recoverable item in + let present_at_runtime = match valdecl2.val_kind with + | Val_prim _ -> false + | _ -> true + in + let shape_map = Shape.Map.add_value_proj shape_map id1 orig_shape in + id1, item, shape_map, present_at_runtime + | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) -> + let item = + core.type_declarations ~loc env ~mark subst id1 tydec1 tydec2 + in + let item = mark_error_as_unrecoverable item in + (* Right now we don't filter hidden constructors / labels from the + shape. *) + let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in + id1, item, shape_map, false + | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> + let item = + core.extension_constructors ~loc env ~mark subst id1 ext1 ext2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_extcons_proj shape_map id1 orig_shape + in + id1, item, shape_map, true + | Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _) + -> begin + let orig_shape = + Shape.(proj orig_shape (Item.module_ id1)) + in + let item = + module_declarations ~core ~in_eq ~loc env ~mark subst id1 + mty1 mty2 orig_shape + in + let item, shape_map = + match item with + | Ok (cc, shape) -> + if shape != orig_shape then shape_modified := true; + let mod_shape = Shape.set_uid_if_none shape mty1.md_uid in + Ok cc, Shape.Map.add_module shape_map id1 mod_shape + | Error diff -> + Error (Error.Module_type diff), + (* We add the original shape to the map, even though + there is a type error. + It could still be useful for merlin. *) + Shape.Map.add_module shape_map id1 orig_shape + in + let present_at_runtime, item = + match pres1, pres2, mty1.md_type with + | Mp_present, Mp_present, _ -> true, item + | _, Mp_absent, _ -> false, item + | Mp_absent, Mp_present, Mty_alias p1 -> + true, Result.map (fun i -> Tcoerce_alias (env, p1, i)) item + | Mp_absent, Mp_present, _ -> assert false + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, present_at_runtime + end + | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> + let item = + modtype_infos ~core ~in_eq ~loc env ~mark subst id1 info1 info2 + in + let shape_map = + Shape.Map.add_module_type_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, false + | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> + let item = + core.class_declarations ~loc env ~mark subst id1 decl1 decl2 + in + let shape_map = + Shape.Map.add_class_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, true + | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> + let item = + core.class_type_declarations ~loc env ~mark subst id1 info1 info2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_class_type_proj shape_map id1 orig_shape + in + id1, item, shape_map, false + | _ -> + assert false + in + let deep_modifications = !shape_modified in + let first = + match item with + | Ok x -> + let runtime_coercions = + if present_at_runtime then [pos,x] else [] + in + Sign_diff.{ empty with deep_modifications; runtime_coercions } + | Error { error; recoverable=_ } -> + Sign_diff.{ empty with errors=[id,error]; deep_modifications } + in + let continue = match item with + | Ok _ -> true + | Error x -> x.recoverable + in + let rest = + if continue then + signature_components ~core ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map rem + else Sign_diff.{ empty with leftovers=rem } + in + Sign_diff.merge first rest + +and module_declarations ~in_eq ~loc env ~mark subst id1 md1 md2 orig_shape = + Builtin_attributes.check_alerts_inclusion + ~def:md1.md_loc + ~use:md2.md_loc + loc + md1.md_attributes md2.md_attributes + (Ident.name id1); + let p1 = Path.Pident id1 in + if mark_positive mark then + Env.mark_module_used md1.md_uid; + strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark subst + md1.md_type p1 md2.md_type orig_shape + +(* Inclusion between module type specifications *) + +and modtype_infos ~core ~in_eq ~loc env ~mark subst id info1 info2 = + Builtin_attributes.check_alerts_inclusion + ~def:info1.mtd_loc + ~use:info2.mtd_loc + loc + info1.mtd_attributes info2.mtd_attributes + (Ident.name id); + let info2 = Subst.modtype_declaration Keep subst info2 in + let r = + match (info1.mtd_type, info2.mtd_type) with + (None, None) -> Ok Tcoerce_none + | (Some _, None) -> Ok Tcoerce_none + | (Some mty1, Some mty2) -> + check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 + | (None, Some mty2) -> + let mty1 = Mty_ident(Path.Pident id) in + check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 in + match r with + | Ok _ as ok -> ok + | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e)) + +and check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 = + let c1 = + modtypes ~core ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 + Shape.dummy_mod + in + let c2 = + (* For nested module type paths, we check only one side of the equivalence: + the outer module type is the one responsible for checking the other side + of the equivalence. + *) + if in_eq then None + else + let mark = negate_mark mark in + Some ( + modtypes ~core ~in_eq:true ~loc env ~mark Subst.identity + mty2 mty1 Shape.dummy_mod + ) + in + match c1, c2 with + | Ok (Tcoerce_none, _), (Some Ok (Tcoerce_none, _)|None) -> Ok Tcoerce_none + | Ok (c1, _), (Some Ok _ | None) -> + (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." + print_coercion _c1 print_coercion _c2; *) + Error Error.(Illegal_permutation c1) + | Ok _, Some Error e -> Error Error.(Not_greater_than e) + | Error e, (Some Ok _ | None) -> Error Error.(Not_less_than e) + | Error less_than, Some Error greater_than -> + Error Error.(Incomparable {less_than; greater_than}) + + +(* Simplified inclusion check between module types (for Env) *) + +let can_alias env path = + let rec no_apply = function + | Path.Pident _ -> true + | Path.Pdot(p, _) | Path.Pextra_ty (p, _) -> no_apply p + | Path.Papply _ -> false + in + no_apply path && not (Env.is_functor_arg path env) + +let core_inclusion = Core_inclusion.{ + type_declarations; + value_descriptions; + extension_constructors; + class_type_declarations; + class_declarations; +} + +let core_consistency = + let type_declarations ~loc:_ env ~mark:_ _ _ d1 d2 = + match Includecore.type_declarations_consistency env d1 d2 with + | None -> Ok Tcoerce_none + | Some err -> Error Error.(Core(Type_declarations (diff d1 d2 err))) + in + let value_descriptions ~loc:_ env ~mark:_ _ _ vd1 vd2 = + match Includecore.value_descriptions_consistency env vd1 vd2 with + | x -> Ok x + | exception Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) + in + let accept ~loc:_ _env ~mark:_ _subst _id _d1 _d2 = Ok Tcoerce_none in + { + type_declarations; + value_descriptions; + class_declarations=accept; + class_type_declarations=accept; + extension_constructors=accept; + } + +type explanation = Env.t * Error.all +exception Error of explanation + +type application_name = + | Anonymous_functor + | Full_application_path of Longident.t + | Named_leftmost_functor of Longident.t +exception Apply_error of { + loc : Location.t ; + env : Env.t ; + app_name : application_name ; + mty_f : module_type ; + args : (Error.functor_arg_descr * module_type) list ; + } + +let check_modtype_inclusion_raw ~loc env mty1 path1 mty2 = + let aliasable = can_alias env path1 in + strengthened_modtypes ~core:core_inclusion ~in_eq:false ~loc ~aliasable env + ~mark:Mark_both Subst.identity mty1 path1 mty2 Shape.dummy_mod + |> Result.map fst + +let check_modtype_inclusion ~loc env mty1 path1 mty2 = + match check_modtype_inclusion_raw ~loc env mty1 path1 mty2 with + | Ok _ -> None + | Error e -> Some (env, Error.In_Module_type e) + +let check_functor_application_in_path + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~arg_path ~arg_mty ~param_mty env = + match check_modtype_inclusion_raw ~loc env arg_mty arg_path param_mty with + | Ok _ -> () + | Error _errs -> + if errors then + let prepare_arg (arg_path, arg_mty) = + let aliasable = can_alias env arg_path in + let smd = Mtype.strengthen ~aliasable env arg_mty arg_path in + (Error.Named arg_path, smd) + in + let mty_f = (Env.find_module f0_path env).md_type in + let args = List.map prepare_arg args in + let app_name = Full_application_path lid_whole_app in + raise (Apply_error {loc; env; app_name; mty_f; args}) + else + raise Not_found + +let () = + Env.check_functor_application := check_functor_application_in_path + + +(* Check that an implementation of a compilation unit meets its + interface. *) + +let compunit env ~mark impl_name impl_sig intf_name intf_sig unit_shape = + let loc = Location.in_file impl_name in + match + signatures ~core:core_inclusion ~in_eq:false ~loc env + ~mark Subst.identity impl_sig intf_sig unit_shape + with Result.Error reasons -> + let cdiff = + Error.In_Compilation_unit(Error.diff impl_name intf_name reasons) in + raise(Error(env, cdiff)) + | Ok x -> x + +(* Functor diffing computation: + The diffing computation uses the internal typing function + *) + +module Functor_inclusion_diff = struct + + module Defs = struct + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state = { + res: module_type option; + env: Env.t; + subst: Subst.t; + } + end + open Defs + + module Diff = Diffing.Define(Defs) + + let param_name = function + | Named(x,_) -> x + | Unit -> None + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Change _ -> 10 + | Keep (param1, param2, _) -> begin + match param_name param1, param_name param2 with + | None, None + -> 0 + | Some n1, Some n2 + when String.equal (Ident.name n1) (Ident.name n2) + -> 0 + | Some _, Some _ -> 1 + | Some _, None | None, Some _ -> 1 + end + + + + let keep_expansible_param = function + | Mty_ident _ | Mty_alias _ as mty -> Some mty + | Mty_signature _ | Mty_functor _ -> None + + let lookup_expansion { env ; res ; _ } = match res with + | None -> None + | Some res -> + match retrieve_functor_params env res with + | [], _ -> None + | params, res -> + let more = Array.of_list params in + Some (keep_expansible_param res, more) + + let expand_params state = + match lookup_expansion state with + | None -> state, [||] + | Some (res, expansion) -> { state with res }, expansion + + (* Whenever we have a named parameter that doesn't match it anonymous + counterpart, we add it to the typing environment because it may + contain useful abbreviations, but without adding any equations *) + let bind id arg state = + let arg' = Subst.modtype Keep state.subst arg in + let env = Env.add_module id Mp_present arg' state.env in + { state with env } + + let rec update (d:Diff.change) st = + match d with + | Insert (Unit | Named (None,_)) + | Delete (Unit | Named (None,_)) + | Keep (Unit,_,_) + | Keep (_,Unit,_) -> + (* No named abstract parameters: we keep the same environment *) + st, [||] + | Insert (Named (Some id, arg)) | Delete (Named (Some id, arg)) -> + (* one named parameter to bind *) + st |> bind id arg |> expand_params + | Change (delete, insert, _) -> + (* Change should be delete + insert: we add both abstract parameters + to the environment without equating them. *) + let st, _expansion = update (Diffing.Delete delete) st in + update (Diffing.Insert insert) st + | Keep (Named (name1, _), Named (name2, arg2), _) -> + let arg = Subst.modtype Keep st.subst arg2 in + let env, subst = + equate_one_functor_param st.subst st.env arg name1 name2 + in + expand_params { st with env; subst } + + let diff env (l1,res1) (l2,_) = + let module Compute = Diff.Left_variadic(struct + let test st mty1 mty2 = + let loc = Location.none in + let res, _, _ = + functor_param ~core:core_inclusion ~in_eq:false ~loc st.env + ~mark:Mark_neither st.subst mty1 mty2 + in + res + let update = update + let weight = weight + end) + in + let param1 = Array.of_list l1 in + let param2 = Array.of_list l2 in + let state = + { env; subst = Subst.identity; res = keep_expansible_param res1} + in + Compute.diff state param1 param2 + +end + +module Functor_app_diff = struct + module I = Functor_inclusion_diff + module Defs= struct + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state = I.Defs.state + end + module Diff = Diffing.Define(Defs) + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Change _ -> 10 + | Keep (param1, param2, _) -> + (* We assign a small penalty to named arguments with + non-matching names *) + begin + let desc1 : Error.functor_arg_descr = fst param1 in + match desc1, I.param_name param2 with + | (Unit | Empty_struct | Anonymous) , None + -> 0 + | Named (Path.Pident n1), Some n2 + when String.equal (Ident.name n1) (Ident.name n2) + -> 0 + | Named _, Some _ -> 1 + | Named _, None | (Unit | Empty_struct | Anonymous), Some _ -> 1 + end + + let update (d: Diff.change) (st:Defs.state) = + let open Error in + match d with + | Insert (Unit|Named(None,_)) + | Delete _ (* delete is a concrete argument, not an abstract parameter*) + | Keep ((Unit,_),_,_) (* Keep(Unit,_) implies Keep(Unit,Unit) *) + | Keep (_,(Unit|Named(None,_)),_) + | Change (_,(Unit|Named (None,_)), _ ) -> + (* no abstract parameters to add, nor any equations *) + st, [||] + | Insert(Named(Some param, param_ty)) + | Change(_, Named(Some param, param_ty), _ ) -> + (* Change is Delete + Insert: we add the Inserted parameter to the + environment to track equalities with external components that the + parameter might add. *) + let mty = Subst.modtype Keep st.subst param_ty in + let env = Env.add_module ~arg:true param Mp_present mty st.env in + I.expand_params { st with env } + | Keep ((Named arg, _mty) , Named (Some param, _param), _) -> + let res = + Option.map (fun res -> + let scope = Ctype.create_scope () in + let subst = Subst.add_module param arg Subst.identity in + Subst.modtype (Rescope scope) subst res + ) + st.res + in + let subst = Subst.add_module param arg st.subst in + I.expand_params { st with subst; res } + | Keep (((Anonymous|Empty_struct), mty), + Named (Some param, _param), _) -> + let mty' = Subst.modtype Keep st.subst mty in + let env = Env.add_module ~arg:true param Mp_present mty' st.env in + let res = Option.map (Mtype.nondep_supertype env [param]) st.res in + I.expand_params { st with env; res} + + let diff env ~f ~args = + let params, res = retrieve_functor_params env f in + let module Compute = Diff.Right_variadic(struct + let update = update + let test (state:Defs.state) (arg,arg_mty) param = + let loc = Location.none in + let res = match (arg:Error.functor_arg_descr), param with + | (Unit|Empty_struct), Unit -> Ok Tcoerce_none + | Unit, Named _ | (Anonymous | Named _), Unit -> + Result.Error (Error.Incompatible_params(arg,param)) + | ( Anonymous | Named _ | Empty_struct ), Named (_, param) -> + match + modtypes ~core:core_inclusion ~in_eq:false ~loc state.env + ~mark:Mark_neither state.subst arg_mty param + Shape.dummy_mod + with + | Error mty -> Result.Error (Error.Mismatch mty) + | Ok (cc, _) -> Ok cc + in + res + let weight = weight + end) + in + let args = Array.of_list args in + let params = Array.of_list params in + let state : Defs.state = + { env; subst = Subst.identity; res = I.keep_expansible_param res } + in + Compute.diff state args params + +end + +(* Hide the context and substitution parameters to the outside world *) + +let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 = + match modtypes ~core:core_inclusion ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 shape + with + | Ok (cc, shape) -> cc, shape + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let modtypes_consistency ~loc env mty1 mty2 = + match modtypes ~core:core_consistency ~in_eq:false ~loc env ~mark:Mark_neither + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok _ -> () + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let modtypes ~loc env ~mark mty1 mty2 = + match modtypes ~core:core_inclusion ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let signatures env ~mark sig1 sig2 = + match signatures ~core:core_inclusion ~in_eq:false ~loc:Location.none env + ~mark Subst.identity sig1 sig2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error(env,Error.(In_Signature reason))) + +let type_declarations ~loc env ~mark id decl1 decl2 = + match Core_inclusion.type_declarations ~loc env ~mark + Subst.identity id decl1 decl2 + with + | Ok _ -> () + | Error (Error.Core reason) -> + raise (Error(env,Error.(In_Type_declaration(id,reason)))) + | Error _ -> assert false + +let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 = + match strengthened_module_decl ~core:core_inclusion ~loc ~aliasable env ~mark + Subst.identity md1 path1 md2 Shape.dummy_mod with + | Ok (x, _shape) -> x + | Error mdiff -> + raise (Error(env,Error.(In_Module_type mdiff))) + +let expand_module_alias ~strengthen env path = + match expand_module_alias ~strengthen env path with + | Ok x -> x + | Result.Error _ -> + raise (Error(env,In_Expansion(Error.Unbound_module_path path))) + +let check_modtype_equiv ~loc env id mty1 mty2 = + match check_modtype_equiv ~core:core_inclusion ~in_eq:false ~loc env + ~mark:Mark_both mty1 mty2 + with + | Ok _ -> () + | Error e -> + raise (Error(env, + Error.(In_Module_type_substitution (id,diff mty1 mty2 e))) + ) diff --git a/upstream/ocaml_503/typing/includemod.mli b/upstream/ocaml_503/typing/includemod.mli new file mode 100644 index 000000000..d0e04178b --- /dev/null +++ b/upstream/ocaml_503/typing/includemod.mli @@ -0,0 +1,265 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the module language *) + +open Typedtree +open Types + +(** Type describing which arguments of an inclusion to consider as used + for the usage warnings. [Mark_both] is the default. *) +type mark = + | Mark_both + (** Mark definitions used from both arguments *) + | Mark_positive + (** Mark definitions used from the positive (first) argument *) + | Mark_negative + (** Mark definitions used from the negative (second) argument *) + | Mark_neither + (** Do not mark definitions used from either argument *) + +module Error: sig + + type ('elt,'explanation) diff = { + got:'elt; + expected:'elt; + symptom:'explanation + } + type 'elt core_diff =('elt,unit) diff + + type functor_arg_descr = + | Anonymous + | Named of Path.t + | Unit + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module. *) + + type core_sigitem_symptom = + | Value_descriptions of + (Types.value_description, Includecore.value_mismatch) diff + | Type_declarations of + (Types.type_declaration, Includecore.type_mismatch) diff + | Extension_constructors of + (Types.extension_constructor, + Includecore.extension_constructor_mismatch) diff + | Class_type_declarations of + (Types.class_type_declaration, Ctype.class_match_failure list) diff + | Class_declarations of + (Types.class_declaration, Ctype.class_match_failure list) diff + + type core_module_type_symptom = + | Not_an_alias + | Not_an_identifier + | Incompatible_aliases + | Abstract_module_type + | Unbound_module_path of Path.t + + type module_type_symptom = + | Mt_core of core_module_type_symptom + | Signature of signature_symptom + | Functor of functor_symptom + | Invalid_module_alias of Path.t + | After_alias_expansion of module_type_diff + + + and module_type_diff = (Types.module_type, module_type_symptom) diff + + and functor_symptom = + | Params of functor_params_diff + | Result of module_type_diff + + and ('arg,'path) functor_param_symptom = + | Incompatible_params of 'arg * Types.functor_parameter + | Mismatch of module_type_diff + + and arg_functor_param_symptom = + (Types.functor_parameter, Ident.t) functor_param_symptom + + and functor_params_diff = + (Types.functor_parameter list * Types.module_type) core_diff + + and signature_symptom = { + env: Env.t; + missings: Types.signature_item list; + incompatibles: (Ident.t * sigitem_symptom) list; + oks: (int * Typedtree.module_coercion) list; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + (** signature items that could not be compared due to type divergence *) + } + and sigitem_symptom = + | Core of core_sigitem_symptom + | Module_type_declaration of + (Types.modtype_declaration, module_type_declaration_symptom) diff + | Module_type of module_type_diff + + and module_type_declaration_symptom = + | Illegal_permutation of Typedtree.module_coercion + | Not_greater_than of module_type_diff + | Not_less_than of module_type_diff + | Incomparable of + {less_than:module_type_diff; greater_than: module_type_diff} + + + type all = + | In_Compilation_unit of (string, signature_symptom) diff + | In_Signature of signature_symptom + | In_Module_type of module_type_diff + | In_Module_type_substitution of + Ident.t * (Types.module_type,module_type_declaration_symptom) diff + | In_Type_declaration of Ident.t * core_sigitem_symptom + | In_Expansion of core_module_type_symptom +end +type explanation = Env.t * Error.all + +(* Extract name, kind and ident from a signature item *) +type field_kind = + | Field_value + | Field_type + | Field_exception + | Field_typext + | Field_module + | Field_modtype + | Field_class + | Field_classtype + +type field_desc = { name: string; kind: field_kind } + +val kind_of_field_desc: field_desc -> string +val field_desc: field_kind -> Ident.t -> field_desc + +(** Map indexed by both field types and names. + This avoids name clashes between different sorts of fields + such as values and types. *) +module FieldMap: Map.S with type key = field_desc + +val item_ident_name: Types.signature_item -> Ident.t * Location.t * field_desc +val is_runtime_component: Types.signature_item -> bool + + +(* Typechecking *) + +val modtypes: + loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion + + +val modtypes_consistency: + loc:Location.t -> Env.t -> module_type -> module_type -> unit + +val modtypes_with_shape: + shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion * Shape.t + +val strengthened_module_decl: + loc:Location.t -> aliasable:bool -> Env.t -> mark:mark -> + module_declaration -> Path.t -> module_declaration -> module_coercion + +val check_modtype_inclusion : + loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type -> + explanation option +(** [check_modtype_inclusion ~loc env mty1 path1 mty2] checks that the + functor application F(M) is well typed, where mty2 is the type of + the argument of F and path1/mty1 is the path/unstrenghened type of M. *) + +val check_modtype_equiv: + loc:Location.t -> Env.t -> Ident.t -> module_type -> module_type -> unit + +val signatures: Env.t -> mark:mark -> + signature -> signature -> module_coercion + +val compunit: + Env.t -> mark:mark -> string -> signature -> + string -> signature -> Shape.t -> module_coercion * Shape.t + +val type_declarations: + loc:Location.t -> Env.t -> mark:mark -> + Ident.t -> type_declaration -> type_declaration -> unit + +val print_coercion: Format.formatter -> module_coercion -> unit + +type symptom = + Missing_field of Ident.t * Location.t * string (* kind *) + | Value_descriptions of + Ident.t * value_description * value_description + * Includecore.value_mismatch + | Type_declarations of Ident.t * type_declaration + * type_declaration * Includecore.type_mismatch + | Extension_constructors of Ident.t * extension_constructor + * extension_constructor * Includecore.extension_constructor_mismatch + | Module_types of module_type * module_type + | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration + | Modtype_permutation of Types.module_type * Typedtree.module_coercion + | Interface_mismatch of string * string + | Class_type_declarations of + Ident.t * class_type_declaration * class_type_declaration * + Ctype.class_match_failure list + | Class_declarations of + Ident.t * class_declaration * class_declaration * + Ctype.class_match_failure list + | Unbound_module_path of Path.t + | Invalid_module_alias of Path.t + +type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of functor_parameter + | Body of functor_parameter + +exception Error of explanation + +type application_name = + | Anonymous_functor (** [(functor (_:sig end) -> struct end)(Int)] *) + | Full_application_path of Longident.t (** [F(G(X).P)(Y)] *) + | Named_leftmost_functor of Longident.t (** [F(struct end)...(...)] *) + +exception Apply_error of { + loc : Location.t ; + env : Env.t ; + app_name : application_name ; + mty_f : module_type ; + args : (Error.functor_arg_descr * Types.module_type) list ; + } + +val expand_module_alias: strengthen:bool -> Env.t -> Path.t -> Types.module_type + +module Functor_inclusion_diff: sig + module Defs: sig + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state + end + val diff: Env.t -> + Types.functor_parameter list * Types.module_type -> + Types.functor_parameter list * Types.module_type -> + Diffing.Define(Defs).patch +end + +module Functor_app_diff: sig + module Defs: sig + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state + end + val diff: + Env.t -> + f:Types.module_type -> + args:(Error.functor_arg_descr * Types.module_type) list -> + Diffing.Define(Defs).patch +end diff --git a/upstream/ocaml_503/typing/includemod_errorprinter.ml b/upstream/ocaml_503/typing/includemod_errorprinter.ml new file mode 100644 index 000000000..fd74a073a --- /dev/null +++ b/upstream/ocaml_503/typing/includemod_errorprinter.ml @@ -0,0 +1,1045 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Style = Misc.Style +module Fmt = Format_doc +module Printtyp = Printtyp.Doc + +module Context = struct + type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of Types.functor_parameter + | Body of Types.functor_parameter + + let path_of_context = function + Module id :: rem -> + let rec subm path = function + | [] -> path + | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem + | _ -> assert false + in subm (Path.Pident id) rem + | _ -> assert false + + + let rec context ppf = function + Module id :: rem -> + Fmt.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem + | Modtype id :: rem -> + Fmt.fprintf ppf "@[<2>module type %a =@ %a@]" + Printtyp.ident id context_mty rem + | Body x :: rem -> + Fmt.fprintf ppf "(%s) ->@ %a" (argname x) context_mty rem + | Arg x :: rem -> + Fmt.fprintf ppf "(%s : %a) -> ..." + (argname x) context_mty rem + | [] -> + Fmt.fprintf ppf "" + and context_mty ppf = function + (Module _ | Modtype _) :: _ as rem -> + Fmt.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + | cxt -> context ppf cxt + and args ppf = function + Body x :: rem -> + Fmt.fprintf ppf "(%s)%a" (argname x) args rem + | Arg x :: rem -> + Fmt.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem + | cxt -> + Fmt.fprintf ppf " :@ %a" context_mty cxt + and argname = function + | Types.Unit -> "" + | Types.Named (None, _) -> "_" + | Types.Named (Some id, _) -> Ident.name id + + let alt_pp ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + Fmt.fprintf ppf ",@ in module %a" + (Style.as_inline_code Printtyp.path) (path_of_context cxt) + else + Fmt.fprintf ppf ",@ @[at position@ %a@]" + (Style.as_inline_code context) cxt + + let pp ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + Fmt.fprintf ppf "In module %a:@ " + (Style.as_inline_code Printtyp.path) (path_of_context cxt) + else + Fmt.fprintf ppf "@[At position@ %a@]@ " + (Style.as_inline_code context) cxt +end + +module Runtime_coercion = struct + (** Extraction of a small change from a non-identity runtime coercion *) + + (** When examining coercions, we only have runtime component indices, + we use thus a limited version of {!pos}. *) + type coerce_pos = + | Item of int + | InArg + | InBody + + let either f x g y = match f x with + | None -> g y + | Some _ as v -> v + + type change = + | Transposition of int * int + | Primitive_coercion of string + | Alias_coercion of Path.t + + (** We extract a small change from a full coercion. *) + let rec first_change_under path (coerc:Typedtree.module_coercion) = + match coerc with + | Tcoerce_structure(c,_) -> + either + (first_item_transposition path 0) c + (first_non_id path 0) c + | Tcoerce_functor(arg,res) -> + either + (first_change_under (InArg::path)) arg + (first_change_under (InBody::path)) res + | Tcoerce_none -> None + | Tcoerce_alias _ | Tcoerce_primitive _ -> None + + (* we search the first point which is not invariant at the current level *) + and first_item_transposition path pos = function + | [] -> None + | (n, _) :: q -> + if n < 0 || n = pos then + (* when n < 0, this is not a transposition but a kind coercion, + which will be covered in the first_non_id case *) + first_item_transposition path (pos+1) q + else + Some(List.rev path, Transposition (pos, n)) + (* we search the first item with a non-identity inner coercion *) + and first_non_id path pos = function + | [] -> None + | (_, Typedtree.Tcoerce_none) :: q -> first_non_id path (pos + 1) q + | (_, Typedtree.Tcoerce_alias (_,p,_)) :: _ -> + Some (List.rev path, Alias_coercion p) + | (_, Typedtree.Tcoerce_primitive p) :: _ -> + let name = Primitive.byte_name p.pc_desc in + Some (List.rev path, Primitive_coercion name) + | (_,c) :: q -> + either + (first_change_under (Item pos :: path)) c + (first_non_id path (pos + 1)) q + + let first_change c = first_change_under [] c + + let rec runtime_item k = function + | [] -> raise Not_found + | item :: q -> + if not(Includemod.is_runtime_component item) then + runtime_item k q + else if k = 0 then + item + else + runtime_item (k-1) q + + (* Find module type at position [path] and convert the [coerce_pos] path to + a [pos] path *) + let rec find env ctx path (mt:Types.module_type) = match mt, path with + | (Mty_ident p | Mty_alias p), _ -> + begin match (Env.find_modtype p env).mtd_type with + | None -> raise Not_found + | Some mt -> find env ctx path mt + end + | Mty_signature s , [] -> List.rev ctx, s + | Mty_signature s, Item k :: q -> + begin match runtime_item k s with + | Sig_module (id, _, md,_,_) -> + find env (Context.Module id :: ctx) q md.md_type + | _ -> raise Not_found + end + | Mty_functor(Named (_,mt) as arg,_), InArg :: q -> + find env (Context.Arg arg :: ctx) q mt + | Mty_functor(arg, mt), InBody :: q -> + find env (Context.Body arg :: ctx) q mt + | _ -> raise Not_found + + let find env path mt = find env [] path mt + let item mt k = Includemod.item_ident_name (runtime_item k mt) + + let pp_item ppf (id,_,kind) = + Fmt.fprintf ppf "%s %a" + (Includemod.kind_of_field_desc kind) + Style.inline_code (Ident.name id) + + let illegal_permutation ctx_printer env ppf (mty,c) = + match first_change c with + | None | Some (_, (Primitive_coercion _ | Alias_coercion _)) -> + (* those kind coercions are not inversible, and raise an error earlier + when checking for module type equivalence *) + assert false + | Some (path, Transposition (k,l)) -> + try + let ctx, mt = find env path mty in + Fmt.fprintf ppf + "@[Illegal permutation of runtime components in a module type.@ \ + @[For example%a,@]@ @[the %a@ and the %a are not in the same order@ \ + in the expected and actual module types.@]@]" + ctx_printer ctx pp_item (item mt k) pp_item (item mt l) + with Not_found -> (* this should not happen *) + Fmt.fprintf ppf + "Illegal permutation of runtime components in a module type." + + let in_package_subtype ctx_printer env mty c ppf = + match first_change c with + | None -> + (* The coercion looks like the identity but was not simplified to + [Tcoerce_none], this only happens when the two first-class module + types differ by runtime size *) + Fmt.fprintf ppf + "The two first-class module types differ by their runtime size." + | Some (path, c) -> + try + let ctx, mt = find env path mty in + match c with + | Primitive_coercion prim_name -> + Fmt.fprintf ppf + "@[The two first-class module types differ by a coercion of@ \ + the primitive %a@ to a value%a.@]" + Style.inline_code prim_name + ctx_printer ctx + | Alias_coercion path -> + Fmt.fprintf ppf + "@[The two first-class module types differ by a coercion of@ \ + a module alias %a@ to a module%a.@]" + (Style.as_inline_code Printtyp.path) path + ctx_printer ctx + | Transposition (k,l) -> + Fmt.fprintf ppf + "@[@[The two first-class module types do not share@ \ + the same positions for runtime components.@]@ \ + @[For example,%a@ the %a@ occurs at the expected position of@ \ + the %a.@]@]" + ctx_printer ctx pp_item (item mt k) pp_item (item mt l) + with Not_found -> + Fmt.fprintf ppf + "@[The two packages types do not share@ \ + the@ same@ positions@ for@ runtime@ components.@]" + +end + + + +module Err = Includemod.Error + +let buffer = ref Bytes.empty +let is_big obj = + let size = !Clflags.error_size in + size > 0 && + begin + if Bytes.length !buffer < size then buffer := Bytes.create size; + try ignore (Marshal.to_buffer !buffer 0 size obj []); false + with _ -> true + end + +let show_loc msg ppf loc = + let pos = loc.Location.loc_start in + if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then () + else Fmt.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.Doc.loc loc msg + +let show_locs ppf (loc1, loc2) = + show_loc "Expected declaration" ppf loc2; + show_loc "Actual declaration" ppf loc1 + + +let dmodtype mty = + let tmty = Out_type.tree_of_modtype mty in + Fmt.dprintf "%a" !Oprint.out_module_type tmty + +let space ppf () = Fmt.fprintf ppf "@ " + +(** + In order to display a list of functor arguments in a compact format, + we introduce a notion of shorthand for functor arguments. + The aim is to first present the lists of actual and expected types with + shorthands: + + (X: $S1) (Y: $S2) (Z: An_existing_module_type) ... + does not match + (X: $T1) (Y: A_real_path) (Z: $T3) ... + + and delay the full display of the module types corresponding to $S1, $S2, + $T1, and $T3 to the suberror message. + +*) +module With_shorthand = struct + + (** A item with a potential shorthand name *) + type 'a named = { + item: 'a; + name : string; + } + + type 'a t = + | Original of 'a (** The shorthand has been discarded *) + | Synthetic of 'a named + (** The shorthand is potentially useful *) + + type functor_param = + | Unit + | Named of (Ident.t option * Types.module_type t) + + (** Shorthand generation *) + type kind = + | Got + | Expected + | Unneeded + + type variant = + | App + | Inclusion + + let elide_if_app ctx s = match ctx with + | App -> Unneeded + | Inclusion -> s + + let make side pos = + match side with + | Got -> Fmt.asprintf "$S%d" pos + | Expected -> Fmt.asprintf "$T%d" pos + | Unneeded -> "..." + + (** Add shorthands to a patch *) + open Diffing + let patch ctx p = + let add_shorthand side pos mty = + {name = (make side pos); item = mty } + in + let aux i d = + let pos = i + 1 in + let d = match d with + | Insert mty -> + Insert (add_shorthand Expected pos mty) + | Delete mty -> + Delete (add_shorthand (elide_if_app ctx Got) pos mty) + | Change (g, e, p) -> + Change + (add_shorthand Got pos g, + add_shorthand Expected pos e, p) + | Keep (g, e, p) -> + Keep (add_shorthand Got pos g, + add_shorthand (elide_if_app ctx Expected) pos e, p) + in + pos, d + in + List.mapi aux p + + (** Shorthand computation from named item *) + let modtype (r : _ named) = match r.item with + | Types.Mty_ident _ + | Types.Mty_alias _ + | Types.Mty_signature [] + -> Original r.item + | Types.Mty_signature _ | Types.Mty_functor _ + -> Synthetic r + + let functor_param (ua : _ named) = match ua.item with + | Types.Unit -> Unit + | Types.Named (from, mty) -> + Named (from, modtype { ua with item = mty }) + + (** Printing of arguments with shorthands *) + let pp ppx = function + | Original x -> ppx x + | Synthetic s -> Fmt.dprintf "%s" s.name + + let pp_orig ppx = function + | Original x | Synthetic { item=x; _ } -> ppx x + + let definition x = match functor_param x with + | Unit -> Fmt.dprintf "()" + | Named(_,short_mty) -> + match short_mty with + | Original mty -> dmodtype mty + | Synthetic {name; item = mty} -> + Fmt.dprintf + "%s@ =@ %t" name (dmodtype mty) + + let param x = match functor_param x with + | Unit -> Fmt.dprintf "()" + | Named (_, short_mty) -> + pp dmodtype short_mty + + let qualified_param x = match functor_param x with + | Unit -> Fmt.dprintf "()" + | Named (None, Original (Mty_signature []) ) -> + Fmt.dprintf "(sig end)" + | Named (None, short_mty) -> + pp dmodtype short_mty + | Named (Some p, short_mty) -> + Fmt.dprintf "(%s : %t)" + (Ident.name p) (pp dmodtype short_mty) + + let definition_of_argument ua = + let arg, mty = ua.item in + match (arg: Err.functor_arg_descr) with + | Unit -> Fmt.dprintf "()" + | Empty_struct -> Fmt.dprintf "(struct end)" + | Named p -> + let mty = modtype { ua with item = mty } in + Fmt.dprintf + "%a@ :@ %t" + Printtyp.path p + (pp_orig dmodtype mty) + | Anonymous -> + let short_mty = modtype { ua with item = mty } in + begin match short_mty with + | Original mty -> dmodtype mty + | Synthetic {name; item=mty} -> + Fmt.dprintf "%s@ :@ %t" name (dmodtype mty) + end + + let arg ua = + let arg, mty = ua.item in + match (arg: Err.functor_arg_descr) with + | Unit -> Fmt.dprintf "()" + | Empty_struct -> Fmt.dprintf "(struct end)" + | Named p -> fun ppf -> Printtyp.path ppf p + | Anonymous -> + let short_mty = modtype { ua with item=mty } in + pp dmodtype short_mty + +end + + +module Functor_suberror = struct + open Err + + let param_id x = match x.With_shorthand.item with + | Types.Named (Some _ as x,_) -> x + | Types.(Unit | Named(None,_)) -> None + + +(** Print a list of functor parameters with style while adjusting the printing + environment for each functor argument. + + Currently, we are disabling disambiguation for functor argument name to + avoid the need to track the moving association between identifiers and + syntactic names in situation like: + + got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T) + expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T) +*) + let pretty_params sep proj printer patch = + let pp_param (x,param) = + let sty = Diffing.(style @@ classify x) in + Fmt.dprintf "%a%t%a" + Fmt.pp_open_stag (Style.Style sty) + (printer param) + Fmt.pp_close_stag () + in + let rec pp_params = function + | [] -> ignore + | [_,param] -> pp_param param + | (id,param) :: q -> + Fmt.dprintf "%t%a%t" + (pp_param param) sep () (hide_id id q) + and hide_id id q = + match id with + | None -> pp_params q + | Some id -> Out_type.Ident_names.with_fuzzy id (fun () -> pp_params q) + in + let params = List.filter_map proj @@ List.map snd patch in + pp_params params + + let expected d = + let extract: _ Diffing.change -> _ = function + | Insert mty + | Keep(_,mty,_) + | Change (_,mty,_) as x -> + Some (param_id mty,(x, mty)) + | Delete _ -> None + in + pretty_params space extract With_shorthand.qualified_param d + + let drop_inserted_suffix patch = + let rec drop = function + | Diffing.Insert _ :: q -> drop q + | rest -> List.rev rest in + drop (List.rev patch) + + let prepare_patch ~drop ~ctx patch = + let drop_suffix x = if drop then drop_inserted_suffix x else x in + patch |> drop_suffix |> With_shorthand.patch ctx + + + module Inclusion = struct + + let got d = + let extract: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (param_id mty,(x,mty)) + | Insert _ -> None + in + pretty_params space extract With_shorthand.qualified_param d + + let insert mty = + Fmt.dprintf + "An argument appears to be missing with module type@;<1 2>@[%t@]" + (With_shorthand.definition mty) + + let delete mty = + Fmt.dprintf + "An extra argument is provided of module type@;<1 2>@[%t@]" + (With_shorthand.definition mty) + + let ok x y = + Fmt.dprintf + "Module types %t and %t match" + (With_shorthand.param x) + (With_shorthand.param y) + + let diff g e more = + let g = With_shorthand.definition g in + let e = With_shorthand.definition e in + Fmt.dprintf + "Module types do not match:@ @[%t@]@;<1 -2>does not include@ \ + @[%t@]%t" + g e (more ()) + + let incompatible = function + | Types.Unit -> + Fmt.dprintf + "The functor was expected to be applicative at this position" + | Types.Named _ -> + Fmt.dprintf + "The functor was expected to be generative at this position" + + let patch env got expected = + Includemod.Functor_inclusion_diff.diff env got expected + |> prepare_patch ~drop:false ~ctx:Inclusion + + end + + module App = struct + + let patch env ~f ~args = + Includemod.Functor_app_diff.diff env ~f ~args + |> prepare_patch ~drop:true ~ctx:App + + let got d = + let extract: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (None,(x,mty)) + | Insert _ -> None + in + pretty_params space extract With_shorthand.arg d + + let delete mty = + Fmt.dprintf + "The following extra argument is provided@;<1 2>@[%t@]" + (With_shorthand.definition_of_argument mty) + + let insert = Inclusion.insert + + let ok x y = + let pp_orig_name = match With_shorthand.functor_param y with + | With_shorthand.Named (_, Original mty) -> + Fmt.dprintf " %t" (dmodtype mty) + | _ -> ignore + in + Fmt.dprintf + "Module %t matches the expected module type%t" + (With_shorthand.arg x) + pp_orig_name + + let diff g e more = + let g = With_shorthand.definition_of_argument g in + let e = With_shorthand.definition e in + Fmt.dprintf + "Modules do not match:@ @[%t@]@;<1 -2>\ + is not included in@ @[%t@]%t" + g e (more ()) + + (** Specialized to avoid introducing shorthand names + for single change difference + *) + let single_diff g e more = + let _arg, mty = g.With_shorthand.item in + let e = match e.With_shorthand.item with + | Types.Unit -> Fmt.dprintf "()" + | Types.Named(_, mty) -> dmodtype mty + in + Fmt.dprintf + "Modules do not match:@ @[%t@]@;<1 -2>\ + is not included in@ @[%t@]%t" + (dmodtype mty) e (more ()) + + + let incompatible = function + | Unit -> + Fmt.dprintf + "The functor was expected to be applicative at this position" + | Named _ | Anonymous -> + Fmt.dprintf + "The functor was expected to be generative at this position" + | Empty_struct -> + (* an empty structure can be used in both applicative and generative + context *) + assert false + end + + let subcase sub ~expansion_token env (pos, diff) = + Location.msg "%a%a%a%a@[%t@]%a" + Fmt.pp_print_tab () + Fmt.pp_open_tbox () + Diffing.prefix (pos, Diffing.classify diff) + Fmt.pp_set_tab () + (Printtyp.wrap_printing_env env ~error:true + (fun () -> sub ~expansion_token env diff) + ) + Fmt.pp_close_tbox () + + let onlycase sub ~expansion_token env (_, diff) = + Location.msg "%a@[%t@]" + Fmt.pp_print_tab () + (Printtyp.wrap_printing_env env ~error:true + (fun () -> sub ~expansion_token env diff) + ) + + let params sub ~expansion_token env l = + let rec aux subcases = function + | [] -> subcases + | (_, Diffing.Keep _) as a :: q -> + aux (subcase sub ~expansion_token env a :: subcases) q + | a :: q -> + List.fold_left (fun acc x -> + (subcase sub ~expansion_token:false env x) :: acc + ) + (subcase sub ~expansion_token env a :: subcases) + q + in + match l with + | [a] -> [onlycase sub ~expansion_token env a] + | l -> aux [] l +end + + +(** Construct a linear presentation of the error tree *) + +open Err + +(* Context helper functions *) +let with_context ?loc ctx printer diff = + Location.msg ?loc "%a%a" Context.pp (List.rev ctx) + printer diff + +let dwith_context ?loc ctx printer = + Location.msg ?loc "%a%t" Context.pp (List.rev ctx) printer + +let dwith_context_and_elision ?loc ctx printer diff = + if is_big (diff.got,diff.expected) then + Location.msg ?loc "..." + else + dwith_context ?loc ctx (printer diff) + +(* Merge sub msgs into one printer *) +let coalesce msgs = + match List.rev msgs with + | [] -> ignore + | before -> + let ctx ppf = + Fmt.pp_print_list ~pp_sep:space + (fun ppf x -> Fmt.pp_doc ppf x.Location.txt) + ppf before in + ctx + +let subcase_list l ppf = match l with + | [] -> () + | _ :: _ -> + let pp_msg ppf lmsg = Fmt.pp_doc ppf lmsg.Location.txt in + Fmt.fprintf ppf "@;<1 -2>@[%a@]" + (Fmt.pp_print_list ~pp_sep:space pp_msg) + (List.rev l) + +(* Printers for leaves *) +let core env id x = + match x with + | Err.Value_descriptions diff -> + Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" + "Values do not match" + !Oprint.out_sig_item + (Out_type.tree_of_value_description id diff.got) + "is not included in" + !Oprint.out_sig_item + (Out_type.tree_of_value_description id diff.expected) + (Includecore.report_value_mismatch + "the first" "the second" env) diff.symptom + show_locs (diff.got.val_loc, diff.expected.val_loc) + | Err.Type_declarations diff -> + Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" + "Type declarations do not match" + !Oprint.out_sig_item + (Out_type.tree_of_type_declaration id diff.got Trec_first) + "is not included in" + !Oprint.out_sig_item + (Out_type.tree_of_type_declaration id diff.expected Trec_first) + (Includecore.report_type_mismatch + "the first" "the second" "declaration" env) diff.symptom + show_locs (diff.got.type_loc, diff.expected.type_loc) + | Err.Extension_constructors diff -> + Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]" + "Extension declarations do not match" + !Oprint.out_sig_item + (Out_type.tree_of_extension_constructor id diff.got Text_first) + "is not included in" + !Oprint.out_sig_item + (Out_type.tree_of_extension_constructor id diff.expected Text_first) + (Includecore.report_extension_constructor_mismatch + "the first" "the second" "declaration" env) diff.symptom + show_locs (diff.got.ext_loc, diff.expected.ext_loc) + | Err.Class_type_declarations diff -> + Fmt.dprintf + "@[Class type declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]@ %a" + !Oprint.out_sig_item + (Out_type.tree_of_cltype_declaration id diff.got Trec_first) + !Oprint.out_sig_item + (Out_type.tree_of_cltype_declaration id diff.expected Trec_first) + (Includeclass.report_error_doc Type_scheme) diff.symptom + | Err.Class_declarations {got;expected;symptom} -> + let t1 = Out_type.tree_of_class_declaration id got Trec_first in + let t2 = Out_type.tree_of_class_declaration id expected Trec_first in + Fmt.dprintf + "@[Class declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]@ %a" + !Oprint.out_sig_item t1 + !Oprint.out_sig_item t2 + (Includeclass.report_error_doc Type_scheme) symptom + +let missing_field ppf item = + let id, loc, kind = Includemod.item_ident_name item in + Fmt.fprintf ppf "The %s %a is required but not provided%a" + (Includemod.kind_of_field_desc kind) + (Style.as_inline_code Printtyp.ident) id + (show_loc "Expected declaration") loc + +let module_types {Err.got=mty1; expected=mty2} = + Fmt.dprintf + "@[Modules do not match:@ \ + %a@;<1 -2>is not included in@ %a@]" + !Oprint.out_module_type (Out_type.tree_of_modtype mty1) + !Oprint.out_module_type (Out_type.tree_of_modtype mty2) + +let eq_module_types {Err.got=mty1; expected=mty2} = + Fmt.dprintf + "@[Module types do not match:@ \ + %a@;<1 -2>is not equal to@ %a@]" + !Oprint.out_module_type (Out_type.tree_of_modtype mty1) + !Oprint.out_module_type (Out_type.tree_of_modtype mty2) + +let module_type_declarations id {Err.got=d1 ; expected=d2} = + Fmt.dprintf + "@[Module type declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]" + !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration id d1) + !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration id d2) + +let interface_mismatch ppf (diff: _ Err.diff) = + Fmt.fprintf ppf + "The implementation %a@ does not match the interface %a:@ " + Style.inline_code diff.got Style.inline_code diff.expected + +let core_module_type_symptom (x:Err.core_module_type_symptom) = + match x with + | Not_an_alias | Not_an_identifier | Abstract_module_type + | Incompatible_aliases -> None + | Unbound_module_path path -> + Some(Fmt.dprintf "Unbound module %a" + (Style.as_inline_code Printtyp.path) path + ) + +(* Construct a linearized error message from the error tree *) + +let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff = + match diff.symptom with + | Invalid_module_alias _ (* the difference is non-informative here *) + | After_alias_expansion _ (* we print only the expanded module types *) -> + module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx + diff.symptom + | Functor Params d -> (* We jump directly to the functor param error *) + functor_params ~expansion_token ~env ~before ~ctx d + | _ -> + let inner = if eqmode then eq_module_types else module_types in + let next = + match diff.symptom with + | Mt_core _ -> + (* In those cases, the refined error messages for the current error + will at most add some minor comments on the current error. + It is thus better to avoid eliding the current error message. + *) + dwith_context ctx (inner diff) + | _ -> dwith_context_and_elision ctx inner diff + in + let before = next :: before in + module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx + diff.symptom + +and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function + | Mt_core core -> + begin match core_module_type_symptom core with + | None -> before + | Some msg -> Location.msg "%t" msg :: before + end + | Signature s -> signature ~expansion_token ~env ~before ~ctx s + | Functor f -> functor_symptom ~expansion_token ~env ~before ~ctx f + | After_alias_expansion diff -> + module_type ~eqmode ~expansion_token ~env ~before ~ctx diff + | Invalid_module_alias path -> + let printer = + Fmt.dprintf "Module %a cannot be aliased" + (Style.as_inline_code Printtyp.path) path + in + dwith_context ctx printer :: before + +and functor_params ~expansion_token ~env ~before ~ctx {got;expected;_} = + let d = Functor_suberror.Inclusion.patch env got expected in + let actual = Functor_suberror.Inclusion.got d in + let expected = Functor_suberror.expected d in + let main = + Fmt.dprintf + "@[Modules do not match:@ \ + @[%t@ -> ...@]@;<1 -2>is not included in@ \ + @[%t@ -> ...@]@]" + actual expected + in + let msgs = dwith_context ctx main :: before in + let functor_suberrors = + if expansion_token then + Functor_suberror.params functor_arg_diff ~expansion_token env d + else [] + in + functor_suberrors @ msgs + +and functor_symptom ~expansion_token ~env ~before ~ctx = function + | Result res -> + module_type ~expansion_token ~eqmode:false ~env ~before ~ctx res + | Params d -> functor_params ~expansion_token ~env ~before ~ctx d + +and signature ~expansion_token ~env:_ ~before ~ctx sgs = + Printtyp.wrap_printing_env ~error:true sgs.env (fun () -> + match sgs.missings, sgs.incompatibles with + | _ :: _ as missings, _ -> + if expansion_token then + let init_missings, last_missing = Misc.split_last missings in + List.map (Location.msg "%a" missing_field) init_missings + @ with_context ctx missing_field last_missing + :: before + else + before + | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a + | [], [] -> assert false + ) +and sigitem ~expansion_token ~env ~before ~ctx (name,s) = match s with + | Core c -> + dwith_context ctx (core env name c) :: before + | Module_type diff -> + module_type ~expansion_token ~eqmode:false ~env ~before + ~ctx:(Context.Module name :: ctx) diff + | Module_type_declaration diff -> + module_type_decl ~expansion_token ~env ~before ~ctx name diff +and module_type_decl ~expansion_token ~env ~before ~ctx id diff = + let next = + dwith_context_and_elision ctx (module_type_declarations id) diff in + let before = next :: before in + match diff.symptom with + | Not_less_than mts -> + let before = + Location.msg "The first module type is not included in the second" + :: before + in + module_type ~expansion_token ~eqmode:true ~before ~env + ~ctx:(Context.Modtype id :: ctx) mts + | Not_greater_than mts -> + let before = + Location.msg "The second module type is not included in the first" + :: before in + module_type ~expansion_token ~eqmode:true ~before ~env + ~ctx:(Context.Modtype id :: ctx) mts + | Incomparable mts -> + module_type ~expansion_token ~eqmode:true ~env ~before + ~ctx:(Context.Modtype id :: ctx) mts.less_than + | Illegal_permutation c -> + begin match diff.got.Types.mtd_type with + | None -> assert false + | Some mty -> + with_context (Modtype id::ctx) + (Runtime_coercion.illegal_permutation Context.alt_pp env) (mty,c) + :: before + end + +and functor_arg_diff ~expansion_token env (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.Inclusion.insert mty + | Delete mty -> Functor_suberror.Inclusion.delete mty + | Keep (x, y, _) -> Functor_suberror.Inclusion.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.Inclusion.incompatible i + | Change (g, e, Err.Mismatch mty_diff) -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Functor_suberror.Inclusion.diff g e more + +let functor_app_diff ~expansion_token env (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.App.insert mty + | Delete mty -> Functor_suberror.App.delete mty + | Keep (x, y, _) -> Functor_suberror.App.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.App.incompatible i + | Change (g, e, Err.Mismatch mty_diff) -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Functor_suberror.App.diff g e more + +let module_type_subst ~env id diff = + match diff.symptom with + | Not_less_than mts -> + module_type ~expansion_token:true ~eqmode:true ~before:[] ~env + ~ctx:[Modtype id] mts + | Not_greater_than mts -> + module_type ~expansion_token:true ~eqmode:true ~before:[] ~env + ~ctx:[Modtype id] mts + | Incomparable mts -> + module_type ~expansion_token:true ~eqmode:true ~env ~before:[] + ~ctx:[Modtype id] mts.less_than + | Illegal_permutation c -> + let mty = diff.got in + let main = + with_context [Modtype id] + (Runtime_coercion.illegal_permutation Context.alt_pp env) (mty,c) in + [main] + +let all env = function + | In_Compilation_unit diff -> + let first = Location.msg "%a" interface_mismatch diff in + signature ~expansion_token:true ~env ~before:[first] ~ctx:[] diff.symptom + | In_Type_declaration (id,reason) -> + [Location.msg "%t" (core env id reason)] + | In_Module_type diff -> + module_type ~expansion_token:true ~eqmode:false ~before:[] ~env ~ctx:[] + diff + | In_Module_type_substitution (id,diff) -> + module_type_subst ~env id diff + | In_Signature diff -> + signature ~expansion_token:true ~before:[] ~env ~ctx:[] diff + | In_Expansion cmts -> + match core_module_type_symptom cmts with + | None -> assert false + | Some main -> [Location.msg "%t" main] + +(* General error reporting *) + +let err_msgs ppf (env, err) = + Printtyp.wrap_printing_env ~error:true env + (fun () -> (coalesce @@ all env err) ppf) + +let report_error_doc err = + Location.errorf + ~loc:Location.(in_file !input_name) + ~footnote:Out_type.Ident_conflicts.err_msg + "%a" err_msgs err + +let report_apply_error_doc ~loc env (app_name, mty_f, args) = + let footnote = Out_type.Ident_conflicts.err_msg in + let d = Functor_suberror.App.patch env ~f:mty_f ~args in + match d with + (* We specialize the one change and one argument case to remove the + presentation of the functor arguments *) + | [ _, Change (_, _, Err.Incompatible_params (i,_)) ] -> + Location.errorf ~loc ~footnote "%t" (Functor_suberror.App.incompatible i) + | [ _, Change (g, e, Err.Mismatch mty_diff) ] -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token:true ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Location.errorf ~loc ~footnote "%t" + (Functor_suberror.App.single_diff g e more) + | _ -> + let not_functor = + List.for_all (function _, Diffing.Delete _ -> true | _ -> false) d + in + if not_functor then + match app_name with + | Includemod.Named_leftmost_functor lid -> + Location.errorf ~loc + "@[The module %a is not a functor, it cannot be applied.@]" + (Style.as_inline_code Printtyp.longident) lid + | Includemod.Anonymous_functor + | Includemod.Full_application_path _ + (* The "non-functor application in term" case is directly handled in + [Env] and it is the only case where we have a full application + path at hand. Thus this case of the or-pattern is currently + unreachable and we don't try to specialize the corresponding error + message. *) -> + Location.errorf ~loc + "@[This module is not a functor, it cannot be applied.@]" + else + let intro ppf = + match app_name with + | Includemod.Anonymous_functor -> + Fmt.fprintf ppf "This functor application is ill-typed." + | Includemod.Full_application_path lid -> + Fmt.fprintf ppf "The functor application %a is ill-typed." + (Style.as_inline_code Printtyp.longident) lid + | Includemod.Named_leftmost_functor lid -> + Fmt.fprintf ppf + "This application of the functor %a is ill-typed." + (Style.as_inline_code Printtyp.longident) lid + in + let actual = Functor_suberror.App.got d in + let expected = Functor_suberror.expected d in + let sub = + List.rev @@ + Functor_suberror.params functor_app_diff env ~expansion_token:true d + in + Location.errorf ~loc ~sub ~footnote + "@[%t@ \ + These arguments:@;<1 2>@[%t@]@ \ + do not match these parameters:@;<1 2>@[%t@ -> ...@]@]" + intro + actual expected + +let coercion_in_package_subtype env mty c = + Format_doc.doc_printf "%t" @@ + Runtime_coercion.in_package_subtype Context.alt_pp env mty c + +let register () = + Location.register_error_of_exn + (function + | Includemod.Error err -> Some (report_error_doc err) + | Includemod.Apply_error {loc; env; app_name; mty_f; args} -> + Some (Printtyp.wrap_printing_env env ~error:true (fun () -> + report_apply_error_doc ~loc env (app_name, mty_f, args)) + ) + | _ -> None + ) diff --git a/upstream/ocaml_503/typing/includemod_errorprinter.mli b/upstream/ocaml_503/typing/includemod_errorprinter.mli new file mode 100644 index 000000000..0c7dda4e5 --- /dev/null +++ b/upstream/ocaml_503/typing/includemod_errorprinter.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val err_msgs: Includemod.explanation Format_doc.printer +val coercion_in_package_subtype: + Env.t -> Types.module_type -> Typedtree.module_coercion -> Format_doc.doc +val register: unit -> unit diff --git a/upstream/ocaml_503/typing/mtype.ml b/upstream/ocaml_503/typing/mtype.ml new file mode 100644 index 000000000..499d85ca1 --- /dev/null +++ b/upstream/ocaml_503/typing/mtype.ml @@ -0,0 +1,569 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Operations on module types *) + +open Asttypes +open Path +open Types + +let rec scrape_lazy env mty = + let open Subst.Lazy in + match mty with + MtyL_ident p -> + begin try + scrape_lazy env (Env.find_modtype_expansion_lazy p env) + with Not_found -> + mty + end + | _ -> mty + +let scrape env mty = + match mty with + Mty_ident p -> + Subst.Lazy.force_modtype (scrape_lazy env (MtyL_ident p)) + | _ -> mty + +let freshen ~scope mty = + Subst.modtype (Rescope scope) Subst.identity mty + +let rec strengthen_lazy ~aliasable env mty p = + let open Subst.Lazy in + match scrape_lazy env mty with + MtyL_signature sg -> + MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) + | MtyL_functor(Named (Some param, arg), res) + when !Clflags.applicative_functors -> + let env = + Env.add_module_lazy ~update_summary:false param Mp_present arg env + in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | MtyL_functor(Named (None, arg), res) + when !Clflags.applicative_functors -> + let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | mty -> + mty + +and strengthen_lazy_sig' ~aliasable env sg p = + let open Subst.Lazy in + match sg with + [] -> [] + | (SigL_value(_, _, _) as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_type(id, {type_kind=Type_abstract _}, _, _) :: rem + when Btype.is_row_name (Ident.name id) -> + strengthen_lazy_sig' ~aliasable env rem p + | SigL_type(id, decl, rs, vis) :: rem -> + let newdecl = + match decl.type_manifest, decl.type_private, decl.type_kind with + Some _, Public, _ -> decl + | Some _, Private, (Type_record _ | Type_variant _) -> decl + | _ -> + let manif = + Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id), + decl.type_params, ref Mnil))) in + if Btype.type_kind_is_abstract decl then + { decl with type_private = Public; type_manifest = manif } + else + { decl with type_manifest = manif } + in + SigL_type(id, newdecl, rs, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + | (SigL_typext _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_module(id, pres, md, rs, vis) :: rem -> + let str = + strengthen_lazy_decl ~aliasable env md (Pdot(p, Ident.name id)) + in + let env = + Env.add_module_declaration_lazy ~update_summary:false id pres md env in + SigL_module(id, pres, str, rs, vis) + :: strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module in case it defines manifest module types *) + | SigL_modtype(id, decl, vis) :: rem -> + let newdecl = + match decl.mtdl_type with + | Some _ when not aliasable -> + (* [not alisable] condition needed because of recursive modules. + See [Typemod.check_recmodule_inclusion]. *) + decl + | _ -> + {decl with mtdl_type = Some(MtyL_ident(Pdot(p,Ident.name id)))} + in + let env = Env.add_modtype_lazy ~update_summary:false id decl env in + SigL_modtype(id, newdecl, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module type in case it is manifest *) + | (SigL_class _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | (SigL_class_type _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + +and strengthen_lazy_sig ~aliasable env sg p = + let sg = Subst.Lazy.force_signature_once sg in + let sg = strengthen_lazy_sig' ~aliasable env sg p in + Subst.Lazy.of_signature_items sg + +and strengthen_lazy_decl ~aliasable env md p = + let open Subst.Lazy in + match md.mdl_type with + | MtyL_alias _ -> md + | _ when aliasable -> {md with mdl_type = MtyL_alias p} + | mty -> {md with mdl_type = strengthen_lazy ~aliasable env mty p} + +let () = Env.strengthen := strengthen_lazy + +let strengthen ~aliasable env mty p = + let mty = strengthen_lazy ~aliasable env (Subst.Lazy.of_modtype mty) p in + Subst.Lazy.force_modtype mty + +let strengthen_decl ~aliasable env md p = + let md = strengthen_lazy_decl ~aliasable env + (Subst.Lazy.of_module_decl md) p in + Subst.Lazy.force_module_decl md + +let rec make_aliases_absent pres mty = + match mty with + | Mty_alias _ -> Mp_absent, mty + | Mty_signature sg -> + pres, Mty_signature(make_aliases_absent_sig sg) + | Mty_functor(arg, res) -> + let _, res = make_aliases_absent Mp_present res in + pres, Mty_functor(arg, res) + | mty -> + pres, mty + +and make_aliases_absent_sig sg = + match sg with + [] -> [] + | Sig_module(id, pres, md, rs, priv) :: rem -> + let pres, md_type = make_aliases_absent pres md.md_type in + let md = { md with md_type } in + Sig_module(id, pres, md, rs, priv) :: make_aliases_absent_sig rem + | sigelt :: rem -> + sigelt :: make_aliases_absent_sig rem + +let scrape_for_type_of env pres mty = + let rec loop env path mty = + match mty, path with + | Mty_alias path, _ -> begin + try + let md = Env.find_module path env in + loop env (Some path) md.md_type + with Not_found -> mty + end + | mty, Some path -> + strengthen ~aliasable:false env mty path + | _ -> mty + in + make_aliases_absent pres (loop env None mty) + +(* In nondep_supertype, env is only used for the type it assigns to id. + Hence there is no need to keep env up-to-date by adding the bindings + traversed. *) + +type variance = Co | Contra | Strict + +let rec nondep_mty_with_presence env va ids pres mty = + match mty with + Mty_ident p -> + begin match Path.find_free_opt ids p with + | Some id -> + let expansion = + try Env.find_modtype_expansion p env + with Not_found -> + raise (Ctype.Nondep_cannot_erase id) + in + nondep_mty_with_presence env va ids pres expansion + | None -> pres, mty + end + | Mty_alias p -> + begin match Path.find_free_opt ids p with + | Some id -> + let expansion = + try Env.find_module p env + with Not_found -> + raise (Ctype.Nondep_cannot_erase id) + in + nondep_mty_with_presence env va ids Mp_present expansion.md_type + | None -> pres, mty + end + | Mty_signature sg -> + let mty = Mty_signature(nondep_sig env va ids sg) in + pres, mty + | Mty_functor(Unit, res) -> + pres, Mty_functor(Unit, nondep_mty env va ids res) + | Mty_functor(Named (param, arg), res) -> + let var_inv = + match va with Co -> Contra | Contra -> Co | Strict -> Strict in + let res_env = + match param with + | None -> env + | Some param -> Env.add_module ~arg:true param Mp_present arg env + in + let mty = + Mty_functor(Named (param, nondep_mty env var_inv ids arg), + nondep_mty res_env va ids res) + in + pres, mty + +and nondep_mty env va ids mty = + snd (nondep_mty_with_presence env va ids Mp_present mty) + +and nondep_sig_item env va ids = function + | Sig_value(id, d, vis) -> + Sig_value(id, + {d with val_type = Ctype.nondep_type env ids d.val_type}, + vis) + | Sig_type(id, d, rs, vis) -> + Sig_type(id, Ctype.nondep_type_decl env ids (va = Co) d, rs, vis) + | Sig_typext(id, ext, es, vis) -> + Sig_typext(id, Ctype.nondep_extension_constructor env ids ext, es, vis) + | Sig_module(id, pres, md, rs, vis) -> + let pres, mty = nondep_mty_with_presence env va ids pres md.md_type in + Sig_module(id, pres, {md with md_type = mty}, rs, vis) + | Sig_modtype(id, d, vis) -> + begin try + Sig_modtype(id, nondep_modtype_decl env ids d, vis) + with Ctype.Nondep_cannot_erase _ as exn -> + match va with + Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none; + mtd_attributes=[]; mtd_uid = d.mtd_uid}, vis) + | _ -> raise exn + end + | Sig_class(id, d, rs, vis) -> + Sig_class(id, Ctype.nondep_class_declaration env ids d, rs, vis) + | Sig_class_type(id, d, rs, vis) -> + Sig_class_type(id, Ctype.nondep_cltype_declaration env ids d, rs, vis) + +and nondep_sig env va ids sg = + let scope = Ctype.create_scope () in + let sg, env = Env.enter_signature ~scope sg env in + List.map (nondep_sig_item env va ids) sg + +and nondep_modtype_decl env ids mtd = + {mtd with mtd_type = Option.map (nondep_mty env Strict ids) mtd.mtd_type} + +let nondep_supertype env ids = nondep_mty env Co ids +let nondep_sig_item env ids = nondep_sig_item env Co ids + +let enrich_typedecl env p id decl = + match decl.type_manifest with + Some _ -> decl + | None -> + match Env.find_type p env with + | exception Not_found -> decl + (* Type which was not present in the signature, so we don't have + anything to do. *) + | orig_decl -> + if decl.type_arity <> orig_decl.type_arity then + decl + else begin + let orig_ty = + Ctype.reify_univars env + (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil))) + in + let new_ty = + Ctype.reify_univars env + (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil))) + in + let env = Env.add_type ~check:false id decl env in + match Ctype.mcomp env orig_ty new_ty with + | exception Ctype.Incompatible -> decl + (* The current declaration is not compatible with the one we got + from the signature. We should just fail now, but then, we could + also have failed if the arities of the two decls were + different, which we didn't. *) + | () -> + let orig_ty = + Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)) + in + {decl with type_manifest = Some orig_ty} + end + +let rec enrich_modtype env p mty = + match mty with + Mty_signature sg -> + Mty_signature(List.map (enrich_item env p) sg) + | _ -> + mty + +and enrich_item env p = function + Sig_type(id, decl, rs, priv) -> + Sig_type(id, + enrich_typedecl env (Pdot(p, Ident.name id)) id decl, rs, priv) + | Sig_module(id, pres, md, rs, priv) -> + Sig_module(id, pres, + {md with + md_type = enrich_modtype env + (Pdot(p, Ident.name id)) md.md_type}, + rs, + priv) + | item -> item + +let rec type_paths env p mty = + match scrape env mty with + Mty_ident _ -> [] + | Mty_alias _ -> [] + | Mty_signature sg -> type_paths_sig env p sg + | Mty_functor _ -> [] + +and type_paths_sig env p sg = + match sg with + [] -> [] + | Sig_type(id, _decl, _, _) :: rem -> + Pdot(p, Ident.name id) :: type_paths_sig env p rem + | Sig_module(id, pres, md, _, _) :: rem -> + type_paths env (Pdot(p, Ident.name id)) md.md_type @ + type_paths_sig (Env.add_module_declaration ~check:false id pres md env) + p rem + | Sig_modtype(id, decl, _) :: rem -> + type_paths_sig (Env.add_modtype id decl env) p rem + | (Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _) :: rem -> + type_paths_sig env p rem + + +let rec no_code_needed_mod env pres mty = + match pres with + | Mp_absent -> true + | Mp_present -> begin + match scrape env mty with + Mty_ident _ -> false + | Mty_signature sg -> no_code_needed_sig env sg + | Mty_functor _ -> false + | Mty_alias _ -> false + end + +and no_code_needed_sig env sg = + match sg with + [] -> true + | Sig_value(_id, decl, _) :: rem -> + begin match decl.val_kind with + | Val_prim _ -> no_code_needed_sig env rem + | _ -> false + end + | Sig_module(id, pres, md, _, _) :: rem -> + no_code_needed_mod env pres md.md_type && + no_code_needed_sig + (Env.add_module_declaration ~check:false id pres md env) rem + | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> + no_code_needed_sig env rem + | (Sig_typext _ | Sig_class _) :: _ -> + false + +let no_code_needed env mty = no_code_needed_mod env Mp_present mty + +(* Check whether a module type may return types *) + +let rec contains_type env = function + Mty_ident path -> + begin try match (Env.find_modtype path env).mtd_type with + | None -> raise Exit (* PR#6427 *) + | Some mty -> contains_type env mty + with Not_found -> raise Exit + end + | Mty_signature sg -> + contains_type_sig env sg + | Mty_functor (_, body) -> + contains_type env body + | Mty_alias _ -> + () + +and contains_type_sig env = List.iter (contains_type_item env) + +and contains_type_item env = function + Sig_type (_,({type_manifest = None} | + {type_kind = Type_abstract _; type_private = Private}),_, _) + | Sig_modtype _ + | Sig_typext (_, {ext_args = Cstr_record _}, _, _) -> + (* We consider that extension constructors with an inlined + record create a type (the inlined record), even though + it would be technically safe to ignore that considering + the current constraints which guarantee that this type + is kept local to expressions. *) + raise Exit + | Sig_module (_, _, {md_type = mty}, _, _) -> + contains_type env mty + | Sig_value _ + | Sig_type _ + | Sig_typext _ + | Sig_class _ + | Sig_class_type _ -> + () + +let contains_type env mty = + try contains_type env mty; false with Exit -> true + + +(* Remove module aliases from a signature *) + +let rec get_prefixes = function + | Pident _ -> Path.Set.empty + | Pdot (p, _) | Papply (p, _) | Pextra_ty (p, _) + -> Path.Set.add p (get_prefixes p) + +let rec get_arg_paths = function + | Pident _ -> Path.Set.empty + | Pdot (p, _) | Pextra_ty (p, _) -> get_arg_paths p + | Papply (p1, p2) -> + Path.Set.add p2 + (Path.Set.union (get_prefixes p2) + (Path.Set.union (get_arg_paths p1) (get_arg_paths p2))) + +let rec rollback_path subst p = + try Pident (Path.Map.find p subst) + with Not_found -> + match p with + Pident _ | Papply _ -> p + | Pdot (p1, s) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s)) + | Pextra_ty (p1, extra) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p + else rollback_path subst (Pextra_ty (p1', extra)) + +let rec collect_ids subst bindings p = + begin match rollback_path subst p with + Pident id -> + let ids = + try collect_ids subst bindings (Ident.find_same id bindings) + with Not_found -> Ident.Set.empty + in + Ident.Set.add id ids + | _ -> Ident.Set.empty + end + +let collect_arg_paths mty = + let open Btype in + let paths = ref Path.Set.empty + and subst = ref Path.Map.empty + and bindings = ref Ident.empty in + (* let rt = Ident.create "Root" in + and prefix = ref (Path.Pident rt) in *) + with_type_mark begin fun mark -> + let super = type_iterators mark in + let it_path p = paths := Path.Set.union (get_arg_paths p) !paths + and it_signature_item it si = + super.it_signature_item it si; + match si with + | Sig_module (id, _, {md_type=Mty_alias p}, _, _) -> + bindings := Ident.add id p !bindings + | Sig_module (id, _, {md_type=Mty_signature sg}, _, _) -> + List.iter + (function Sig_module (id', _, _, _, _) -> + subst := + Path.Map.add (Pdot (Pident id, Ident.name id')) id' !subst + | _ -> ()) + sg + | _ -> () + in + let it = {super with it_path; it_signature_item} in + it.it_module_type it mty; + Path.Set.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p)) + !paths Ident.Set.empty + end + +type remove_alias_args = + { mutable modified: bool; + exclude: Ident.t -> Path.t -> bool; + scrape: Env.t -> module_type -> module_type } + +let rec remove_aliases_mty env args pres mty = + let args' = {args with modified = false} in + let res = + match args.scrape env mty with + Mty_signature sg -> + Mp_present, Mty_signature (remove_aliases_sig env args' sg) + | Mty_alias _ -> + let mty' = Env.scrape_alias env mty in + if mty' = mty then begin + pres, mty + end else begin + args'.modified <- true; + remove_aliases_mty env args' Mp_present mty' + end + | mty -> + Mp_present, mty + in + if args'.modified then begin + args.modified <- true; + res + end else begin + pres, mty + end + +and remove_aliases_sig env args sg = + match sg with + [] -> [] + | Sig_module(id, pres, md, rs, priv) :: rem -> + let pres, mty = + match md.md_type with + Mty_alias p when args.exclude id p -> + pres, md.md_type + | mty -> + remove_aliases_mty env args pres mty + in + Sig_module(id, pres, {md with md_type = mty} , rs, priv) :: + remove_aliases_sig (Env.add_module id pres mty env) args rem + | Sig_modtype(id, mtd, priv) :: rem -> + Sig_modtype(id, mtd, priv) :: + remove_aliases_sig (Env.add_modtype id mtd env) args rem + | it :: rem -> + it :: remove_aliases_sig env args rem + +let scrape_for_functor_arg env mty = + let exclude _id p = + try ignore (Env.find_module p env); true with Not_found -> false + in + let _, mty = + remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty + in + mty + +let scrape_for_type_of ~remove_aliases env mty = + if remove_aliases then begin + let excl = collect_arg_paths mty in + let exclude id _p = Ident.Set.mem id excl in + let scrape _ mty = mty in + let _, mty = + remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty + in + mty + end else begin + let _, mty = scrape_for_type_of env Mp_present mty in + mty + end + +(* Lower non-generalizable type variables *) + +let lower_nongen nglev mty = + let open Btype in + with_type_mark begin fun mark -> + let super = type_iterators mark in + let it_do_type_expr it ty = + match get_desc ty with + Tvar _ -> + let level = get_level ty in + if level < generic_level && level > nglev then set_level ty nglev + | _ -> + super.it_do_type_expr it ty + in + let it = {super with it_do_type_expr} in + it.it_module_type it mty + end diff --git a/upstream/ocaml_503/typing/mtype.mli b/upstream/ocaml_503/typing/mtype.mli new file mode 100644 index 000000000..68d290b36 --- /dev/null +++ b/upstream/ocaml_503/typing/mtype.mli @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Operations on module types *) + +open Types + +val scrape: Env.t -> module_type -> module_type + (* Expand toplevel module type abbreviations + till hitting a "hard" module type (signature, functor, + or abstract module type ident. *) +val scrape_for_functor_arg: Env.t -> module_type -> module_type + (* Remove aliases in a functor argument type *) +val scrape_for_type_of: + remove_aliases:bool -> Env.t -> module_type -> module_type + (* Process type for module type of *) +val freshen: scope:int -> module_type -> module_type + (* Return an alpha-equivalent copy of the given module type + where bound identifiers are fresh. *) +val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type + (* Strengthen abstract type components relative to the + given path. *) +val strengthen_decl: + aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration +val nondep_supertype: Env.t -> Ident.t list -> module_type -> module_type + (* Return the smallest supertype of the given type + in which none of the given idents appears. + @raise [Ctype.Nondep_cannot_erase] if no such type exists. *) +val nondep_sig_item: Env.t -> Ident.t list -> signature_item -> signature_item + (* Returns the signature item with its type updated + to be the smallest supertype of its initial type + in which none of the given idents appears. + @raise [Ctype.Nondep_cannot_erase] if no such type exists. *) +val no_code_needed: Env.t -> module_type -> bool +val no_code_needed_sig: Env.t -> signature -> bool + (* Determine whether a module needs no implementation code, + i.e. consists only of type definitions. *) +val enrich_modtype: Env.t -> Path.t -> module_type -> module_type +val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration -> + type_declaration +val type_paths: Env.t -> Path.t -> module_type -> Path.t list +val contains_type: Env.t -> module_type -> bool +val lower_nongen: int -> module_type -> unit diff --git a/upstream/ocaml_503/typing/oprint.ml b/upstream/ocaml_503/typing/oprint.ml new file mode 100644 index 000000000..83dda4a27 --- /dev/null +++ b/upstream/ocaml_503/typing/oprint.ml @@ -0,0 +1,858 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format_doc +open Outcometree + +exception Ellipsis + +let cautious f ppf arg = + try f ppf arg with + Ellipsis -> fprintf ppf "..." + +let print_lident ppf = function + | "::" -> pp_print_string ppf "(::)" + | s when Lexer.is_keyword s -> fprintf ppf "\\#%s" s + | s -> pp_print_string ppf s + +let rec print_ident ppf = + function + Oide_ident s -> print_lident ppf s.printed_name + | Oide_dot (id, s) -> + print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s + | Oide_apply (id1, id2) -> + fprintf ppf "%a(%a)" print_ident id1 print_ident id2 + +let out_ident = ref print_ident + +let parenthesized_ident name = + (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) + || not (Misc.Utf8_lexeme.is_valid_identifier name) + +let value_ident ppf name = + if parenthesized_ident name then + fprintf ppf "( %s )" name + else if Lexer.is_keyword name then + fprintf ppf "\\#%s" name + else + pp_print_string ppf name + +(* Values *) + +let valid_float_lexeme s = + let l = String.length s in + let rec loop i = + if i >= l then s ^ "." else + match s.[i] with + | '0' .. '9' | '-' -> loop (i+1) + | _ -> s + in loop 0 + +let float_repres f = + match classify_float f with + FP_nan -> "nan" + | FP_infinite -> + if f < 0.0 then "neg_infinity" else "infinity" + | _ -> + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 then s1 else + let s2 = Printf.sprintf "%.15g" f in + if f = float_of_string s2 then s2 else + Printf.sprintf "%.18g" f + in valid_float_lexeme float_val + +let parenthesize_if_neg ppf fmt v isneg = + if isneg then pp_print_char ppf '('; + fprintf ppf fmt v; + if isneg then pp_print_char ppf ')' + +let escape_string s = + (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\' + and '"' *) + let n = ref 0 in + for i = 0 to String.length s - 1 do + n := !n + + (match String.unsafe_get s i with + | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 + | '\x00' .. '\x1F' + | '\x7F' -> 4 + | _ -> 1) + done; + if !n = String.length s then s else begin + let s' = Bytes.create !n in + n := 0; + for i = 0 to String.length s - 1 do + begin match String.unsafe_get s i with + | ('\"' | '\\') as c -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c + | '\n' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n' + | '\t' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't' + | '\r' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r' + | '\b' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b' + | '\x00' .. '\x1F' | '\x7F' as c -> + let a = Char.code c in + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + a / 100)); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10)); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10)); + | c -> Bytes.unsafe_set s' !n c + end; + incr n + done; + Bytes.to_string s' + end + + +let print_out_string ppf s = + let not_escaped = + (* let the user dynamically choose if strings should be escaped: *) + match Sys.getenv_opt "OCAMLTOP_UTF_8" with + | None -> true + | Some x -> + match bool_of_string_opt x with + | None -> true + | Some f -> f in + if not_escaped then + fprintf ppf "\"%s\"" (escape_string s) + else + fprintf ppf "%S" s + +let print_constr ppf name = + match name with + | Oide_ident {printed_name = ("true" | "false") as c} -> + (* despite being keywords, these are constructor names + and should not be escaped *) + fprintf ppf "%s" c + | _ -> print_ident ppf name + +let print_out_value ppf tree = + let rec print_tree_1 ppf = + function + | Oval_constr (name, [param]) -> + fprintf ppf "@[<1>%a@ %a@]" print_constr name print_constr_param param + | Oval_constr (name, (_ :: _ as params)) -> + fprintf ppf "@[<1>%a@ (%a)@]" print_constr name + (print_tree_list print_tree_1 ",") params + | Oval_variant (name, Some param) -> + fprintf ppf "@[<2>`%a@ %a@]" print_lident name print_constr_param param + | Oval_lazy param -> + fprintf ppf "@[<2>lazy@ %a@]" print_constr_param param + | tree -> print_simple_tree ppf tree + and print_constr_param ppf = function + | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) + | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l) + | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L) + | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n) + | Oval_float f -> + parenthesize_if_neg ppf "%s" (float_repres f) + (f < 0.0 || 1. /. f = neg_infinity) + | Oval_string (_,_, Ostr_bytes) as tree -> + pp_print_char ppf '('; + print_simple_tree ppf tree; + pp_print_char ppf ')'; + | tree -> print_simple_tree ppf tree + and print_simple_tree ppf = + function + Oval_int i -> fprintf ppf "%i" i + | Oval_int32 i -> fprintf ppf "%lil" i + | Oval_int64 i -> fprintf ppf "%LiL" i + | Oval_nativeint i -> fprintf ppf "%nin" i + | Oval_float f -> pp_print_string ppf (float_repres f) + | Oval_char c -> fprintf ppf "%C" c + | Oval_string (s, maxlen, kind) -> + begin try + let len = String.length s in + let maxlen = max maxlen 8 in (* always show a little prefix *) + let s = if len > maxlen then String.sub s 0 maxlen else s in + begin match kind with + | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s + | Ostr_string -> print_out_string ppf s + end; + (if len > maxlen then + fprintf ppf + "... (* string length %d; truncated *)" len + ) + with + Invalid_argument _ (* "String.create" *)-> fprintf ppf "" + end + | Oval_list tl -> + fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl + | Oval_array tl -> + fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl + | Oval_constr (name, []) -> print_constr ppf name + | Oval_variant (name, None) -> fprintf ppf "`%a" print_lident name + | Oval_stuff s -> pp_print_string ppf s + | Oval_record fel -> + fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel + | Oval_ellipsis -> raise Ellipsis + | Oval_printer f -> f ppf + | Oval_tuple tree_list -> + fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list + | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree + and print_fields first ppf = + function + [] -> () + | (name, tree) :: fields -> + if not first then fprintf ppf ";@ "; + fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1) + tree; + print_fields false ppf fields + and print_tree_list print_item sep ppf tree_list = + let rec print_list first ppf = + function + [] -> () + | tree :: tree_list -> + if not first then fprintf ppf "%s@ " sep; + print_item ppf tree; + print_list false ppf tree_list + in + cautious (print_list true) ppf tree_list + in + cautious print_tree_1 ppf tree + +let out_value = ref (compat print_out_value) + +(* Types *) + +let rec print_list_init pr sep ppf = + function + [] -> () + | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l + +let rec print_list pr sep ppf = + function + [] -> () + | [a] -> pr ppf a + | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l + +let pr_present = + print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") + +let pr_var = Pprintast.Doc.tyvar +let ty_var ~non_gen ppf s = + pr_var ppf (if non_gen then "_" ^ s else s) + +let pr_vars = + print_list pr_var (fun ppf -> fprintf ppf "@ ") + +let print_arg_label ppf (lbl : Asttypes.arg_label) = + match lbl with + | Nolabel -> () + | Labelled s -> fprintf ppf "%a:" print_lident s + | Optional s -> fprintf ppf "?%a:" print_lident s + +let rec print_out_type ppf = + function + | Otyp_alias {non_gen; aliased; alias } -> + fprintf ppf "@[%a@ as %a@]" + print_out_type aliased + (ty_var ~non_gen) alias + | Otyp_poly (sl, ty) -> + fprintf ppf "@[%a.@ %a@]" + pr_vars sl + print_out_type ty + | ty -> + print_out_type_1 ppf ty + +and print_out_type_1 ppf = + function + Otyp_arrow (lab, ty1, ty2) -> + pp_open_box ppf 0; + print_arg_label ppf lab; + print_out_type_2 ppf ty1; + pp_print_string ppf " ->"; + pp_print_space ppf (); + print_out_type_1 ppf ty2; + pp_close_box ppf () + | ty -> print_out_type_2 ppf ty +and print_out_type_2 ppf = + function + Otyp_tuple tyl -> + fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl + | ty -> print_simple_out_type ppf ty +and print_simple_out_type ppf = + function + Otyp_class (id, tyl) -> + fprintf ppf "@[%a#%a@]" print_typargs tyl print_ident id + | Otyp_constr (id, tyl) -> + pp_open_box ppf 0; + print_typargs ppf tyl; + print_ident ppf id; + pp_close_box ppf () + | Otyp_object {fields; open_row} -> + fprintf ppf "@[<2>< %a >@]" (print_fields open_row) fields + | Otyp_stuff s -> pp_print_string ppf s + | Otyp_var (non_gen, s) -> ty_var ~non_gen ppf s + | Otyp_variant (row_fields, closed, tags) -> + let print_present ppf = + function + None | Some [] -> () + | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l + in + let print_fields ppf = + function + Ovar_fields fields -> + print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") + ppf fields + | Ovar_typ typ -> + print_simple_out_type ppf typ + in + fprintf ppf "@[[%s@[@[%a@]%a@]@ ]@]" + (if closed then if tags = None then " " else "< " + else if tags = None then "> " else "? ") + print_fields row_fields + print_present tags + | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty -> + pp_open_box ppf 1; + pp_print_char ppf '('; + print_out_type ppf ty; + pp_print_char ppf ')'; + pp_close_box ppf () + | Otyp_abstract | Otyp_open + | Otyp_sum _ | Otyp_manifest (_, _) -> () + | Otyp_record lbls -> print_record_decl ppf lbls + | Otyp_module (p, fl) -> + fprintf ppf "@[<1>(module %a" print_ident p; + let first = ref true in + List.iter + (fun (s, t) -> + let sep = if !first then (first := false; "with") else "and" in + fprintf ppf " %s type %s = %a" sep s print_out_type t + ) + fl; + fprintf ppf ")@]" + | Otyp_attribute (t, attr) -> + fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name +and print_record_decl ppf lbls = + fprintf ppf "{%a@;<1 -2>}" + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls +and print_fields open_row ppf = + function + [] -> + if open_row then fprintf ppf ".."; + | [s, t] -> + fprintf ppf "%a : %a" print_lident s print_out_type t; + if open_row then fprintf ppf ";@ "; + print_fields open_row ppf [] + | (s, t) :: l -> + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields open_row) l +and print_row_field ppf (l, opt_amp, tyl) = + let pr_of ppf = + if opt_amp then fprintf ppf " of@ &@ " + else if tyl <> [] then fprintf ppf " of@ " + else fprintf ppf "" + in + fprintf ppf "@[`%a%t%a@]" print_lident l pr_of + (print_typlist print_out_type " &") + tyl +and print_typlist print_elem sep ppf = + function + [] -> () + | [ty] -> print_elem ppf ty + | ty :: tyl -> + print_elem ppf ty; + pp_print_string ppf sep; + pp_print_space ppf (); + print_typlist print_elem sep ppf tyl +and print_typargs ppf = + function + [] -> () + | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf () + | tyl -> + pp_open_box ppf 1; + pp_print_char ppf '('; + print_typlist print_out_type "," ppf tyl; + pp_print_char ppf ')'; + pp_close_box ppf (); + pp_print_space ppf () +and print_out_label ppf {olab_name; olab_mut; olab_type} = + fprintf ppf "@[<2>%s%a :@ %a@];" + (match olab_mut with + | Mutable -> "mutable " + | Immutable -> "") + print_lident olab_name + print_out_type olab_type + +let out_label = ref print_out_label + +let out_type = ref print_out_type + +let out_type_args = ref print_typargs + +(* Class types *) + +let print_type_parameter ?(non_gen=false) ppf s = + if s = "_" then fprintf ppf "_" else ty_var ~non_gen ppf s + +let type_parameter ppf {ot_non_gen=non_gen; ot_name=ty; ot_variance=var,inj} = + let open Asttypes in + fprintf ppf "%s%s%a" + (match var with Covariant -> "+" | Contravariant -> "-" | NoVariance -> "") + (match inj with Injective -> "!" | NoInjectivity -> "") + (print_type_parameter ~non_gen) ty + +let print_out_class_params ppf = + function + [] -> () + | tyl -> + fprintf ppf "@[<1>[%a]@]@ " + (print_list type_parameter (fun ppf -> fprintf ppf ", ")) + tyl + +let rec print_out_class_type ppf = + function + Octy_constr (id, tyl) -> + let pr_tyl ppf = + function + [] -> () + | tyl -> + fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl + in + fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id + | Octy_arrow (lab, ty, cty) -> + fprintf ppf "@[%a%a ->@ %a@]" print_arg_label lab + print_out_type_2 ty print_out_class_type cty + | Octy_signature (self_ty, csil) -> + let pr_param ppf = + function + Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty + | None -> () + in + fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty + (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) + csil +and print_out_class_sig_item ppf = + function + Ocsg_constraint (ty1, ty2) -> + fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 + !out_type ty2 + | Ocsg_method (name, priv, virt, ty) -> + fprintf ppf "@[<2>method %s%s%a :@ %a@]" + (if priv then "private " else "") (if virt then "virtual " else "") + print_lident name !out_type ty + | Ocsg_value (name, mut, vr, ty) -> + fprintf ppf "@[<2>val %s%s%a :@ %a@]" + (if mut then "mutable " else "") + (if vr then "virtual " else "") + print_lident name !out_type ty + +let out_class_type = ref print_out_class_type + +(* Signature *) + +let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") +let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") +let out_signature = ref (fun _ -> failwith "Oprint.out_signature") +let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") +let out_functor_parameters = + ref (fun _ -> failwith "Oprint.out_functor_parameters") + +(* For anonymous functor arguments, the logic to choose between + the long-form + functor (_ : S) -> ... + and the short-form + S -> ... + is as follows: if we are already printing long-form functor arguments, + we use the long form unless all remaining functor arguments can use + the short form. (Otherwise use the short form.) + + For example, + functor (X : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end + will get printed as + functor (X : S1) (_ : S2) (Y : S3) -> S4 -> S5 -> sig end + + but + functor (_ : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end + gets printed as + S1 -> S2 -> functor (Y : S3) -> S4 -> S5 -> sig end +*) + +(* take a module type that may be a functor type, + and return the longest prefix list of arguments + that should be printed in long form. *) + +let rec collect_functor_args acc = function + | Omty_functor (param, mty_res) -> + collect_functor_args (param :: acc) mty_res + | non_functor -> (acc, non_functor) +let collect_functor_args mty = + let l, rest = collect_functor_args [] mty in + List.rev l, rest + +let constructor_of_extension_constructor + (ext : out_extension_constructor) : out_constructor += + { + ocstr_name = ext.oext_name; + ocstr_args = ext.oext_args; + ocstr_return_type = ext.oext_ret_type; + } + +let split_anon_functor_arguments params = + let rec uncollect_anonymous_suffix acc rest = match acc with + | Some (None, mty_arg) :: acc -> + uncollect_anonymous_suffix acc + (Some (None, mty_arg) :: rest) + | _ :: _ | [] -> + (acc, rest) + in + let (acc, rest) = uncollect_anonymous_suffix (List.rev params) [] in + (List.rev acc, rest) + +let rec print_out_module_type ppf mty = + print_out_functor ppf mty + +and print_out_functor_parameters ppf l = + let print_nonanon_arg ppf = function + | None -> + fprintf ppf "()" + | Some (param, mty) -> + fprintf ppf "(%s : %a)" + (Option.value param ~default:"_") + print_out_module_type mty + in + let rec print_args ppf = function + | [] -> () + | Some (None, mty_arg) :: l -> + fprintf ppf "%a ->@ %a" + print_simple_out_module_type mty_arg + print_args l + | _ :: _ as non_anonymous_functor -> + let args, anons = split_anon_functor_arguments non_anonymous_functor in + fprintf ppf "@[%a@]@ ->@ %a" + (pp_print_list ~pp_sep:pp_print_space print_nonanon_arg) args + print_args anons + in + print_args ppf l + +and print_out_functor ppf t = + let params, non_functor = collect_functor_args t in + fprintf ppf "@[<2>%a%a@]" + print_out_functor_parameters params + print_simple_out_module_type non_functor +and print_simple_out_module_type ppf = + function + Omty_abstract -> () + | Omty_ident id -> fprintf ppf "%a" print_ident id + | Omty_signature sg -> + begin match sg with + | [] -> fprintf ppf "sig end" + | sg -> + fprintf ppf "@[sig@ %a@;<1 -2>end@]" print_out_signature sg + end + | Omty_alias id -> fprintf ppf "(module %a)" print_ident id + | Omty_functor _ as non_simple -> + fprintf ppf "(%a)" print_out_module_type non_simple +and print_out_signature ppf = + function + [] -> () + | [item] -> !out_sig_item ppf item + | Osig_typext(ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + Osig_typext(ext, Oext_next) :: items -> + gather_extensions + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + items + in + let te = + { otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private } + in + fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items + | item :: items -> + fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items +and print_out_sig_item ppf = + function + Osig_class (vir_flag, name, params, clt, rs) -> + fprintf ppf "@[<2>%s%s@ %a%a@ :@ %a@]" + (if rs = Orec_next then "and" else "class") + (if vir_flag then " virtual" else "") print_out_class_params params + print_lident name !out_class_type clt + | Osig_class_type (vir_flag, name, params, clt, rs) -> + fprintf ppf "@[<2>%s%s@ %a%a@ =@ %a@]" + (if rs = Orec_next then "and" else "class type") + (if vir_flag then " virtual" else "") print_out_class_params params + print_lident name !out_class_type clt + | Osig_typext (ext, Oext_exception) -> + fprintf ppf "@[<2>exception %a@]" + print_out_constr (constructor_of_extension_constructor ext) + | Osig_typext (ext, _es) -> + print_out_extension_constructor ppf ext + | Osig_modtype (name, Omty_abstract) -> + fprintf ppf "@[<2>module type %s@]" name + | Osig_modtype (name, mty) -> + fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty + | Osig_module (name, Omty_alias id, _) -> + fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id + | Osig_module (name, mty, rs) -> + fprintf ppf "@[<2>%s %s :@ %a@]" + (match rs with Orec_not -> "module" + | Orec_first -> "module rec" + | Orec_next -> "and") + name !out_module_type mty + | Osig_type(td, rs) -> + print_out_type_decl + (match rs with + | Orec_not -> "type nonrec" + | Orec_first -> "type" + | Orec_next -> "and") + ppf td + | Osig_value vd -> + let kwd = if vd.oval_prims = [] then "val" else "external" in + let pr_prims ppf = + function + [] -> () + | s :: sl -> + fprintf ppf "@ = \"%s\"" s; + List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl + in + fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name + !out_type vd.oval_type pr_prims vd.oval_prims + (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name)) + vd.oval_attributes + | Osig_ellipsis -> + fprintf ppf "..." + +and print_out_type_decl kwd ppf td = + let print_constraints ppf = + List.iter + (fun (ty1, ty2) -> + fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1 + !out_type ty2) + td.otype_cstrs + in + let type_defined ppf = + match td.otype_params with + [] -> print_lident ppf td.otype_name + | [param] -> + fprintf ppf "@[%a@ %a@]" type_parameter param + print_lident td.otype_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %a@]" + (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) + td.otype_params + print_lident td.otype_name + in + let print_manifest ppf = + function + Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty + | _ -> () + in + let print_name_params ppf = + fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type + in + let ty = + match td.otype_type with + Otyp_manifest (_, ty) -> ty + | _ -> td.otype_type + in + let print_private ppf = function + Asttypes.Private -> fprintf ppf " private" + | Asttypes.Public -> () + in + let print_immediate ppf = + match td.otype_immediate with + | Unknown -> () + | Always -> fprintf ppf " [%@%@immediate]" + | Always_on_64bits -> fprintf ppf " [%@%@immediate64]" + in + let print_unboxed ppf = + if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else () + in + let print_out_tkind ppf = function + | Otyp_abstract -> () + | Otyp_record lbls -> + fprintf ppf " =%a %a" + print_private td.otype_private + print_record_decl lbls + | Otyp_sum constrs -> + let variants fmt constrs = + if constrs = [] then fprintf fmt "|" else + fprintf fmt "%a" (print_list print_out_constr + (fun ppf -> fprintf ppf "@ | ")) constrs in + fprintf ppf " =%a@;<1 2>%a" + print_private td.otype_private variants constrs + | Otyp_open -> + fprintf ppf " =%a .." + print_private td.otype_private + | ty -> + fprintf ppf " =%a@;<1 2>%a" + print_private td.otype_private + !out_type ty + in + fprintf ppf "@[<2>@[%t%a@]%t%t%t@]" + print_name_params + print_out_tkind ty + print_constraints + print_immediate + print_unboxed + +and print_out_constr ppf constr = + let { + ocstr_name = name; + ocstr_args = tyl; + ocstr_return_type = return_type; + } = constr in + let name = + match name with + | "::" -> "(::)" (* #7200 *) + | s -> s + in + match return_type with + | None -> + begin match tyl with + | [] -> + pp_print_string ppf name + | _ -> + fprintf ppf "@[<2>%s of@ %a@]" name + (print_typlist print_simple_out_type " *") tyl + end + | Some ret_type -> + begin match tyl with + | [] -> + fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type + | _ -> + fprintf ppf "@[<2>%s :@ %a -> %a@]" name + (print_typlist print_simple_out_type " *") + tyl print_simple_out_type ret_type + end + +and print_out_extension_constructor ppf ext = + let print_extended_type ppf = + match ext.oext_type_params with + [] -> fprintf ppf "%a" print_lident ext.oext_type_name + | [ty_param] -> + fprintf ppf "@[%a@ %a@]" + (print_type_parameter ~non_gen:false) + ty_param + print_lident ext.oext_type_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %a@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + ext.oext_type_params + print_lident ext.oext_type_name + in + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" + print_extended_type + (if ext.oext_private = Asttypes.Private then " private" else "") + print_out_constr + (constructor_of_extension_constructor ext) + +and print_out_type_extension ppf te = + let print_extended_type ppf = + match te.otyext_params with + [] -> fprintf ppf "%a" print_lident te.otyext_name + | [param] -> + fprintf ppf "@[%a@ %a@]" + (print_type_parameter ~non_gen:false) param + print_lident te.otyext_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %a@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + te.otyext_params + print_lident te.otyext_name + in + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" + print_extended_type + (if te.otyext_private = Asttypes.Private then " private" else "") + (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) + te.otyext_constructors + +let out_constr = ref print_out_constr +let _ = out_module_type := print_out_module_type +let _ = out_signature := print_out_signature +let _ = out_sig_item := print_out_sig_item +let _ = out_type_extension := print_out_type_extension +let _ = out_functor_parameters := print_out_functor_parameters + +(* Phrases *) + +open Format + +let print_out_exception ppf exn outv = + match exn with + Sys.Break -> fprintf ppf "Interrupted.@." + | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." + | Stack_overflow -> + fprintf ppf "Stack overflow during evaluation (looping recursion?).@." + | _ -> match Printexc.use_printers exn with + | None -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv + | Some s -> fprintf ppf "@[Exception:@ %s@]@." s + +let rec print_items ppf = + function + [] -> () + | (Osig_typext(ext, Oext_first), None) :: items -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + (Osig_typext(ext, Oext_next), None) :: items -> + gather_extensions + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + items + in + let te = + { otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private } + in + fprintf ppf "@[%a@]" (Format_doc.compat !out_type_extension) te; + if items <> [] then fprintf ppf "@ %a" print_items items + | (tree, valopt) :: items -> + begin match valopt with + Some v -> + fprintf ppf "@[<2>%a =@ %a@]" (Format_doc.compat !out_sig_item) tree + !out_value v + | None -> fprintf ppf "@[%a@]" (Format_doc.compat !out_sig_item) tree + end; + if items <> [] then fprintf ppf "@ %a" print_items items + +let print_out_phrase ppf = + function + Ophr_eval (outv, ty) -> + fprintf ppf "@[- : %a@ =@ %a@]@." (compat !out_type) ty !out_value outv + | Ophr_signature [] -> () + | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items + | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv + +let out_phrase = ref print_out_phrase + +type 'a printer = 'a Format_doc.printer ref +type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref diff --git a/upstream/ocaml_503/typing/oprint.mli b/upstream/ocaml_503/typing/oprint.mli new file mode 100644 index 000000000..8ce44f37e --- /dev/null +++ b/upstream/ocaml_503/typing/oprint.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Outcometree + +type 'a printer = 'a Format_doc.printer ref +type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref + +val out_ident: out_ident printer +val out_value : out_value toplevel_printer +val out_label : out_label printer +val out_type : out_type printer +val out_type_args : out_type list printer +val out_constr : out_constructor printer +val out_class_type : out_class_type printer +val out_module_type : out_module_type printer +val out_sig_item : out_sig_item printer +val out_signature :out_sig_item list printer +val out_functor_parameters : + (string option * Outcometree.out_module_type) option list printer +val out_type_extension : out_type_extension printer +val out_phrase : out_phrase toplevel_printer + +val parenthesized_ident : string -> bool diff --git a/upstream/ocaml_503/typing/out_type.ml b/upstream/ocaml_503/typing/out_type.ml new file mode 100644 index 000000000..d0daaead2 --- /dev/null +++ b/upstream/ocaml_503/typing/out_type.ml @@ -0,0 +1,1973 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compute a spanning tree representation of types *) + +open Misc +open Ctype +open Longident +open Path +open Asttypes +open Types +open Btype +open Outcometree + +module String = Misc.Stdlib.String +module Sig_component_kind = Shape.Sig_component_kind +module Style = Misc.Style + +(* Print a long identifier *) + +module Fmt = Format_doc +open Format_doc + +let longident = Pprintast.Doc.longident + +let () = Env.print_longident := longident + +(* Print an identifier avoiding name collisions *) + +module Out_name = struct + let create x = { printed_name = x } + let print x = x.printed_name +end + +(** Some identifiers may require hiding when printing *) +type bound_ident = { hide:bool; ident:Ident.t } + +(* printing environment for path shortening and naming *) +let printing_env = ref Env.empty + +(* When printing, it is important to only observe the + current printing environment, without reading any new + cmi present on the file system *) +let in_printing_env f = Env.without_cmis f !printing_env + + type namespace = Sig_component_kind.t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value | Constructor | Label -> 5 + (* we do not handle those component *) + + let size = 1 + id Value + + + let pp ppf x = + Fmt.pp_print_string ppf (Shape.Sig_component_kind.to_string x) + + (** The two functions below should never access the filesystem, + and thus use {!in_printing_env} rather than directly + accessing the printing environment *) + let lookup = + let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in + function + | Some Type -> to_lookup Env.find_type_by_name + | Some Module -> to_lookup Env.find_module_by_name + | Some Module_type -> to_lookup Env.find_modtype_by_name + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | None | Some(Value|Extension_constructor|Constructor|Label) -> + fun _ -> raise Not_found + + let location namespace id = + let path = Path.Pident id in + try Some ( + match namespace with + | Some Type -> (in_printing_env @@ Env.find_type path).type_loc + | Some Module -> (in_printing_env @@ Env.find_module path).md_loc + | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc + | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc + | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc + | Some (Extension_constructor|Value|Constructor|Label) | None -> + Location.none + ) with Not_found -> None + + let best_class_namespace = function + | Papply _ | Pdot _ -> Some Module + | Pextra_ty _ -> assert false (* Only in type path *) + | Pident c -> + match location (Some Class) c with + | Some _ -> Some Class + | None -> Some Class_type + +end + +(** {2 Ident conflicts printing} + + Ident conflicts arise when multiple {!Ident.t}s are attributed the same name. + The following module stores the global conflict references and provides the + printing functions for explaining the source of the conflicts. +*) +module Ident_conflicts = struct + module M = String.Map + type explanation = + { kind: namespace; name:string; root_name:string; location:Location.t} + let explanations = ref M.empty + + let add namespace name id = + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = + { kind = namespace; location; name; root_name=Ident.name id} + in + explanations := M.add name explanation !explanations + + let collect_explanation namespace id ~name = + let root_name = Ident.name id in + (* if [name] is of the form "root_name/%d", we register both + [id] and the identifier in scope for [root_name]. + *) + if root_name <> name && not (M.mem name !explanations) then + begin + add namespace name id; + if not (M.mem root_name !explanations) then + (* lookup the identifier in scope with name [root_name] and + add it too + *) + match Namespace.lookup (Some namespace) root_name with + | Pident root_id -> add namespace root_name root_id + | exception Not_found | _ -> () + end + + let pp_explanation ppf r= + Fmt.fprintf ppf "@[%a:@,Definition of %s %a@]" + Location.Doc.loc r.location (Sig_component_kind.to_string r.kind) + Style.inline_code r.name + + let print_located_explanations ppf l = + Fmt.fprintf ppf "@[%a@]" + (Fmt.pp_print_list pp_explanation) l + + let reset () = explanations := M.empty + let list_explanations () = + let c = !explanations in + reset (); + c |> M.bindings |> List.map snd |> List.sort Stdlib.compare + + + let print_toplevel_hint ppf l = + let conj ppf () = Fmt.fprintf ppf " and@ " in + let pp_namespace_plural ppf n = Fmt.fprintf ppf "%as" Namespace.pp n in + let root_names = List.map (fun r -> r.kind, r.root_name) l in + let unique_root_names = List.sort_uniq Stdlib.compare root_names in + let submsgs = Array.make Namespace.size [] in + let () = List.iter (fun (n,_ as x) -> + submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) + ) unique_root_names in + let pp_submsg ppf names = + match names with + | [] -> () + | [namespace, a] -> + Fmt.fprintf ppf + "@,\ + @[<2>@{Hint@}: The %a %a has been defined multiple times@ \ + in@ this@ toplevel@ session.@ \ + Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ + @ Did you try to redefine them?@]" + Namespace.pp namespace + Style.inline_code a Namespace.pp namespace + | (namespace, _) :: _ :: _ -> + Fmt.fprintf ppf + "@,\ + @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ + in@ this@ toplevel@ session.@ \ + Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ + @ Did you try to redefine them?@]" + pp_namespace_plural namespace + Fmt.(pp_print_list ~pp_sep:conj Style.inline_code) + (List.map snd names) + pp_namespace_plural namespace in + Array.iter (pp_submsg ppf) submsgs + + let err_msg () = + let ltop, l = + (* isolate toplevel locations, since they are too imprecise *) + let from_toplevel a = + a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in + List.partition from_toplevel (list_explanations ()) + in + match l, ltop with + | [], [] -> None + | _ -> + Some + (Fmt.doc_printf "%a%a" + print_located_explanations l + print_toplevel_hint ltop + ) + let err_print ppf = Option.iter Fmt.(fprintf ppf "@,%a" pp_doc) (err_msg ()) + + let exists () = M.cardinal !explanations >0 +end + +module Ident_names = struct + +module M = String.Map +module S = String.Set + +let enabled = ref true +let enable b = enabled := b + +(* Names bound in recursive definitions should be considered as bound + in the environment when printing identifiers but not when trying + to find shortest path. + For instance, if we define + [{ + module Avoid__me = struct + type t = A + end + type t = X + type u = [` A of t * t ] + module M = struct + type t = A of [ u | `B ] + type r = Avoid__me.t + end + }] + It is is important that in the definition of [t] that the outer type [t] is + printed as [t/2] reserving the name [t] to the type being defined in the + current recursive definition. + Contrarily, in the definition of [r], one should not shorten the + path [Avoid__me.t] to [r] until the end of the definition of [r]. + The [bound_in_recursion] bridges the gap between those two slightly different + notions of printing environment. +*) +let bound_in_recursion = ref M.empty + +(* When dealing with functor arguments, identity becomes fuzzy because the same + syntactic argument may be represented by different identifiers during the + error processing, we are thus disabling disambiguation on the argument name +*) +let fuzzy = ref S.empty +let with_fuzzy id f = + protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f +let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy + +let with_hidden ids f = + let update m id = M.add (Ident.name id.ident) id.ident m in + let updated = List.fold_left update !bound_in_recursion ids in + protect_refs [ R(bound_in_recursion, updated )] f + +let human_id id index = + (* The identifier with index [k] is the (k+1)-th most recent identifier in + the printing environment. We print them as [name/(k+1)] except for [k=0] + which is printed as [name] rather than [name/1]. + *) + if index = 0 then + Ident.name id + else + let ordinal = index + 1 in + String.concat "/" [Ident.name id; string_of_int ordinal] + +let indexed_name namespace id = + let find namespace id env = match namespace with + | Type -> Env.find_type_index id env + | Module -> Env.find_module_index id env + | Module_type -> Env.find_modtype_index id env + | Class -> Env.find_class_index id env + | Class_type-> Env.find_cltype_index id env + | Value | Extension_constructor | Constructor | Label -> None + in + let index = + match M.find_opt (Ident.name id) !bound_in_recursion with + | Some rec_bound_id -> + (* the identifier name appears in the current group of recursive + definition *) + if Ident.same rec_bound_id id then + Some 0 + else + (* the current recursive definition shadows one more time the + previously existing identifier with the same name *) + Option.map succ (in_printing_env (find namespace id)) + | None -> + in_printing_env (find namespace id) + in + let index = + (* If [index] is [None] at this point, it might indicate that + the identifier id is not defined in the environment, while there + are other identifiers in scope that share the same name. + Currently, this kind of partially incoherent environment happens + within functor error messages where the left and right hand side + have a different views of the environment at the source level. + Printing the source-level by using a default index of `0` + seems like a reasonable compromise in this situation however.*) + Option.value index ~default:0 + in + human_id id index + +let ident_name namespace id = + match namespace, !enabled with + | None, _ | _, false -> Out_name.create (Ident.name id) + | Some namespace, true -> + if fuzzy_id namespace id then Out_name.create (Ident.name id) + else + let name = indexed_name namespace id in + Ident_conflicts.collect_explanation namespace id ~name; + Out_name.create name +end +let ident_name = Ident_names.ident_name + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_stdlib namespace = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match Namespace.lookup namespace s with + | path' -> Path.same path path' + | exception Not_found -> true) + | _ -> false + +let find_double_underscore s = + let len = String.length s in + let rec loop i = + if i + 1 >= len then + None + else if s.[i] = '_' && s.[i + 1] = '_' then + Some i + else + loop (i + 1) + in + loop 0 + +let rec module_path_is_an_alias_of env path ~alias_of = + match Env.find_module path env with + | { md_type = Mty_alias path'; _ } -> + Path.same path' alias_of || + module_path_is_an_alias_of env path' ~alias_of + | _ -> false + | exception Not_found -> false + +(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias + for Foo__bar. This pattern is used by the stdlib. *) +let rec rewrite_double_underscore_paths env p = + match p with + | Pdot (p, s) -> + Pdot (rewrite_double_underscore_paths env p, s) + | Papply (a, b) -> + Papply (rewrite_double_underscore_paths env a, + rewrite_double_underscore_paths env b) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths env p, extra) + | Pident id -> + let name = Ident.name id in + match find_double_underscore name with + | None -> p + | Some i -> + let better_lid = + Ldot + (Lident (String.sub name 0 i), + Unit_info.modulize + (String.sub name (i + 2) (String.length name - i - 2))) + in + match Env.find_module_by_name better_lid env with + | exception Not_found -> p + | p', _ -> + if module_path_is_an_alias_of env p' ~alias_of:p then + p' + else + p + +let rewrite_double_underscore_paths env p = + if env == Env.empty then + p + else + rewrite_double_underscore_paths env p + +let rec tree_of_path ?(disambiguation=true) namespace p = + let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in + let namespace = if disambiguation then namespace else None in + match p with + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> + Oide_ident (Out_name.create s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + let t1 = tree_of_path (Some Module) p1 in + let t2 = tree_of_path (Some Module) p2 in + Oide_apply (t1, t2) + | Pextra_ty (p, extra) -> begin + (* inline record types are syntactically prevented from escaping their + binding scope, and are never shown to users. *) + match extra with + Pcstr_ty s -> + Oide_dot (tree_of_path (Some Type) p, s) + | Pext_ty -> + tree_of_path None p + end + +let tree_of_path ?disambiguation namespace p = + tree_of_path ?disambiguation namespace + (rewrite_double_underscore_paths !printing_env p) + + +(* Print a recursive annotation *) + +let tree_of_rec = function + | Trec_not -> Orec_not + | Trec_first -> Orec_first + | Trec_next -> Orec_next + +(* Normalize paths *) + +type param_subst = Id | Nth of int | Map of int list + +let is_nth = function + Nth _ -> true + | _ -> false + +let compose l1 = function + | Id -> Map l1 + | Map l2 -> Map (List.map (List.nth l1) l2) + | Nth n -> Nth (List.nth l1 n) + +let apply_subst s1 tyl = + if tyl = [] then [] + (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) + else + match s1 with + Nth n1 -> [List.nth tyl n1] + | Map l1 -> List.map (List.nth tyl) l1 + | Id -> tyl + +type best_path = Paths of Path.t list | Best of Path.t + +(** Short-paths cache: the five mutable variables below implement a one-slot + cache for short-paths + *) +let printing_old = ref Env.empty +let printing_pers = ref String.Set.empty +(** {!printing_old} and {!printing_pers} are the keys of the one-slot cache *) + +let printing_depth = ref 0 +let printing_cont = ref ([] : Env.iter_cont list) +let printing_map = ref Path.Map.empty +(** + - {!printing_map} is the main value stored in the cache. + Note that it is evaluated lazily and its value is updated during printing. + - {!printing_dep} is the current exploration depth of the environment, + it is used to determine whenever the {!printing_map} should be evaluated + further before completing a request. + - {!printing_cont} is the list of continuations needed to evaluate + the {!printing_map} one level further (see also {!Env.run_iter_cont}) +*) + +let rec index l x = + match l with + [] -> raise Not_found + | a :: l -> if eq_type x a then 0 else 1 + index l x + +let rec uniq = function + [] -> true + | a :: l -> not (List.memq (a : int) l) && uniq l + +let rec normalize_type_path ?(cache=false) env p = + try + let (params, ty, _) = Env.find_type_expansion p env in + match get_desc ty with + Tconstr (p1, tyl, _) -> + if List.length params = List.length tyl + && List.for_all2 eq_type params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl + || not (uniq (List.map get_id tyl)) then (p, Id) + else + let l1 = List.map (index params) tyl in + let (p2, s2) = normalize_type_path ~cache env p1 in + (p2, compose l1 s2) + | _ -> + (p, Nth (index params ty)) + with + Not_found -> + (Env.normalize_type_path None env p, Id) + +let penalty s = + if s <> "" && s.[0] = '_' then + 10 + else + match find_double_underscore s with + | None -> 1 + | Some _ -> 10 + +let rec path_size = function + Pident id -> + penalty (Ident.name id), -Ident.scope id + | Pdot (p, _) | Pextra_ty (p, Pcstr_ty _) -> + let (l, b) = path_size p in (1+l, b) + | Papply (p1, p2) -> + let (l, b) = path_size p1 in + (l + fst (path_size p2), b) + | Pextra_ty (p, _) -> path_size p + +let same_printing_env env = + let used_pers = Env.used_persistent () in + Env.same_types !printing_old env && String.Set.equal !printing_pers used_pers + +let set_printing_env env = + printing_env := env; + if !Clflags.real_paths || + !printing_env == Env.empty || + same_printing_env env then + () + else begin + (* printf "Reset printing_map@."; *) + printing_old := env; + printing_pers := Env.used_persistent (); + printing_map := Path.Map.empty; + printing_depth := 0; + (* printf "Recompute printing_map.@."; *) + let cont = + Env.iter_types + (fun p (p', _decl) -> + let (p1, s1) = normalize_type_path env p' ~cache:true in + (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) + if s1 = Id then + try + let r = Path.Map.find p1 !printing_map in + match !r with + Paths l -> r := Paths (p :: l) + | Best p' -> r := Paths [p; p'] (* assert false *) + with Not_found -> + printing_map := Path.Map.add p1 (ref (Paths [p])) !printing_map) + env in + printing_cont := [cont]; + end + +let wrap_printing_env env f = + set_printing_env env; + try_finally f ~always:(fun () -> set_printing_env Env.empty) + +let wrap_printing_env ~error env f = + if error then Env.without_cmis (wrap_printing_env env) f + else wrap_printing_env env f + +let rec lid_of_path = function + Path.Pident id -> + Longident.Lident (Ident.name id) + | Path.Pdot (p1, s) | Path.Pextra_ty (p1, Pcstr_ty s) -> + Longident.Ldot (lid_of_path p1, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lid_of_path p1, lid_of_path p2) + | Path.Pextra_ty (p, Pext_ty) -> lid_of_path p + +let is_unambiguous path env = + let l = Env.find_shadowed_types path env in + List.exists (Path.same path) l || (* concrete paths are ok *) + match l with + [] -> true + | p :: rem -> + (* allow also coherent paths: *) + let normalize p = fst (normalize_type_path ~cache:true env p) in + let p' = normalize p in + List.for_all (fun p -> Path.same (normalize p) p') rem || + (* also allow repeatedly defining and opening (for toplevel) *) + let id = lid_of_path p in + List.for_all (fun p -> lid_of_path p = id) rem && + Path.same p (fst (Env.find_type_by_name id env)) + +let rec get_best_path r = + match !r with + Best p' -> p' + | Paths [] -> raise Not_found + | Paths l -> + r := Paths []; + List.iter + (fun p -> + (* Format.eprintf "evaluating %a@." path p; *) + match !r with + Best p' when path_size p >= path_size p' -> () + | _ -> if is_unambiguous p !printing_env then r := Best p) + (* else Format.eprintf "%a ignored as ambiguous@." path p *) + l; + get_best_path r + +let best_type_path p = + if !printing_env == Env.empty + then (p, Id) + else if !Clflags.real_paths + then (p, Id) + else + let (p', s) = normalize_type_path !printing_env p in + let get_path () = get_best_path (Path.Map.find p' !printing_map) in + while !printing_cont <> [] && + try fst (path_size (get_path ())) > !printing_depth with Not_found -> true + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth; + done; + let p'' = try get_path () with Not_found -> p' in + (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) + (p'', s) + +(* When building a tree for a best type path, we should not disambiguate + identifiers whenever the short-path algorithm detected a better path than + the original one.*) +let tree_of_best_type_path p p' = + if Path.same p p' then tree_of_path (Some Type) p' + else tree_of_path ~disambiguation:false None p' + +(* Print a type expression *) + +let proxy ty = Transient_expr.repr (proxy ty) + +(* When printing a type scheme, we print weak names. When printing a plain + type, we do not. This type controls that behavior *) +type type_or_scheme = Type | Type_scheme + +let is_non_gen mode ty = + match mode with + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level + | Type -> false + +let nameable_row row = + row_name row <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _) -> + row_closed row && if c then l = [] else List.length l = 1 + | _ -> true) + (row_fields row) + +(* This specialized version of [Btype.iter_type_expr] normalizes and + short-circuits the traversal of the [type_expr], so that it covers only the + subterms that would be printed by the type printer. *) +let printer_iter_type_expr f ty = + match get_desc ty with + | Tconstr(p, tyl, _) -> + let (_p', s) = best_type_path p in + List.iter f (apply_subst s tyl) + | Tvariant row -> begin + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter f tyl + | _ -> + iter_row f row + end + | Tobject (fi, nm) -> begin + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + f ty) + fields + | Some (_, l) -> + List.iter f (List.tl l) + end + | Tfield(_, kind, ty1, ty2) -> + if field_kind_repr kind = Fpublic then + f ty1; + f ty2 + | _ -> + Btype.iter_type_expr f ty + +let quoted_ident ppf x = + Style.as_inline_code !Oprint.out_ident ppf x + +module Internal_names : sig + + val reset : unit -> unit + + val add : Path.t -> unit + + val print_explanations : Env.t -> Fmt.formatter -> unit + +end = struct + + let names = ref Ident.Set.empty + + let reset () = + names := Ident.Set.empty + + let add p = + match p with + | Pident id -> + let name = Ident.name id in + if String.length name > 0 && name.[0] = '$' then begin + names := Ident.Set.add id !names + end + | Pdot _ | Papply _ | Pextra_ty _ -> () + + let print_explanations env ppf = + let constrs = + Ident.Set.fold + (fun id acc -> + let p = Pident id in + match Env.find_type p env with + | exception Not_found -> acc + | decl -> + match type_origin decl with + | Existential constr -> + let prev = String.Map.find_opt constr acc in + let prev = Option.value ~default:[] prev in + String.Map.add constr (tree_of_path None p :: prev) acc + | Definition | Rec_check_regularity -> acc) + !names String.Map.empty + in + String.Map.iter + (fun constr out_idents -> + match out_idents with + | [] -> () + | [out_ident] -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ + bound by the constructor@ %a.@]" + quoted_ident out_ident + Style.inline_code constr + | out_ident :: out_idents -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ + bound by the constructor@ %a.@]" + (Fmt.pp_print_list + ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") + quoted_ident) + (List.rev out_idents) + quoted_ident out_ident + Style.inline_code constr) + constrs + +end + +module Variable_names : sig + val reset_names : unit -> unit + + val add_subst : (type_expr * type_expr) list -> unit + + val new_name : unit -> string + val new_var_name : non_gen:bool -> type_expr -> unit -> string + + val name_of_type : (unit -> string) -> transient_expr -> string + val check_name_of_type : non_gen:bool -> transient_expr -> unit + + + val reserve: type_expr -> unit + + val remove_names : transient_expr list -> unit + + val with_local_names : (unit -> 'a) -> 'a + + (* Refresh the weak variable map in the toplevel; for [print_items], which is + itself for the toplevel *) + val refresh_weak : unit -> unit +end = struct + (* We map from types to names, but not directly; we also store a substitution, + which maps from types to types. The lookup process is + "type -> apply substitution -> find name". The substitution is presumed to + be one-shot. *) + let names = ref ([] : (transient_expr * string) list) + let name_subst = ref ([] : (transient_expr * transient_expr) list) + let name_counter = ref 0 + let named_vars = ref ([] : string list) + let visited_for_named_vars = ref ([] : transient_expr list) + + let weak_counter = ref 1 + let weak_var_map = ref TypeMap.empty + let named_weak_vars = ref String.Set.empty + + let reset_names () = + names := []; + name_subst := []; + name_counter := 0; + named_vars := []; + visited_for_named_vars := [] + + let add_named_var tty = + match tty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () + + let rec add_named_vars ty = + let tty = Transient_expr.repr ty in + let px = proxy ty in + if not (List.memq px !visited_for_named_vars) then begin + visited_for_named_vars := px :: !visited_for_named_vars; + match tty.desc with + | Tvar _ | Tunivar _ -> + add_named_var tty + | _ -> + printer_iter_type_expr add_named_vars ty + end + + let substitute ty = + match List.assq ty !name_subst with + | ty' -> ty' + | exception Not_found -> ty + + let add_subst subst = + name_subst := + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) + subst + @ !name_subst + + let name_is_already_used name = + List.mem name !named_vars + || List.exists (fun (_, name') -> name = name') !names + || String.Set.mem name !named_weak_vars + + let rec new_name () = + let name = Misc.letter_of_int !name_counter in + incr name_counter; + if name_is_already_used name then new_name () else name + + let rec new_weak_name ty () = + let name = "weak" ^ Int.to_string !weak_counter in + incr weak_counter; + if name_is_already_used name then new_weak_name ty () + else begin + named_weak_vars := String.Set.add name !named_weak_vars; + weak_var_map := TypeMap.add ty name !weak_var_map; + name + end + + let new_var_name ~non_gen ty () = + if non_gen then new_weak_name ty () + else new_name () + + let name_of_type name_generator t = + (* We've already been through repr at this stage, so t is our representative + of the union-find class. *) + let t = substitute t in + try List.assq t !names with Not_found -> + try TransientTypeMap.find t !weak_var_map with Not_found -> + let name = + match t.desc with + Tvar (Some name) | Tunivar (Some name) -> + (* Some part of the type we've already printed has assigned another + * unification variable to that name. We want to keep the name, so + * try adding a number until we find a name that's not taken. *) + let available name = + List.for_all + (fun (_, name') -> name <> name') + !names + in + if available name then name + else + let suffixed i = name ^ Int.to_string i in + let i = Misc.find_first_mono (fun i -> available (suffixed i)) in + suffixed i + | _ -> + (* No name available, create a new one *) + name_generator () + in + (* Exception for type declarations *) + if name <> "_" then names := (t, name) :: !names; + name + + let check_name_of_type ~non_gen px = + let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in + ignore(name_of_type name_gen px) + + let remove_names tyl = + let tyl = List.map substitute tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let with_local_names f = + let old_names = !names in + let old_subst = !name_subst in + names := []; + name_subst := []; + try_finally + ~always:(fun () -> + names := old_names; + name_subst := old_subst) + f + + let refresh_weak () = + let refresh t name (m,s) = + if is_non_gen Type_scheme t then + begin + TypeMap.add t name m, + String.Set.add name s + end + else m, s in + let m, s = + TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in + named_weak_vars := s; + weak_var_map := m + + let reserve ty = + normalize_type ty; + add_named_vars ty +end + +module Aliases = struct + let visited_objects = ref ([] : transient_expr list) + let aliased = ref ([] : transient_expr list) + let delayed = ref ([] : transient_expr list) + let printed_aliases = ref ([] : transient_expr list) + +(* [printed_aliases] is a subset of [aliased] that records only those aliased + types that have actually been printed; this allows us to avoid naming loops + that the user will never see. *) + + let is_delayed t = List.memq t !delayed + + let remove_delay t = + if is_delayed t then + delayed := List.filter ((!=) t) !delayed + + let add_delayed t = + if not (is_delayed t) then delayed := t :: !delayed + + let is_aliased_proxy px = List.memq px !aliased + let is_printed_proxy px = List.memq px !printed_aliases + + let add_proxy px = + if not (is_aliased_proxy px) then + aliased := px :: !aliased + + let add ty = add_proxy (proxy ty) + + let add_printed_proxy ~non_gen px = + Variable_names.check_name_of_type ~non_gen px; + printed_aliases := px :: !printed_aliases + + let mark_as_printed px = + if is_aliased_proxy px then (add_printed_proxy ~non_gen:false) px + + let add_printed ty = add_printed_proxy (proxy ty) + + let aliasable ty = + match get_desc ty with + Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> + not (is_nth (snd (best_type_path p))) + | _ -> true + + let should_visit_object ty = + match get_desc ty with + | Tvariant row -> not (static_row row) + | Tobject _ -> opened_object ty + | _ -> false + + let rec mark_loops_rec visited ty = + let px = proxy ty in + if List.memq px visited && aliasable ty then add_proxy px else + let tty = Transient_expr.repr ty in + let visited = px :: visited in + match tty.desc with + | Tvariant _ | Tobject _ -> + if List.memq px !visited_objects then add_proxy px else begin + if should_visit_object ty then + visited_objects := px :: !visited_objects; + printer_iter_type_expr (mark_loops_rec visited) ty + end + | Tpoly(ty, tyl) -> + List.iter add tyl; + mark_loops_rec visited ty + | _ -> + printer_iter_type_expr (mark_loops_rec visited) ty + + let mark_loops ty = + mark_loops_rec [] ty + + let reset () = + visited_objects := []; aliased := []; delayed := []; printed_aliases := [] + +end + +let prepare_type ty = + Variable_names.reserve ty; + Aliases.mark_loops ty + + +let reset_except_conflicts () = + Variable_names.reset_names (); Aliases.reset (); Internal_names.reset () + +let reset () = + Ident_conflicts.reset (); + reset_except_conflicts () + +let prepare_for_printing tyl = + reset_except_conflicts (); + List.iter prepare_type tyl + +let add_type_to_preparation = prepare_type + +(* Disabled in classic mode when printing an unification error *) +let print_labels = ref true +let with_labels b f = Misc.protect_refs [R (print_labels,b)] f + +let alias_nongen_row mode px ty = + match get_desc ty with + | Tvariant _ | Tobject _ -> + if is_non_gen mode (Transient_expr.type_expr px) then + Aliases.add_proxy px + | _ -> () + +let rec tree_of_typexp mode ty = + let px = proxy ty in + if Aliases.is_printed_proxy px && not (Aliases.is_delayed px) then + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + let name = Variable_names.(name_of_type (new_var_name ~non_gen ty)) px in + Otyp_var (non_gen, name) else + + let pr_typ () = + let tty = Transient_expr.repr ty in + match tty.desc with + | Tvar _ -> + let non_gen = is_non_gen mode ty in + let name_gen = Variable_names.new_var_name ~non_gen ty in + Otyp_var (non_gen, Variable_names.name_of_type name_gen tty) + | Tarrow(l, ty1, ty2, _) -> + let lab = + if !print_labels || is_optional l then l else Nolabel + in + let t1 = + if is_optional l then + match get_desc ty1 with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty1 in + Otyp_arrow (lab, t1, tree_of_typexp mode ty2) + | Ttuple tyl -> + Otyp_tuple (tree_of_typlist mode tyl) + | Tconstr(p, tyl, _abbrev) -> + let p', s = best_type_path p in + let tyl' = apply_subst s tyl in + if is_nth s && not (tyl'=[]) + then tree_of_typexp mode (List.hd tyl') + else begin + Internal_names.add p'; + Otyp_constr (tree_of_best_type_path p p', tree_of_typlist mode tyl') + end + | Tvariant row -> + let Row {fields; name; closed; _} = row_repr row in + let fields = + if closed then + List.filter (fun (_, f) -> row_field_repr f <> Rabsent) + fields + else fields in + let present = + List.filter + (fun (_, f) -> + match row_field_repr f with + | Rpresent _ -> true + | _ -> false) + fields in + let all_present = List.length present = List.length fields in + begin match name with + | Some(p, tyl) when nameable_row row -> + let (p', s) = best_type_path p in + let id = tree_of_best_type_path p p' in + let args = tree_of_typlist mode (apply_subst s tyl) in + let out_variant = + if is_nth s then List.hd args else Otyp_constr (id, args) in + if closed && all_present then + out_variant + else + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_typ out_variant, closed, tags) + | _ -> + let fields = List.map (tree_of_row_field mode) fields in + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tnil | Tfield _ -> + tree_of_typobject mode ty None + | Tsubst _ -> + (* This case should only happen when debugging the compiler *) + Otyp_stuff "" + | Tlink _ -> + fatal_error "Out_type.tree_of_typexp" + | Tpoly (ty, []) -> + tree_of_typexp mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + if tyl = [] then tree_of_typexp mode ty else begin + let tyl = List.map Transient_expr.repr tyl in + let old_delayed = !Aliases.delayed in + (* Make the names delayed, so that the real type is + printed once when used as proxy *) + List.iter Aliases.add_delayed tyl; + let tl = List.map Variable_names.(name_of_type new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode ty) in + (* Forget names when we leave scope *) + Variable_names.remove_names tyl; + Aliases.delayed := old_delayed; tr + end + | Tunivar _ -> + Otyp_var (false, Variable_names.(name_of_type new_name) tty) + | Tpackage (p, fl) -> + let fl = + List.map + (fun (li, ty) -> ( + String.concat "." (Longident.flatten li), + tree_of_typexp mode ty + )) fl in + Otyp_module (tree_of_path (Some Module_type) p, fl) + in + Aliases.remove_delay px; + alias_nongen_row mode px ty; + if Aliases.(is_aliased_proxy px && aliasable ty) then begin + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + Aliases.add_printed_proxy ~non_gen px; + (* add_printed_alias chose a name, thus the name generator + doesn't matter.*) + let alias = Variable_names.(name_of_type (new_var_name ~non_gen ty)) px in + Otyp_alias {non_gen; aliased = pr_typ (); alias } end + else pr_typ () + +and tree_of_row_field mode (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tree_of_typlist mode tyl) + else (l, false, tree_of_typlist mode tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode) tyl + +and tree_of_typobject mode fi nm = + begin match nm with + | None -> + let pr_fields fi = + let (fields, rest) = flatten_fields fi in + let present_fields = + List.fold_right + (fun (n, k, t) l -> + match field_kind_repr k with + | Fpublic -> (n, t) :: l + | _ -> l) + fields [] in + let sorted_fields = + List.sort + (fun (n, _) (n', _) -> String.compare n n') present_fields in + tree_of_typfields mode rest sorted_fields in + let (fields, open_row) = pr_fields fi in + Otyp_object {fields; open_row} + | Some (p, _ty :: tyl) -> + let args = tree_of_typlist mode tyl in + let (p', s) = best_type_path p in + assert (s = Id); + Otyp_class (tree_of_best_type_path p p', args) + | _ -> + fatal_error "Out_type.tree_of_typobject" + end + +and tree_of_typfields mode rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | (s, t) :: l -> + let field = (s, tree_of_typexp mode t) in + let (fields, rest) = tree_of_typfields mode rest l in + (field :: fields, rest) + +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + +let prepared_type_expr ppf ty = typexp Type ppf ty + +(* "Half-prepared" type expression: [ty] should have had its names reserved, but + should not have had its loops marked. *) +let type_expr_with_reserved_names ppf ty = + Aliases.reset (); + Aliases.mark_loops ty; + prepared_type_expr ppf ty + + +let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty + +(* Print one type declaration *) + +let tree_of_constraints params = + List.fold_right + (fun ty list -> + let ty' = unalias ty in + if proxy ty != proxy ty' then + let tr = tree_of_typexp Type_scheme ty in + (tr, tree_of_typexp Type_scheme ty') :: list + else list) + params [] + +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + if List.exists (eq_type ty) tyl + then newty2 ~level:generic_level (Ttuple [ty]) :: tyl + else ty :: tyl) + (* Two parameters might be identical due to a constraint but we need to + print them differently in order to make the output syntactically valid. + We use [Ttuple [ty]] because it is printed as [ty]. *) + (* Replacing fold_left by fold_right does not work! *) + [] tyl + in List.rev params + +let prepare_type_constructor_arguments = function + | Cstr_tuple l -> List.iter prepare_type l + | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l + +let tree_of_label l = + { + olab_name = Ident.name l.ld_id; + olab_mut = l.ld_mutable; + olab_type = tree_of_typexp Type l.ld_type; + } + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist Type l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let ret = Option.map (tree_of_typexp Type) cd.cd_res in + let args = tree_of_constructor_arguments cd.cd_args in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* When printing GADT constructor, we need to forget the naming decision we took + for the type parameters and constraints. Indeed, in + {[ + type 'a t = X: 'a -> 'b t + ]} + It is fine to print both the type parameter ['a] and the existentially + quantified ['a] in the definition of the constructor X as ['a] + *) +let tree_of_constructor_in_decl cd = + match cd.cd_res with + | None -> tree_of_single_constructor cd + | Some _ -> + Variable_names.with_local_names (fun () -> tree_of_single_constructor cd) + +let prepare_decl id decl = + let params = filter_params decl.type_params in + begin match decl.type_manifest with + | Some ty -> + let vars = free_variables ty in + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + params + | None -> () + end; + List.iter Aliases.add params; + List.iter prepare_type params; + List.iter (Aliases.add_printed ~non_gen:false) params; + let ty_manifest = + match decl.type_manifest with + | None -> None + | Some ty -> + let ty = + (* Special hack to hide variant name *) + match get_desc ty with + Tvariant row -> + begin match row_name row with + Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant (set_row_name row None)) + | _ -> ty + end + | _ -> ty + in + prepare_type ty; + Some ty + in + begin match decl.type_kind with + | Type_abstract _ -> () + | Type_variant (cstrs, _rep) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_open -> () + end; + ty_manifest, params + +let tree_of_type_decl id decl = + let ty_manifest, params = prepare_decl id decl in + let type_param ot_variance = + function + | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} + in + let type_defined decl = + let abstr = + match decl.type_kind with + Type_abstract _ -> + decl.type_manifest = None || decl.type_private = Private + | Type_record _ -> + decl.type_private = Private + | Type_variant (tll, _rep) -> + decl.type_private = Private || + List.exists (fun cd -> cd.cd_res <> None) tll + | Type_open -> + decl.type_manifest = None + in + let vari = + List.map2 + (fun ty v -> + let is_var = is_Tvar ty in + if abstr || not is_var then + let inj = + type_kind_is_abstract decl && Variance.mem Inj v && + match decl.type_manifest with + | None -> true + | Some ty -> (* only abstract or private row types *) + decl.type_private = Private && + Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty) + and (co, cn) = Variance.get_upper v in + (if not cn then Covariant else + if not co then Contravariant else NoVariance), + (if inj then Injective else NoInjectivity) + else (NoVariance, NoInjectivity)) + decl.type_params decl.type_variance + in + (Ident.name id, + List.map2 (fun ty cocn -> type_param cocn (tree_of_typexp Type ty)) + params vari) + in + let tree_of_manifest ty1 = + match ty_manifest with + | None -> ty1 + | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) + in + let (name, args) = type_defined decl in + let constraints = tree_of_constraints params in + let ty, priv, unboxed = + match decl.type_kind with + | Type_abstract _ -> + begin match ty_manifest with + | None -> (Otyp_abstract, Public, false) + | Some ty -> + tree_of_typexp Type ty, decl.type_private, false + end + | Type_variant (cstrs, rep) -> + tree_of_manifest + (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), + decl.type_private, + (rep = Variant_unboxed) + | Type_record(lbls, rep) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private, + (match rep with Record_unboxed _ -> true | _ -> false) + | Type_open -> + tree_of_manifest Otyp_open, + decl.type_private, + false + in + { otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_immediate = Type_immediacy.of_attributes decl.type_attributes; + otype_unboxed = unboxed; + otype_cstrs = constraints } + +let add_type_decl_to_preparation id decl = + ignore @@ prepare_decl id decl + +let tree_of_prepared_type_decl id decl = + tree_of_type_decl id decl + +let tree_of_type_decl id decl = + reset_except_conflicts(); + tree_of_type_decl id decl + +let add_constructor_to_preparation c = + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res + +let prepared_constructor ppf c = + !Oprint.out_constr ppf (tree_of_single_constructor c) + + +let tree_of_type_declaration id decl rs = + Osig_type (tree_of_type_decl id decl, tree_of_rec rs) + +let tree_of_prepared_type_declaration id decl rs = + Osig_type (tree_of_prepared_type_decl id decl, tree_of_rec rs) + +let add_type_declaration_to_preparation id decl = + add_type_decl_to_preparation id decl + +let prepared_type_declaration id ppf decl = + !Oprint.out_sig_item ppf + (tree_of_prepared_type_declaration id decl Trec_first) + + +(* When printing extension constructor, it is important to ensure that +after printing the constructor, we are still in the scope of the constructor. +For GADT constructor, this can be done by printing the type parameters inside +their own isolated scope. This ensures that in +{[ + type 'b t += A: 'b -> 'b any t +]} +the type parameter `'b` is not bound when printing the type variable `'b` from +the constructor definition from the type parameter. + +Contrarily, for non-gadt constructor, we must keep the same scope for +the type parameters and the constructor because a type constraint may +have changed the name of the type parameter: +{[ +type -'a t = .. constraint 'a> = 'a +(* the universal 'a is here to steal the name 'a from the type parameter *) +type 'a t = X of 'a +]} *) +let add_extension_constructor_to_preparation ext = + let ty_params = filter_params ext.ext_type_params in + List.iter Aliases.add ty_params; + List.iter prepare_type ty_params; + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type + +let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = + let ret = Option.map (tree_of_typexp Type) ext_ret_type in + let args = tree_of_constructor_arguments ext_args in + (args, ret) + +let prepared_tree_of_extension_constructor + id ext es + = + let ty_name = Path.name ext.ext_type_path in + let ty_params = filter_params ext.ext_type_params in + let type_param = + function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let param_scope f = + match ext.ext_ret_type with + | None -> + (* normal constructor: same scope for parameters and the constructor *) + f () + | Some _ -> + (* gadt constructor: isolated scope for the type parameters *) + Variable_names.with_local_names f + in + let ty_params = + param_scope + (fun () -> + List.iter (Aliases.add_printed ~non_gen:false) ty_params; + List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params + ) + in + let name = Ident.name id in + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type + in + let ext = + { oext_name = name; + oext_type_name = ty_name; + oext_type_params = ty_params; + oext_args = args; + oext_ret_type = ret; + oext_private = ext.ext_private } + in + let es = + match es with + Text_first -> Oext_first + | Text_next -> Oext_next + | Text_exception -> Oext_exception + in + Osig_typext (ext, es) + +let tree_of_extension_constructor id ext es = + reset_except_conflicts (); + add_extension_constructor_to_preparation ext; + prepared_tree_of_extension_constructor id ext es + +let prepared_extension_constructor id ppf ext = + !Oprint.out_sig_item ppf + (prepared_tree_of_extension_constructor id ext Text_first) + +(* Print a value declaration *) + +let tree_of_value_description id decl = + (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) + let id = Ident.name id in + let () = prepare_for_printing [decl.val_type] in + let ty = tree_of_typexp Type_scheme decl.val_type in + let vd = + { oval_name = id; + oval_type = ty; + oval_prims = []; + oval_attributes = [] } + in + let vd = + match decl.val_kind with + | Val_prim p -> Primitive.print p vd + | _ -> vd + in + Osig_value vd + +(* Print a class type *) + +let method_type priv ty = + match priv, get_desc ty with + | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) + | _ , _ -> (ty, []) + +let prepare_method _lab (priv, _virt, ty) = + let ty, _ = method_type priv ty in + prepare_type ty + +let tree_of_method mode (lab, priv, virt, ty) = + let (ty, tyl) = method_type priv ty in + let tty = tree_of_typexp mode ty in + Variable_names.remove_names (List.map Transient_expr.repr tyl); + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, tty) + +let rec prepare_class_type params = function + | Cty_constr (_p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !Aliases.visited_objects + || not (List.for_all is_Tvar params) + || List.exists (deep_occur row) tyl + then prepare_class_type params cty + else List.iter prepare_type tyl + | Cty_signature sign -> + (* Self may have a name *) + let px = proxy sign.csig_self_row in + if List.memq px !Aliases.visited_objects then Aliases.add_proxy px + else Aliases.(visited_objects := px :: !visited_objects); + Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; + Meths.iter prepare_method sign.csig_meths + | Cty_arrow (_, ty, cty) -> + prepare_type ty; + prepare_class_type params cty + +let rec tree_of_class_type mode params = + function + | Cty_constr (p', tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !Aliases.visited_objects + || not (List.for_all is_Tvar params) + then + tree_of_class_type mode params cty + else + let namespace = Namespace.best_class_namespace p' in + Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) + | Cty_signature sign -> + let px = proxy sign.csig_self_row in + let self_ty = + if Aliases.is_aliased_proxy px then + Some + (Otyp_var (false, Variable_names.(name_of_type new_name) px)) + else None + in + let csil = [] in + let csil = + List.fold_left + (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) + csil (tree_of_constraints params) + in + let all_vars = + Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] + in + (* Consequence of PR#3607: order of Map.fold has changed! *) + let all_vars = List.rev all_vars in + let csil = + List.fold_left + (fun csil (l, m, v, t) -> + Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) + :: csil) + csil all_vars + in + let all_meths = + Meths.fold + (fun l (p, v, t) all -> (l, p, v, t) :: all) + sign.csig_meths [] + in + let all_meths = List.rev all_meths in + let csil = + List.fold_left + (fun csil meth -> tree_of_method mode meth :: csil) + csil all_meths + in + Octy_signature (self_ty, List.rev csil) + | Cty_arrow (l, ty, cty) -> + let lab = + if !print_labels || is_optional l then l else Nolabel + in + let tr = + if is_optional l then + match get_desc ty with + | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty in + Octy_arrow (lab, tr, tree_of_class_type mode params cty) + + +let tree_of_class_param param variance = + let ot_variance = + if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in + match tree_of_typexp Type_scheme param with + Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} + +let class_variance = + let open Variance in let open Asttypes in + List.map (fun v -> + (if not (mem May_pos v) then Contravariant else + if not (mem May_neg v) then Covariant else NoVariance), + NoInjectivity) + +let tree_of_class_declaration id cl rs = + let params = filter_params cl.cty_params in + + reset_except_conflicts (); + List.iter Aliases.add params; + prepare_class_type params cl.cty_type; + let px = proxy (Btype.self_type_row cl.cty_type) in + List.iter prepare_type params; + + List.iter (Aliases.add_printed ~non_gen:false) params; + if Aliases.is_aliased_proxy px then + Aliases.add_printed_proxy ~non_gen:false px; + + let vir_flag = cl.cty_new = None in + Osig_class + (vir_flag, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.cty_variance), + tree_of_class_type Type_scheme params cl.cty_type, + tree_of_rec rs) + +let tree_of_cltype_declaration id cl rs = + let params = cl.clty_params in + + reset_except_conflicts (); + List.iter Aliases.add params; + prepare_class_type params cl.clty_type; + let px = proxy (Btype.self_type_row cl.clty_type) in + List.iter prepare_type params; + + List.iter (Aliases.add_printed ~non_gen:false) params; + Aliases.mark_as_printed px; + + let sign = Btype.signature_of_class_type cl.clty_type in + let has_virtual_vars = + Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_vars false + in + let has_virtual_meths = + Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_meths false + in + Osig_class_type + (has_virtual_vars || has_virtual_meths, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.clty_variance), + tree_of_class_type Type_scheme params cl.clty_type, + tree_of_rec rs) + +(* Print a module type *) + +let wrap_env fenv ftree arg = + (* We save the current value of the short-path cache *) + (* From keys *) + let env = !printing_env in + let old_pers = !printing_pers in + (* to data *) + let old_map = !printing_map in + let old_depth = !printing_depth in + let old_cont = !printing_cont in + set_printing_env (fenv env); + let tree = ftree arg in + if !Clflags.real_paths + || same_printing_env env then () + (* our cached key is still live in the cache, and we want to keep all + progress made on the computation of the [printing_map] *) + else begin + (* we restore the snapshotted cache before calling set_printing_env *) + printing_old := env; + printing_pers := old_pers; + printing_depth := old_depth; + printing_cont := old_cont; + printing_map := old_map + end; + set_printing_env env; + tree + +let dummy = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = None; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = Location.none; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + } + +(** we hide items being defined from short-path to avoid shortening + [type t = Path.To.t] into [type t = t]. +*) + +let ident_sigitem = function + | Types.Sig_type(ident,_,_,_) -> {hide=true;ident} + | Types.Sig_class(ident,_,_,_) + | Types.Sig_class_type (ident,_,_,_) + | Types.Sig_module(ident,_, _,_,_) + | Types.Sig_value (ident,_,_) + | Types.Sig_modtype (ident,_,_) + | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } + +let hide ids env = + let hide_id id env = + (* Global idents cannot be renamed *) + if id.hide && not (Ident.global id.ident) then + Env.add_type ~check:false (Ident.rename id.ident) dummy env + else env + in + List.fold_right hide_id ids env + +let with_hidden_items ids f = + let with_hidden_in_printing_env ids f = + wrap_env (hide ids) (Ident_names.with_hidden ids) f + in + if not !Clflags.real_paths then + with_hidden_in_printing_env ids f + else + Ident_names.with_hidden ids f + + +let add_sigitem env x = + Env.add_signature (Signature_group.flatten x) env + +let rec tree_of_modtype ?(ellipsis=false) = function + | Mty_ident p -> + Omty_ident (tree_of_path (Some Module_type) p) + | Mty_signature sg -> + Omty_signature (if ellipsis then [Osig_ellipsis] + else tree_of_signature sg) + | Mty_functor(param, ty_res) -> + let param, env = + tree_of_functor_parameter param + in + let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in + Omty_functor (param, res) + | Mty_alias p -> + Omty_alias (tree_of_path (Some Module) p) + +and tree_of_functor_parameter = function + | Unit -> + None, fun k -> k + | Named (param, ty_arg) -> + let name, env = + match param with + | None -> None, fun env -> env + | Some id -> + Some (Ident.name id), + Env.add_module ~arg:true id Mp_present ty_arg + in + Some (name, tree_of_modtype ~ellipsis:false ty_arg), env + +and tree_of_signature sg = + wrap_env (fun env -> env)(fun sg -> + let tree_groups = tree_of_signature_rec !printing_env sg in + List.concat_map (fun (_env,l) -> List.map snd l) tree_groups + ) sg + +and tree_of_signature_rec env' sg = + let structured = List.of_seq (Signature_group.seq sg) in + let collect_trees_of_rec_group group = + let env = !printing_env in + let env', group_trees = + trees_of_recursive_sigitem_group env group + in + set_printing_env env'; + (env, group_trees) in + set_printing_env env'; + List.map collect_trees_of_rec_group structured + +and trees_of_recursive_sigitem_group env + (syntactic_group: Signature_group.rec_group) = + let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in + let env = Env.add_signature syntactic_group.pre_ghosts env in + match syntactic_group.group with + | Not_rec x -> add_sigitem env x, [display x] + | Rec_group items -> + let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in + List.fold_left add_sigitem env items, + with_hidden_items ids (fun () -> List.map display items) + +and tree_of_sigitem = function + | Sig_value(id, decl, _) -> + tree_of_value_description id decl + | Sig_type(id, decl, rs, _) -> + tree_of_type_declaration id decl rs + | Sig_typext(id, ext, es, _) -> + tree_of_extension_constructor id ext es + | Sig_module(id, _, md, rs, _) -> + let ellipsis = + List.exists (function + | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true + | _ -> false) + md.md_attributes in + tree_of_module id md.md_type rs ~ellipsis + | Sig_modtype(id, decl, _) -> + tree_of_modtype_declaration id decl + | Sig_class(id, decl, rs, _) -> + tree_of_class_declaration id decl rs + | Sig_class_type(id, decl, rs, _) -> + tree_of_cltype_declaration id decl rs + +and tree_of_modtype_declaration id decl = + let mty = + match decl.mtd_type with + | None -> Omty_abstract + | Some mty -> tree_of_modtype mty + in + Osig_modtype (Ident.name id, mty) + +and tree_of_module id ?ellipsis mty rs = + Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) + +(* For the toplevel: merge with tree_of_signature? *) +let print_items showval env x = + Variable_names.refresh_weak(); + Ident_conflicts.reset (); + let extend_val env (sigitem,outcome) = outcome, showval env sigitem in + let post_process (env,l) = List.map (extend_val env) l in + List.concat_map post_process @@ tree_of_signature_rec env x + +let same_path t t' = + let open Types in + eq_type t t' || + match get_desc t, get_desc t' with + Tconstr(p,tl,_), Tconstr(p',tl',_) -> + let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in + begin match s1, s2 with + Nth n1, Nth n2 when n1 = n2 -> true + | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> + let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in + List.length tl = List.length tl' && + List.for_all2 eq_type tl tl' + | _ -> false + end + | _ -> + false + +type 'a diff = Same of 'a | Diff of 'a * 'a + +let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = + Aliases.reset (); + Aliases.mark_loops t; + if same_path t t' + then begin Aliases.add_delayed (proxy t); Same (tree_of_typexp mode t) end + else begin + Aliases.mark_loops t'; + let t' = if proxy t == proxy t' then unalias t' else t' in + (* beware order matter due to side effect, + e.g. when printing object types *) + let first = tree_of_typexp mode t in + let second = tree_of_typexp mode t' in + if first = second then Same first + else Diff(first,second) + end + +let pp_type ppf t = + Style.as_inline_code !Oprint.out_type ppf t + +let pp_type_expansion ppf = function + | Same t -> pp_type ppf t + | Diff(t,t') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + pp_type t + pp_type t' + +(* Hide variant name and var, to force printing the expanded type *) +let hide_variant_name t = + let open Types in + match get_desc t with + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + if name = None then t else + Btype.newty2 ~level:(get_level t) + (Tvariant + (create_row ~fields ~fixed ~closed ~name:None + ~more:(Ctype.newvar2 (get_level more)))) + | _ -> t + +let prepare_expansion Errortrace.{ty; expanded} = + let expanded = hide_variant_name expanded in + Variable_names.reserve ty; + if not (same_path ty expanded) then Variable_names.reserve expanded; + Errortrace.{ty; expanded} + + +(* Adapt functions to exposed interface *) +let namespaced_tree_of_path n = tree_of_path (Some n) +let tree_of_path ?disambiguation p = tree_of_path ?disambiguation None p +let tree_of_modtype = tree_of_modtype ~ellipsis:false +let tree_of_type_declaration ident td rs = + with_hidden_items [{hide=true; ident}] + (fun () -> tree_of_type_declaration ident td rs) + +let tree_of_class_type kind cty = tree_of_class_type kind [] cty +let prepare_class_type cty = prepare_class_type [] cty + +let tree_of_type_path p = + let (p', s) = best_type_path p in + let p'' = if (s = Id) then p' else p in + tree_of_best_type_path p p'' diff --git a/upstream/ocaml_503/typing/out_type.mli b/upstream/ocaml_503/typing/out_type.mli new file mode 100644 index 000000000..b134fa119 --- /dev/null +++ b/upstream/ocaml_503/typing/out_type.mli @@ -0,0 +1,259 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Functions for representing type expressions and module types as outcometree + (with [as 'a] aliases for cycles) and printing them. All functions below + depends on global contexts that keep track of + +- If labels are disabled +- Current printing environment +- Shortest equivalent paths + +- Conflicts for identifier names +- Names chosen for type variables +- Aliases used for representing cycles or row variables +- Uses of internal names + +Whenever possible, it is advised to use the simpler functions available in +{!Printtyp} which take care of setting up this naming context. The functions +below are needed when one needs to share a common naming context (or part of it) +between different calls to printing functions (or in order to implement +{!Printtyp}). +*) + +open Format_doc +open Types +open Outcometree + +(** {1 Wrapping functions}*) + +val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a +(** Call the function using the environment for type path shortening + This affects all the printing and tree cration functions functions below + Also, if [~error:true], then disable the loading of cmis *) + + +(** [with_labels false] disable labels in function types *) +val with_labels: bool -> (unit -> 'a) -> 'a + +(** {1 Printing idents and paths } *) + +val ident_name: Shape.Sig_component_kind.t option -> Ident.t -> out_name +val tree_of_path: ?disambiguation:bool -> Path.t -> out_ident +val namespaced_tree_of_path: Shape.Sig_component_kind.t -> Path.t -> out_ident +val tree_of_type_path: Path.t -> out_ident +(** Specialized functions for printing types with [short-paths] *) + +(** [same_path ty ty2] is true when there is an equation [ty]=[ty2] in the + short-path scope*) +val same_path: type_expr -> type_expr -> bool + +(** Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias + for Foo__bar. This pattern is used by the stdlib. *) +val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t + +(** {1 Printing type expressions} *) + +(** Printing type expressions requires to translate the internal graph based + representation into to an {!Outcometree} closer to the source syntax. In + order to do so, the printing is generally split in three phase: + - A preparation phase which in particular + - marks cycles + - chooses user-facing names for type variables + - An outcometree generation phase, where we emit an outcometree as a + ready-for-printing representation of trees (represented by the various + [tree_of_*] functions) + - Printing proper +*) + +(** [prepare_for_printing] resets the global naming environment, a la + {!reset_except_conflicts}, and prepares the types for printing by reserving + variable names and marking cycles. Any type variables that are shared + between multiple types in the input list will be given the same name when + printed with {!prepared_type_expr}. *) +val prepare_for_printing: type_expr list -> unit + +(** [add_type_to_preparation ty] extend a previous type expression preparation + to the type expression [ty] +*) +val add_type_to_preparation: type_expr -> unit + +(** In [Type_scheme] mode, non-generic types variables are printed as weakly + polymorphic type variables. *) +type type_or_scheme = Type | Type_scheme +val tree_of_typexp: type_or_scheme -> type_expr -> out_type +(** [tree_of_typexp] generate the [outcometree] for a prepared type + expression.*) + +val prepared_type_scheme: type_expr printer +val prepared_type_expr: type_expr printer +(** The printers [prepared_type_expr] and [prepared_type_scheme] should only be + used on prepared types. Types can be prepared by initially calling + {!prepare_for_printing} or adding them later to the preparation with + {!add_type_to_preparation}. + + Calling this function on non-prepared types may cause a stack overflow (see + #8860) due to cycles in the printed types. + + See {!Printtyp.type_expr} for a safer but less flexible printer. *) + +(** [type_expr_with_reserved_names] can print "half-prepared" type expression. A + "half-prepared" type expression should have had its names reserved (with + {!Variable_names.reserve}), but should not have had its cycles marked. *) +val type_expr_with_reserved_names: type_expr printer + +type 'a diff = Same of 'a | Diff of 'a * 'a +val trees_of_type_expansion: + type_or_scheme -> Errortrace.expanded_type -> out_type diff +val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type +val pp_type_expansion: out_type diff printer +val hide_variant_name: Types.type_expr -> Types.type_expr + + +(** {1: Label and constructors }*) +val prepare_type_constructor_arguments: constructor_arguments -> unit +val tree_of_constructor_arguments: constructor_arguments -> out_type list + +val tree_of_label: label_declaration -> out_label + +val add_constructor_to_preparation : constructor_declaration -> unit +val prepared_constructor : constructor_declaration printer + +val tree_of_extension_constructor: + Ident.t -> extension_constructor -> ext_status -> out_sig_item +val extension_constructor_args_and_ret_type_subtree: + constructor_arguments -> type_expr option -> out_type list * out_type option +val add_extension_constructor_to_preparation : + extension_constructor -> unit +val prepared_extension_constructor: + Ident.t -> extension_constructor printer + + +(** {1 Declarations }*) + +val tree_of_type_declaration: + Ident.t -> type_declaration -> rec_status -> out_sig_item +val add_type_declaration_to_preparation : + Ident.t -> type_declaration -> unit +val prepared_type_declaration: Ident.t -> type_declaration printer + +val tree_of_value_description: Ident.t -> value_description -> out_sig_item +val tree_of_modtype_declaration: + Ident.t -> modtype_declaration -> out_sig_item +val tree_of_class_declaration: + Ident.t -> class_declaration -> rec_status -> out_sig_item +val tree_of_cltype_declaration: + Ident.t -> class_type_declaration -> rec_status -> out_sig_item + +(** {1 Module types }*) + +val tree_of_module: + Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item +val tree_of_modtype: module_type -> out_module_type +val tree_of_signature: Types.signature -> out_sig_item list + +val tree_of_class_type: type_or_scheme -> class_type -> out_class_type +val prepare_class_type: class_type -> unit + +(** {1 Toplevel printing} *) +val print_items: (Env.t -> signature_item -> 'a option) -> + Env.t -> signature_item list -> (out_sig_item * 'a option) list + +(** {1 Naming contexts }*) + +(** Path name, which were mutable at some point *) +module Out_name: sig + val create: string -> out_name + val print: out_name -> string +end + +(** Disambiguation for identifiers, e.g. the two type constructors named [t] +in the type of [f] in +{[ + type t = A + module M = struct + type t = B + let f A = B + end +]} +should be disambiguated to [t/2->t] *) +module Ident_names: sig + val enable: bool -> unit + (** When contextual names are enabled, the mapping between identifiers + and names is ensured to be one-to-one. *) + + (** [with_fuzzy id f] locally disable ident disambiguation for [id] within + [f] *) + val with_fuzzy: Ident.t -> (unit -> 'a) -> 'a +end + +(** The [Ident_conflicts] module keeps track of conflicts arising when + attributing names to identifiers and provides functions that can print + explanations for these conflict in error messages *) +module Ident_conflicts: sig + val exists: unit -> bool + (** [exists()] returns true if the current naming context renamed + an identifier to avoid a name collision *) + + type explanation = + { kind: Shape.Sig_component_kind.t; + name:string; + root_name:string; + location:Location.t + } + + val list_explanations: unit -> explanation list +(** [list_explanations()] return the list of conflict explanations + collected up to this point, and reset the list of collected + explanations *) + + val print_located_explanations: explanation list printer + + val err_print: formatter -> unit + val err_msg: unit -> doc option + (** [err_msg ()] return an error message if there are pending conflict + explanations at this point. It is often important to check for conflicts + after all printing is done, thus the delayed nature of [err_msg]*) + + val reset: unit -> unit +end + +(** Naming choice for type variable names (['a], ['b], ...), for instance the + two classes of distinct type variables in + {[let repeat x y = x, y, y, x]} + should be printed printed as ['a -> 'b -> 'a * 'b * 'b * 'a]. +*) +module Variable_names: sig + + (** Add external type equalities*) + val add_subst: (type_expr * type_expr) list -> unit + + (** [reserve ty] registers the variable names appearing in [ty] *) + val reserve: type_expr -> unit +end + +(** Register internal typechecker names ([$0],[$a]) appearing in the + [outcometree] *) +module Internal_names: sig + val add: Path.t -> unit + val reset: unit -> unit + val print_explanations: Env.t -> formatter -> unit +end + +(** Reset all contexts *) +val reset: unit -> unit + +(** Reset all contexts except for conflicts *) +val reset_except_conflicts: unit -> unit diff --git a/upstream/ocaml_503/typing/outcometree.mli b/upstream/ocaml_503/typing/outcometree.mli new file mode 100644 index 000000000..f4b89630b --- /dev/null +++ b/upstream/ocaml_503/typing/outcometree.mli @@ -0,0 +1,166 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Module [Outcometree]: results displayed by the toplevel *) + +(* These types represent messages that the toplevel displays as normal + results or errors. The real displaying is customisable using the hooks: + [Toploop.print_out_value] + [Toploop.print_out_type] + [Toploop.print_out_sig_item] + [Toploop.print_out_phrase] *) + +(** An [out_name] is a string representation of an identifier which can be + rewritten on the fly to avoid name collisions *) +type out_name = { mutable printed_name: string } + +type out_ident = + | Oide_apply of out_ident * out_ident + | Oide_dot of out_ident * string + | Oide_ident of out_name + +type out_string = + | Ostr_string + | Ostr_bytes + +type out_attribute = + { oattr_name: string } + +type out_value = + | Oval_array of out_value list + | Oval_char of char + | Oval_constr of out_ident * out_value list + | Oval_ellipsis + | Oval_float of float + | Oval_int of int + | Oval_int32 of int32 + | Oval_int64 of int64 + | Oval_nativeint of nativeint + | Oval_list of out_value list + | Oval_printer of (Format_doc.formatter -> unit) + | Oval_record of (out_ident * out_value) list + | Oval_string of string * int * out_string (* string, size-to-print, kind *) + | Oval_stuff of string + | Oval_tuple of out_value list + | Oval_variant of string * out_value option + | Oval_lazy of out_value + +type out_type_param = { + ot_non_gen: bool; + ot_name: string; + ot_variance: Asttypes.variance * Asttypes.injectivity +} + +type out_type = + | Otyp_abstract + | Otyp_open + | Otyp_alias of {non_gen:bool; aliased:out_type; alias:string} + | Otyp_arrow of Asttypes.arg_label * out_type * out_type + | Otyp_class of out_ident * out_type list + | Otyp_constr of out_ident * out_type list + | Otyp_manifest of out_type * out_type + | Otyp_object of { fields: (string * out_type) list; open_row:bool} + | Otyp_record of out_label list + | Otyp_stuff of string + | Otyp_sum of out_constructor list + | Otyp_tuple of out_type list + | Otyp_var of bool * string + | Otyp_variant of out_variant * bool * (string list) option + | Otyp_poly of string list * out_type + | Otyp_module of out_ident * (string * out_type) list + | Otyp_attribute of out_type * out_attribute + +and out_label = { + olab_name: string; + olab_mut: Asttypes.mutable_flag; + olab_type: out_type; +} + +and out_constructor = { + ocstr_name: string; + ocstr_args: out_type list; + ocstr_return_type: out_type option; +} + +and out_variant = + | Ovar_fields of (string * bool * out_type list) list + | Ovar_typ of out_type + +type out_class_type = + | Octy_constr of out_ident * out_type list + | Octy_arrow of Asttypes.arg_label * out_type * out_class_type + | Octy_signature of out_type option * out_class_sig_item list +and out_class_sig_item = + | Ocsg_constraint of out_type * out_type + | Ocsg_method of string * bool * bool * out_type + | Ocsg_value of string * bool * bool * out_type + +type out_module_type = + | Omty_abstract + | Omty_functor of (string option * out_module_type) option * out_module_type + | Omty_ident of out_ident + | Omty_signature of out_sig_item list + | Omty_alias of out_ident +and out_sig_item = + | Osig_class of + bool * string * out_type_param list * out_class_type * + out_rec_status + | Osig_class_type of + bool * string * out_type_param list * out_class_type * + out_rec_status + | Osig_typext of out_extension_constructor * out_ext_status + | Osig_modtype of string * out_module_type + | Osig_module of string * out_module_type * out_rec_status + | Osig_type of out_type_decl * out_rec_status + | Osig_value of out_val_decl + | Osig_ellipsis +and out_type_decl = + { otype_name: string; + otype_params: out_type_param list; + otype_type: out_type; + otype_private: Asttypes.private_flag; + otype_immediate: Type_immediacy.t; + otype_unboxed: bool; + otype_cstrs: (out_type * out_type) list } +and out_extension_constructor = + { oext_name: string; + oext_type_name: string; + oext_type_params: string list; + oext_args: out_type list; + oext_ret_type: out_type option; + oext_private: Asttypes.private_flag } +and out_type_extension = + { otyext_name: string; + otyext_params: string list; + otyext_constructors: out_constructor list; + otyext_private: Asttypes.private_flag } +and out_val_decl = + { oval_name: string; + oval_type: out_type; + oval_prims: string list; + oval_attributes: out_attribute list } +and out_rec_status = + | Orec_not + | Orec_first + | Orec_next +and out_ext_status = + | Oext_first + | Oext_next + | Oext_exception + +type out_phrase = + | Ophr_eval of out_value * out_type + | Ophr_signature of (out_sig_item * out_value option) list + | Ophr_exception of (exn * out_value) diff --git a/upstream/ocaml_503/typing/parmatch.ml b/upstream/ocaml_503/typing/parmatch.ml new file mode 100644 index 000000000..c1cc84e3a --- /dev/null +++ b/upstream/ocaml_503/typing/parmatch.ml @@ -0,0 +1,2363 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Detection of partial matches and unused match cases. *) + +open Misc +open Asttypes +open Types +open Typedtree + +type 'pattern parmatch_case = + { pattern : 'pattern; + has_guard : bool; + needs_refute : bool; + } + +let typed_case { c_lhs; c_guard; c_rhs } = + { pattern = c_lhs; + has_guard = Option.is_some c_guard; + needs_refute = (c_rhs.exp_desc = Texp_unreachable); + } + +let untyped_case { Parsetree.pc_lhs; pc_guard; pc_rhs } = + { pattern = pc_lhs; + has_guard = Option.is_some pc_guard; + needs_refute = (pc_rhs.pexp_desc = Parsetree.Pexp_unreachable); + } + +(*************************************) +(* Utilities for building patterns *) +(*************************************) + +let make_pat desc ty tenv = + {pat_desc = desc; pat_loc = Location.none; pat_extra = []; + pat_type = ty ; pat_env = tenv; + pat_attributes = []; + } + +let omega = Patterns.omega +let omegas = Patterns.omegas +let omega_list = Patterns.omega_list + +let extra_pat = + make_pat + (Tpat_var (Ident.create_local "+", mknoloc "+", + Uid.internal_not_actually_unique)) + Ctype.none Env.empty + + +(*******************) +(* Coherence check *) +(*******************) + +(* For some of the operations we do in this module, we would like (because it + simplifies matters) to assume that patterns appearing on a given column in a + pattern matrix are /coherent/ (think "of the same type"). + Unfortunately that is not always true. + + Consider the following (well-typed) example: + {[ + type _ t = S : string t | U : unit t + + let f (type a) (t1 : a t) (t2 : a t) (a : a) = + match t1, t2, a with + | U, _, () -> () + | _, S, "" -> () + ]} + + Clearly the 3rd column contains incoherent patterns. + + On the example above, most of the algorithms will explore the pattern matrix + as illustrated by the following tree: + + {v + S + -------> | "" | + U | S, "" | __/ | () | + --------> | _, () | \ not S + | U, _, () | __/ -------> | () | + | _, S, "" | \ + ---------> | S, "" | ----------> | "" | + not U S + v} + + where following an edge labelled by a pattern P means "assuming the value I + am matching on is filtered by [P] on the column I am currently looking at, + then the following submatrix is still reachable". + + Notice that at any point of that tree, if the first column of a matrix is + incoherent, then the branch leading to it can only be taken if the scrutinee + is ill-typed. + In the example above the only case where we have a matrix with an incoherent + first column is when we consider [t1, t2, a] to be [U, S, ...]. However such + a value would be ill-typed, so we can never actually get there. + + Checking the first column at each step of the recursion and making the + conscious decision of "aborting" the algorithm whenever the first column + becomes incoherent, allows us to retain the initial assumption in later + stages of the algorithms. + + --- + + N.B. two patterns can be considered coherent even though they might not be of + the same type. + + That's in part because we only care about the "head" of patterns and leave + checking coherence of subpatterns for the next steps of the algorithm: + ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples + of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1). + + But also because it can be hard/costly to determine exactly whether two + patterns are of the same type or not (eg. in the example above with _ and S, + but see also the module [Coherence_illustration] in + testsuite/tests/basic-more/robustmatch.ml). + + For the moment our weak, loosely-syntactic, coherence check seems to be + enough and we leave it to each user to consider (and document!) what happens + when an "incoherence" is not detected by this check. +*) + +(* Given the first column of a simplified matrix, this function first looks for + a "discriminating" pattern on that column (i.e. a non-omega one) and then + check that every other head pattern in the column is coherent with that one. +*) +let all_coherent column = + let open Patterns.Head in + let coherent_heads hp1 hp2 = + match hp1.pat_desc, hp2.pat_desc with + | Construct c, Construct c' -> + c.cstr_consts = c'.cstr_consts + && c.cstr_nonconsts = c'.cstr_nonconsts + | Constant c1, Constant c2 -> begin + match c1, c2 with + | Const_char _, Const_char _ + | Const_int _, Const_int _ + | Const_int32 _, Const_int32 _ + | Const_int64 _, Const_int64 _ + | Const_nativeint _, Const_nativeint _ + | Const_float _, Const_float _ + | Const_string _, Const_string _ -> true + | ( Const_char _ + | Const_int _ + | Const_int32 _ + | Const_int64 _ + | Const_nativeint _ + | Const_float _ + | Const_string _), _ -> false + end + | Tuple l1, Tuple l2 -> l1 = l2 + | Record (lbl1 :: _), Record (lbl2 :: _) -> + Array.length lbl1.lbl_all = Array.length lbl2.lbl_all + | Any, _ + | _, Any + | Record [], Record [] + | Variant _, Variant _ + | Array _, Array _ + | Lazy, Lazy -> true + | _, _ -> false + in + match + List.find + (function + | { pat_desc = Any } -> false + | _ -> true) + column + with + | exception Not_found -> + (* only omegas on the column: the column is coherent. *) + true + | discr_pat -> + List.for_all (coherent_heads discr_pat) column + +let first_column simplified_matrix = + List.map (fun ((head, _args), _rest) -> head) simplified_matrix + +(***********************) +(* Compatibility check *) +(***********************) + +(* Patterns p and q compatible means: + there exists value V that matches both, However.... + + The case of extension types is dubious, as constructor rebind permits + that different constructors are the same (and are thus compatible). + + Compilation must take this into account, consider: + + type t = .. + type t += A|B + type t += C=A + + let f x y = match x,y with + | true,A -> '1' + | _,C -> '2' + | false,A -> '3' + | _,_ -> '_' + + As C is bound to A the value of f false A is '2' (and not '3' as it would + be in the absence of rebinding). + + Not considering rebinding, patterns "false,A" and "_,C" are incompatible + and the compiler can swap the second and third clause, resulting in the + (more efficiently compiled) matching + + match x,y with + | true,A -> '1' + | false,A -> '3' + | _,C -> '2' + | _,_ -> '_' + + This is not correct: when C is bound to A, "f false A" returns '2' (not '3') + + + However, diagnostics do not take constructor rebinding into account. + Notice, that due to module abstraction constructor rebinding is hidden. + + module X : sig type t = .. type t += A|B end = struct + type t = .. + type t += A + type t += B=A + end + + open X + + let f x = match x with + | A -> '1' + | B -> '2' + | _ -> '_' + + The second clause above will NOT (and cannot) be flagged as useless. + + Finally, there are two compatibility functions: + compat p q ---> 'syntactic compatibility, used for diagnostics. + may_compat p q ---> a safe approximation of possible compat, + for compilation + +*) + + +let is_absent tag row = row_field_repr (get_row_field tag !row) = Rabsent + +let is_absent_pat d = + match d.pat_desc with + | Patterns.Head.Variant { tag; cstr_row; _ } -> is_absent tag cstr_row + | _ -> false + +let const_compare x y = + match x,y with + | Const_float f1, Const_float f2 -> + Stdlib.compare (float_of_string f1) (float_of_string f2) + | Const_string (s1, _, _), Const_string (s2, _, _) -> + String.compare s1 s2 + | (Const_int _ + |Const_char _ + |Const_string (_, _, _) + |Const_float _ + |Const_int32 _ + |Const_int64 _ + |Const_nativeint _ + ), _ -> Stdlib.compare x y + +let records_args l1 l2 = + (* Invariant: fields are already sorted by Typecore.type_label_a_list *) + let rec combine r1 r2 l1 l2 = match l1,l2 with + | [],[] -> List.rev r1, List.rev r2 + | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 + | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] + | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then + combine (p1::r1) (omega::r2) rem1 l2 + else if lbl1.lbl_pos > lbl2.lbl_pos then + combine (omega::r1) (p2::r2) l1 rem2 + else (* same label on both sides *) + combine (p1::r1) (p2::r2) rem1 rem2 in + combine [] [] l1 l2 + + + +module Compat + (Constr:sig + val equal : + Types.constructor_description -> + Types.constructor_description -> + bool + end) = struct + + let rec compat p q = match p.pat_desc,q.pat_desc with +(* Variables match any value *) + | ((Tpat_any|Tpat_var _),_) + | (_,(Tpat_any|Tpat_var _)) -> true +(* Structural induction *) + | Tpat_alias (p,_,_,_),_ -> compat p q + | _,Tpat_alias (q,_,_,_) -> compat p q + | Tpat_or (p1,p2,_),_ -> + (compat p1 q || compat p2 q) + | _,Tpat_or (q1,q2,_) -> + (compat p q1 || compat p q2) +(* Constructors, with special case for extension *) + | Tpat_construct (_, c1, ps1, _), Tpat_construct (_, c2, ps2, _) -> + Constr.equal c1 c2 && compats ps1 ps2 +(* More standard stuff *) + | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) -> + l1=l2 && ocompat op1 op2 + | Tpat_constant c1, Tpat_constant c2 -> + const_compare c1 c2 = 0 + | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs + | Tpat_lazy p, Tpat_lazy q -> compat p q + | Tpat_record (l1,_),Tpat_record (l2,_) -> + let ps,qs = records_args l1 l2 in + compats ps qs + | Tpat_array ps, Tpat_array qs -> + List.length ps = List.length qs && + compats ps qs + | _,_ -> false + + and ocompat op oq = match op,oq with + | None,None -> true + | Some p,Some q -> compat p q + | (None,Some _)|(Some _,None) -> false + + and compats ps qs = match ps,qs with + | [], [] -> true + | p::ps, q::qs -> compat p q && compats ps qs + | _,_ -> false + +end + +module SyntacticCompat = + Compat + (struct + let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag + end) + +let compat = SyntacticCompat.compat +and compats = SyntacticCompat.compats + +(* Due to (potential) rebinding, two extension constructors + of the same arity type may equal *) + +exception Empty (* Empty pattern *) + +(****************************************) +(* Utilities for retrieving type paths *) +(****************************************) + +(* May need a clean copy, cf. PR#4745 *) +let clean_copy ty = + if get_level ty = Btype.generic_level then ty + else Subst.type_expr Subst.identity ty + +let get_constructor_type_path ty tenv = + let ty = Ctype.expand_head tenv (clean_copy ty) in + match get_desc ty with + | Tconstr (path,_,_) -> path + | _ -> assert false + +(****************************) +(* Utilities for matching *) +(****************************) + +(* Check top matching *) +let simple_match d h = + let open Patterns.Head in + match d.pat_desc, h.pat_desc with + | Construct c1, Construct c2 -> + Types.equal_tag c1.cstr_tag c2.cstr_tag + | Variant { tag = t1; _ }, Variant { tag = t2 } -> + t1 = t2 + | Constant c1, Constant c2 -> const_compare c1 c2 = 0 + | Lazy, Lazy -> true + | Record _, Record _ -> true + | Tuple len1, Tuple len2 + | Array len1, Array len2 -> len1 = len2 + | _, Any -> true + | _, _ -> false + + + +(* extract record fields as a whole *) +let record_arg ph = + let open Patterns.Head in + match ph.pat_desc with + | Any -> [] + | Record args -> args + | _ -> fatal_error "Parmatch.as_record" + + +let extract_fields lbls arg = + let get_field pos arg = + match List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg with + | _, p -> p + | exception Not_found -> omega + in + List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls + +(* Build argument list when p2 >= p1, where p1 is a simple pattern *) +let simple_match_args discr head args = + let open Patterns.Head in + match head.pat_desc with + | Constant _ -> [] + | Construct _ + | Variant _ + | Tuple _ + | Array _ + | Lazy -> args + | Record lbls -> extract_fields (record_arg discr) (List.combine lbls args) + | Any -> + begin match discr.pat_desc with + | Construct cstr -> Patterns.omegas cstr.cstr_arity + | Variant { has_arg = true } + | Lazy -> [Patterns.omega] + | Record lbls -> omega_list lbls + | Array len + | Tuple len -> Patterns.omegas len + | Variant { has_arg = false } + | Any + | Constant _ -> [] + end + +(* Consider a pattern matrix whose first column has been simplified to contain + only _ or a head constructor + | p1, r1... + | p2, r2... + | p3, r3... + | ... + + We build a normalized /discriminating/ pattern from a pattern [q] by folding + over the first column of the matrix, "refining" [q] as we go: + + - when we encounter a row starting with [Tuple] or [Lazy] then we + can stop and return that head, as we cannot refine any further. Indeed, + these constructors are alone in their signature, so they will subsume + whatever other head we might find, as well as the head we're threading + along. + + - when we find a [Record] then it is a bit more involved: it is also alone + in its signature, however it might only be matching a subset of the + record fields. We use these fields to refine our accumulator and keep going + as another row might match on different fields. + + - rows starting with a wildcard do not bring any information, so we ignore + them and keep going + + - if we encounter anything else (i.e. any other constructor), then we just + stop and return our accumulator. +*) +let discr_pat q pss = + let open Patterns.Head in + let rec refine_pat acc = function + | [] -> acc + | ((head, _), _) :: rows -> + match head.pat_desc with + | Any -> refine_pat acc rows + | Tuple _ | Lazy -> head + | Record lbls -> + (* N.B. we could make this case "simpler" by refining the record case + using [all_record_args]. + In which case we wouldn't need to fold over the first column for + records. + However it makes the witness we generate for the exhaustivity warning + less pretty. *) + let fields = + List.fold_right (fun lbl r -> + if List.exists (fun l -> l.lbl_pos = lbl.lbl_pos) r then + r + else + lbl :: r + ) lbls (record_arg acc) + in + let d = { head with pat_desc = Record fields } in + refine_pat d rows + | _ -> acc + in + let q, _ = deconstruct q in + match q.pat_desc with + (* short-circuiting: clearly if we have anything other than [Record] or + [Any] to start with, we're not going to be able refine at all. So + there's no point going over the matrix. *) + | Any | Record _ -> refine_pat q pss + | _ -> q + +(* + In case a matching value is found, set actual arguments + of the matching pattern. +*) + +let rec read_args xs r = match xs,r with +| [],_ -> [],r +| _::xs, arg::rest -> + let args,rest = read_args xs rest in + arg::args,rest +| _,_ -> + fatal_error "Parmatch.read_args" + +let set_args q r = match q with +| {pat_desc = Tpat_tuple omegas} -> + let args,rest = read_args omegas r in + make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest +| {pat_desc = Tpat_record (omegas,closed)} -> + let args,rest = read_args omegas r in + let args = + List.map2 (fun (lid, lbl, _) arg -> (lid, lbl, arg)) omegas args in + make_pat (Tpat_record (args, closed)) q.pat_type q.pat_env :: rest +| {pat_desc = Tpat_construct (lid, c, omegas, _)} -> + let args,rest = read_args omegas r in + make_pat + (Tpat_construct (lid, c, args, None)) + q.pat_type q.pat_env:: + rest +| {pat_desc = Tpat_variant (l, omega, row)} -> + let arg, rest = + match omega, r with + Some _, a::r -> Some a, r + | None, r -> None, r + | _ -> assert false + in + make_pat + (Tpat_variant (l, arg, row)) q.pat_type q.pat_env:: + rest +| {pat_desc = Tpat_lazy _omega} -> + begin match r with + arg::rest -> + make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest + | _ -> fatal_error "Parmatch.do_set_args (lazy)" + end +| {pat_desc = Tpat_array omegas} -> + let args,rest = read_args omegas r in + make_pat + (Tpat_array args) q.pat_type q.pat_env:: + rest +| {pat_desc=Tpat_constant _|Tpat_any} -> + q::r (* case any is used in matching.ml *) +| {pat_desc = (Tpat_var _ | Tpat_alias _ | Tpat_or _); _} -> + fatal_error "Parmatch.set_args" + +(* Given a matrix of non-empty rows + p1 :: r1... + p2 :: r2... + p3 :: r3... + + Simplify the first column [p1 p2 p3] by splitting all or-patterns. + The result is a list of pairs + ((pattern head, arguments), rest of row) + + For example, + x :: r1 + (Some _) as y :: r2 + (None as x) as y :: r3 + (Some x | (None as x)) :: r4 + becomes + (( _ , [ ] ), r1) + (( Some, [_] ), r2) + (( None, [ ] ), r3) + (( Some, [x] ), r4) + (( None, [ ] ), r4) + *) +let simplify_head_pat ~add_column p ps k = + let rec simplify_head_pat p ps k = + match Patterns.General.(view p |> strip_vars).pat_desc with + | `Or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k) + | #Patterns.Simple.view as view -> + add_column (Patterns.Head.deconstruct { p with pat_desc = view }) ps k + in simplify_head_pat p ps k + +let rec simplify_first_col = function + | [] -> [] + | [] :: _ -> assert false (* the rows are non-empty! *) + | (p::ps) :: rows -> + let add_column p ps k = (p, ps) :: k in + simplify_head_pat ~add_column p ps (simplify_first_col rows) + + +(* Builds the specialized matrix of [pss] according to the discriminating + pattern head [d]. + See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf + + NOTES: + - we are polymorphic on the type of matrices we work on, in particular a row + might not simply be a [pattern list]. That's why we have the [extend_row] + parameter. +*) +let build_specialized_submatrix ~extend_row discr pss = + let rec filter_rec = function + | ((head, args), ps) :: pss -> + if simple_match discr head + then extend_row (simple_match_args discr head args) ps :: filter_rec pss + else filter_rec pss + | _ -> [] in + filter_rec pss + +(* The "default" and "specialized" matrices of a given matrix. + See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf . +*) +type 'matrix specialized_matrices = { + default : 'matrix; + constrs : (Patterns.Head.t * 'matrix) list; +} + +(* Consider a pattern matrix whose first column has been simplified + to contain only _ or a head constructor + | p1, r1... + | p2, r2... + | p3, r3... + | ... + + We split this matrix into a list of /specialized/ sub-matrices, one for + each head constructor appearing in the first column. For each row whose + first column starts with a head constructor, remove this head + column, prepend one column for each argument of the constructor, + and add the resulting row in the sub-matrix corresponding to this + head constructor. + + Rows whose left column is omega (the Any pattern _) may match any + head constructor, so they are added to all sub-matrices. + + In the case where all the rows in the matrix have an omega on their first + column, then there is only one /specialized/ sub-matrix, formed of all these + omega rows. + This matrix is also called the /default/ matrix. + + See the documentation of [build_specialized_submatrix] for an explanation of + the [extend_row] parameter. +*) +let build_specialized_submatrices ~extend_row discr rows = + let extend_group discr p args r rs = + let r = extend_row (simple_match_args discr p args) r in + (discr, r :: rs) + in + + (* insert a row of head [p] and rest [r] into the right group + + Note: with this implementation, the order of the groups + is the order of their first row in the source order. + This is a nice property to get exhaustivity counter-examples + in source order. + *) + let rec insert_constr head args r = function + | [] -> + (* if no group matched this row, it has a head constructor that + was never seen before; add a new sub-matrix for this head *) + [extend_group head head args r []] + | (q0,rs) as bd::env -> + if simple_match q0 head + then extend_group q0 head args r rs :: env + else bd :: insert_constr head args r env + in + + (* insert a row of head omega into all groups *) + let insert_omega r env = + List.map (fun (q0,rs) -> extend_group q0 Patterns.Head.omega [] r rs) env + in + + let rec form_groups constr_groups omega_tails = function + | [] -> (constr_groups, omega_tails) + | ((head, args), tail) :: rest -> + match head.pat_desc with + | Patterns.Head.Any -> + (* note that calling insert_omega here would be wrong + as some groups may not have been formed yet, if the + first row with this head pattern comes after in the list *) + form_groups constr_groups (tail :: omega_tails) rest + | _ -> + form_groups + (insert_constr head args tail constr_groups) omega_tails rest + in + + let constr_groups, omega_tails = + let initial_constr_group = + let open Patterns.Head in + match discr.pat_desc with + | Record _ | Tuple _ | Lazy -> + (* [discr] comes from [discr_pat], and in this case subsumes any of the + patterns we could find on the first column of [rows]. So it is better + to use it for our initial environment than any of the normalized + pattern we might obtain from the first column. *) + [discr,[]] + | _ -> [] + in + form_groups initial_constr_group [] rows + in + + (* groups are accumulated in reverse order; + we restore the order of rows in the source code *) + let default = List.rev omega_tails in + let constrs = + List.fold_right insert_omega omega_tails constr_groups + |> List.map (fun (discr, rs) -> (discr, List.rev rs)) + in + { default; constrs; } + +(* Variant related functions *) + +let set_last a = + let rec loop = function + | [] -> assert false + | [_] -> [Patterns.General.erase a] + | x::l -> x :: loop l + in + function + | (_, []) -> (Patterns.Head.deconstruct a, []) + | (first, row) -> (first, loop row) + +(* mark constructor lines for failure when they are incomplete *) +let mark_partial = + let zero = make_pat (`Constant (Const_int 0)) Ctype.none Env.empty in + List.map (fun ((hp, _), _ as ps) -> + match hp.pat_desc with + | Patterns.Head.Any -> ps + | _ -> set_last zero ps + ) + +let close_variant env row = + let Row {fields; more; name=orig_name; closed; fixed} = row_repr row in + let name, static = + List.fold_left + (fun (nm, static) (_tag,f) -> + match row_field_repr f with + | Reither(_, _, false) -> + (* fixed=false means that this tag is not explicitly matched *) + link_row_field_ext ~inside:f rf_absent; + (None, static) + | Reither (_, _, true) -> (nm, false) + | Rabsent | Rpresent _ -> (nm, static)) + (orig_name, true) fields in + if not closed || name != orig_name then begin + let more' = if static then Btype.newgenty Tnil else Btype.newgenvar () in + (* this unification cannot fail *) + Ctype.unify env more + (Btype.newgenty + (Tvariant + (create_row ~fields:[] ~more:more' + ~closed:true ~name ~fixed))) + end + +(* + Check whether the first column of env makes up a complete signature or + not. We work on the discriminating pattern heads of each sub-matrix: they + are not omega/Any. +*) +let full_match closing env = match env with +| [] -> false +| (discr, _) :: _ -> + let open Patterns.Head in + match discr.pat_desc with + | Any -> assert false + | Construct { cstr_tag = Cstr_extension _ ; _ } -> false + | Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts + | Variant { type_row; _ } -> + let fields = + List.map + (fun (d, _) -> + match d.pat_desc with + | Variant { tag } -> tag + | _ -> assert false) + env + in + let row = type_row () in + if closing && not (Btype.has_fixed_explanation row) then + (* closing=true, we are considering the variant as closed *) + List.for_all + (fun (tag,f) -> + match row_field_repr f with + Rabsent | Reither(_, _, false) -> true + | Reither (_, _, true) + (* m=true, do not discard matched tags, rather warn *) + | Rpresent _ -> List.mem tag fields) + (row_fields row) + else + row_closed row && + List.for_all + (fun (tag,f) -> + row_field_repr f = Rabsent || List.mem tag fields) + (row_fields row) + | Constant Const_char _ -> + List.length env = 256 + | Constant _ + | Array _ -> false + | Tuple _ + | Record _ + | Lazy -> true + +(* Written as a non-fragile matching, PR#7451 originated from a fragile matching + below. *) +let should_extend ext env = match ext with +| None -> false +| Some ext -> begin match env with + | [] -> assert false + | (p,_)::_ -> + let open Patterns.Head in + begin match p.pat_desc with + | Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} -> + let path = get_constructor_type_path p.pat_type p.pat_env in + Path.same path ext + | Construct {cstr_tag=(Cstr_extension _)} -> false + | Constant _ | Tuple _ | Variant _ | Record _ | Array _ | Lazy -> false + | Any -> assert false + end +end + +(* build a pattern from a constructor description *) +let pat_of_constr ex_pat cstr = + {ex_pat with pat_desc = + Tpat_construct (mknoloc (Longident.Lident cstr.cstr_name), + cstr, omegas cstr.cstr_arity, None)} + +let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env + +let rec orify_many = function +| [] -> assert false +| [x] -> x +| x :: xs -> orify x (orify_many xs) + +(* build an or-pattern from a constructor list *) +let pat_of_constrs ex_pat cstrs = + let ex_pat = Patterns.Head.to_omega_pattern ex_pat in + if cstrs = [] then raise Empty else + orify_many (List.map (pat_of_constr ex_pat) cstrs) + +let pats_of_type env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _ | Type_record _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) when List.length cstrs <= 1 || + (* Only explode when all constructors are GADTs *) + List.for_all (fun cd -> cd.cstr_generalized) cstrs -> + List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs + | Type_record (labels, _) -> + let fields = + List.map (fun ld -> + mknoloc (Longident.Lident ld.lbl_name), ld, omega) + labels + in + [make_pat (Tpat_record (fields, Closed)) ty env] + | _ -> [omega] + end + | Has_no_typedecl -> + begin match get_desc (Ctype.expand_head env ty) with + Ttuple tl -> + [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] + | _ -> [omega] + end + | Typedecl (_, _, {type_kind = Type_abstract _ | Type_open}) + | May_have_typedecl -> [omega] + +let get_variant_constructors env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) -> cstrs + | _ -> fatal_error "Parmatch.get_variant_constructors" + end + | _ -> fatal_error "Parmatch.get_variant_constructors" + +module ConstructorSet = Set.Make(struct + type t = constructor_description + let compare c1 c2 = String.compare c1.cstr_name c2.cstr_name +end) + +(* Sends back a pattern that complements the given constructors used_constrs *) +let complete_constrs constr used_constrs = + let c = constr.pat_desc in + let constrs = get_variant_constructors constr.pat_env c.cstr_res in + let used_constrs = ConstructorSet.of_list used_constrs in + let others = + List.filter + (fun cnstr -> not (ConstructorSet.mem cnstr used_constrs)) + constrs in + (* Split constructors to put constant ones first *) + let const, nonconst = + List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in + const @ nonconst + +let build_other_constrs env p = + let open Patterns.Head in + match p.pat_desc with + | Construct ({ cstr_tag = Cstr_extension _ }) -> extra_pat + | Construct + ({ cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed } as c) -> + let constr = { p with pat_desc = c } in + let get_constr q = + match q.pat_desc with + | Construct c -> c + | _ -> fatal_error "Parmatch.get_constr" in + let used_constrs = List.map (fun (p,_) -> get_constr p) env in + pat_of_constrs p (complete_constrs constr used_constrs) + | _ -> extra_pat + +(* Auxiliary for build_other *) + +let build_other_constant proj make first next p env = + let all = List.map (fun (p, _) -> proj p.pat_desc) env in + let rec try_const i = + if List.mem i all + then try_const (next i) + else make_pat (make i) p.pat_type p.pat_env + in try_const first + +(* + Builds a pattern that is incompatible with all patterns in + the first column of env +*) + +let some_private_tag = "" + +let build_other ext env = + match env with + | [] -> omega + | (d, _) :: _ -> + let open Patterns.Head in + match d.pat_desc with + | Construct { cstr_tag = Cstr_extension _ } -> + (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) + make_pat + (Tpat_var (Ident.create_local "*extension*", + {txt="*extension*"; loc = d.pat_loc}, + Uid.internal_not_actually_unique)) + Ctype.none Env.empty + | Construct _ -> + begin match ext with + | Some ext -> + if Path.same ext (get_constructor_type_path d.pat_type d.pat_env) + then + extra_pat + else + build_other_constrs env d + | _ -> + build_other_constrs env d + end + | Variant { cstr_row; type_row } -> + let tags = + List.map + (fun (d, _) -> + match d.pat_desc with + | Variant { tag } -> tag + | _ -> assert false) + env + in + let make_other_pat tag const = + let arg = if const then None else Some Patterns.omega in + make_pat (Tpat_variant(tag, arg, cstr_row)) d.pat_type d.pat_env + in + let row = type_row () in + begin match + List.fold_left + (fun others (tag,f) -> + if List.mem tag tags then others else + match row_field_repr f with + Rabsent (* | Reither _ *) -> others + (* This one is called after erasing pattern info *) + | Reither (c, _, _) -> make_other_pat tag c :: others + | Rpresent arg -> make_other_pat tag (arg = None) :: others) + [] (row_fields row) + with + [] -> + let tag = + if Btype.has_fixed_explanation row then some_private_tag else + let rec mktag tag = + if List.mem tag tags then mktag (tag ^ "'") else tag in + mktag "AnyOtherTag" + in make_other_pat tag true + | pat::other_pats -> + List.fold_left + (fun p_res pat -> + make_pat (Tpat_or (pat, p_res, None)) d.pat_type d.pat_env) + pat other_pats + end + | Constant Const_char _ -> + let all_chars = + List.map + (fun (p,_) -> match p.pat_desc with + | Constant (Const_char c) -> c + | _ -> assert false) + env + in + let rec find_other i imax = + if i > imax then raise Not_found + else + let ci = Char.chr i in + if List.mem ci all_chars then + find_other (i+1) imax + else + make_pat (Tpat_constant (Const_char ci)) d.pat_type d.pat_env + in + let rec try_chars = function + | [] -> Patterns.omega + | (c1,c2) :: rest -> + try + find_other (Char.code c1) (Char.code c2) + with + | Not_found -> try_chars rest + in + try_chars + [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ; + ' ', '~' ; Char.chr 0 , Char.chr 255] + | Constant Const_int _ -> + build_other_constant + (function Constant(Const_int i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_int i)) + 0 succ d env + | Constant Const_int32 _ -> + build_other_constant + (function Constant(Const_int32 i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_int32 i)) + 0l Int32.succ d env + | Constant Const_int64 _ -> + build_other_constant + (function Constant(Const_int64 i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_int64 i)) + 0L Int64.succ d env + | Constant Const_nativeint _ -> + build_other_constant + (function Constant(Const_nativeint i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_nativeint i)) + 0n Nativeint.succ d env + | Constant Const_string _ -> + build_other_constant + (function Constant(Const_string (s, _, _)) -> String.length s + | _ -> assert false) + (function i -> + Tpat_constant + (Const_string(String.make i '*',Location.none,None))) + 0 succ d env + | Constant Const_float _ -> + build_other_constant + (function Constant(Const_float f) -> float_of_string f + | _ -> assert false) + (function f -> Tpat_constant(Const_float (string_of_float f))) + 0.0 (fun f -> f +. 1.0) d env + | Array _ -> + let all_lengths = + List.map + (fun (p,_) -> match p.pat_desc with + | Array len -> len + | _ -> assert false) + env in + let rec try_arrays l = + if List.mem l all_lengths then try_arrays (l+1) + else + make_pat (Tpat_array (omegas l)) d.pat_type d.pat_env in + try_arrays 0 + | _ -> Patterns.omega + +let rec has_instance p = match p.pat_desc with + | Tpat_variant (l,_,r) when is_absent l r -> false + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true + | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p + | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 + | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps -> + has_instances ps + | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) + | Tpat_lazy p + -> has_instance p + +and has_instances = function + | [] -> true + | q::rem -> has_instance q && has_instances rem + +(* + Core function : + Is the last row of pattern matrix pss + qs satisfiable ? + That is : + Does there exists at least one value vector, es such that : + 1- for all ps in pss ps # es (ps and es are not compatible) + 2- qs <= es (es matches qs) + + --- + + In two places in the following function, we check the coherence of the first + column of (pss + qs). + If it is incoherent, then we exit early saying that (pss + qs) is not + satisfiable (which is equivalent to saying "oh, we shouldn't have considered + that branch, no good result came come from here"). + + But what happens if we have a coherent but ill-typed column? + - we might end up returning [false], which is equivalent to noticing the + incompatibility: clearly this is fine. + - if we end up returning [true] then we're saying that [qs] is useful while + it is not. This is sad but not the end of the world, we're just allowing dead + code to survive. +*) +let rec satisfiable pss qs = match pss with +| [] -> has_instances qs +| _ -> + match qs with + | [] -> false + | q::qs -> + match Patterns.General.(view q |> strip_vars).pat_desc with + | `Or(q1,q2,_) -> + satisfiable pss (q1::qs) || satisfiable pss (q2::qs) + | `Any -> + let pss = simplify_first_col pss in + if not (all_coherent (first_column pss)) then + false + else begin + let { default; constrs } = + let q0 = discr_pat Patterns.Simple.omega pss in + build_specialized_submatrices ~extend_row:(@) q0 pss in + if not (full_match false constrs) then + satisfiable default qs + else + List.exists + (fun (p,pss) -> + not (is_absent_pat p) && + satisfiable pss + (simple_match_args p Patterns.Head.omega [] @ qs)) + constrs + end + | `Variant (l,_,r) when is_absent l r -> false + | #Patterns.Simple.view as view -> + let q = { q with pat_desc = view } in + let pss = simplify_first_col pss in + let hq, qargs = Patterns.Head.deconstruct q in + if not (all_coherent (hq :: first_column pss)) then + false + else begin + let q0 = discr_pat q pss in + satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss) + (simple_match_args q0 hq qargs @ qs) + end + +(* While [satisfiable] only checks whether the last row of [pss + qs] is + satisfiable, this function returns the (possibly empty) list of vectors [es] + which verify: + 1- for all ps in pss, ps # es (ps and es are not compatible) + 2- qs <= es (es matches qs) + + This is done to enable GADT handling + + For considerations regarding the coherence check, see the comment on + [satisfiable] above. *) +let rec list_satisfying_vectors pss qs = + match pss with + | [] -> if has_instances qs then [qs] else [] + | _ -> + match qs with + | [] -> [] + | q :: qs -> + match Patterns.General.(view q |> strip_vars).pat_desc with + | `Or(q1,q2,_) -> + list_satisfying_vectors pss (q1::qs) @ + list_satisfying_vectors pss (q2::qs) + | `Any -> + let pss = simplify_first_col pss in + if not (all_coherent (first_column pss)) then + [] + else begin + let q0 = discr_pat Patterns.Simple.omega pss in + let wild default_matrix p = + List.map (fun qs -> p::qs) + (list_satisfying_vectors default_matrix qs) + in + match build_specialized_submatrices ~extend_row:(@) q0 pss with + | { default; constrs = [] } -> + (* first column of pss is made of variables only *) + wild default omega + | { default; constrs = ((p,_)::_ as constrs) } -> + let for_constrs () = + List.flatten ( + List.map (fun (p,pss) -> + if is_absent_pat p then + [] + else + let witnesses = + list_satisfying_vectors pss + (simple_match_args p Patterns.Head.omega [] @ qs) + in + let p = Patterns.Head.to_omega_pattern p in + List.map (set_args p) witnesses + ) constrs + ) + in + if full_match false constrs then for_constrs () else + begin match p.pat_desc with + | Construct _ -> + (* activate this code + for checking non-gadt constructors *) + wild default (build_other_constrs constrs p) + @ for_constrs () + | _ -> + wild default Patterns.omega + end + end + | `Variant (l, _, r) when is_absent l r -> [] + | #Patterns.Simple.view as view -> + let q = { q with pat_desc = view } in + let hq, qargs = Patterns.Head.deconstruct q in + let pss = simplify_first_col pss in + if not (all_coherent (hq :: first_column pss)) then + [] + else begin + let q0 = discr_pat q pss in + List.map (set_args (Patterns.Head.to_omega_pattern q0)) + (list_satisfying_vectors + (build_specialized_submatrix ~extend_row:(@) q0 pss) + (simple_match_args q0 hq qargs @ qs)) + end + +(******************************************) +(* Look for a row that matches some value *) +(******************************************) + +(* + Useful for seeing if the example of + non-matched value can indeed be matched + (by a guarded clause) +*) + +let rec do_match pss qs = match qs with +| [] -> + begin match pss with + | []::_ -> true + | _ -> false + end +| q::qs -> match Patterns.General.(view q |> strip_vars).pat_desc with + | `Or (q1,q2,_) -> + do_match pss (q1::qs) || do_match pss (q2::qs) + | `Any -> + let rec remove_first_column = function + | (_::ps)::rem -> ps::remove_first_column rem + | _ -> [] + in + do_match (remove_first_column pss) qs + | #Patterns.Simple.view as view -> + let q = { q with pat_desc = view } in + let q0, qargs = Patterns.Head.deconstruct q in + let pss = simplify_first_col pss in + (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of + its first column. *) + do_match + (build_specialized_submatrix ~extend_row:(@) q0 pss) + (qargs @ qs) + +(* +let print_pat pat = + let rec string_of_pat pat = + match pat.pat_desc with + Tpat_var _ -> "v" + | Tpat_any -> "_" + | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?" (string_of_pat p) + | Tpat_constant n -> "0" + | Tpat_construct (_, lid, _) -> + Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt)) + | Tpat_lazy p -> + Printf.sprintf "(lazy %s)" (string_of_pat p) + | Tpat_or (p1,p2,_) -> + Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2) + | Tpat_tuple list -> + Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) + | Tpat_variant (_, _, _) -> "variant" + | Tpat_record (_, _) -> "record" + | Tpat_array _ -> "array" + in + Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) +*) + +(* + Now another satisfiable function that additionally + supplies an example of a matching value. + + This function should be called for exhaustiveness check only. +*) +let rec exhaust (ext:Path.t option) pss n = match pss with +| [] -> Seq.return (omegas n) +| []::_ -> Seq.empty +| [(p :: ps)] -> exhaust_single_row ext p ps n +| pss -> specialize_and_exhaust ext pss n + +and exhaust_single_row ext p ps n = + (* Shortcut: in the single-row case p :: ps we know that all + counter-examples are either of the form + counter-example(p) :: omegas + or + p :: counter-examples(ps) + + This is very interesting in the case where p contains + or-patterns, as the non-shortcut path below would do a separate + search for each constructor of the or-pattern, which can lead to + an exponential blowup on examples such as + + | (A|B), (A|B), (A|B), (A|B) -> foo + + Note that this shortcut also applies to examples such as + + | A, A, A, A -> foo | (A|B), (A|B), (A|B), (A|B) -> bar + + thanks to the [get_mins] preprocessing step which will drop the + first row (subsumed by the second). Code with this shape does + occur naturally when people want to avoid fragile pattern + matches: if A and B are the only two constructors, this is the + best way to make a non-fragile distinction between "all As" and + "at least one B". + *) + List.to_seq [Some p; None] |> Seq.flat_map + (function + | Some p -> + let sub_witnesses = exhaust ext [ps] (n - 1) in + Seq.map (fun row -> p :: row) sub_witnesses + | None -> + (* note: calling [exhaust] recursively of p would + result in an infinite loop in the case n=1 *) + let p_witnesses = specialize_and_exhaust ext [[p]] 1 in + Seq.map (fun p_row -> p_row @ omegas (n - 1)) p_witnesses + ) + +and specialize_and_exhaust ext pss n = + let pss = simplify_first_col pss in + if not (all_coherent (first_column pss)) then + (* We're considering an ill-typed branch, we won't actually be able to + produce a well typed value taking that branch. *) + Seq.empty + else begin + (* Assuming the first column is ill-typed but considered coherent, we + might end up producing an ill-typed witness of non-exhaustivity + corresponding to the current branch. + + If [exhaust] has been called by [do_check_partial], then the witnesses + produced get typechecked and the ill-typed ones are discarded. + + If [exhaust] has been called by [do_check_fragile], then it is possible + we might fail to warn the user that the matching is fragile. See for + example testsuite/tests/warnings/w04_failure.ml. *) + let q0 = discr_pat Patterns.Simple.omega pss in + match build_specialized_submatrices ~extend_row:(@) q0 pss with + | { default; constrs = [] } -> + (* first column of pss is made of variables only *) + let sub_witnesses = exhaust ext default (n-1) in + let q0 = Patterns.Head.to_omega_pattern q0 in + Seq.map (fun row -> q0::row) sub_witnesses + | { default; constrs } -> + let try_non_omega (p,pss) = + if is_absent_pat p then + Seq.empty + else + let sub_witnesses = + exhaust + ext pss + (List.length (simple_match_args p Patterns.Head.omega []) + + n - 1) + in + let p = Patterns.Head.to_omega_pattern p in + Seq.map (set_args p) sub_witnesses + in + let try_omega () = + if full_match false constrs && not (should_extend ext constrs) then + Seq.empty + else + let sub_witnesses = exhaust ext default (n-1) in + match build_other ext constrs with + | exception Empty -> + (* cannot occur, since constructors don't make + a full signature *) + fatal_error "Parmatch.exhaust" + | p -> + Seq.map (fun tail -> p :: tail) sub_witnesses + in + (* Lazily compute witnesses for all constructor submatrices + (Some constr_mat) then the wildcard/default submatrix (None). + Note that the call to [try_omega ()] is delayed to after + all constructor matrices have been traversed. *) + List.map (fun constr_mat -> Some constr_mat) constrs @ [None] + |> List.to_seq + |> Seq.flat_map + (function + | Some constr_mat -> try_non_omega constr_mat + | None -> try_omega ()) + end + +let exhaust ext pss n = + exhaust ext pss n + |> Seq.map (function + | [x] -> x + | _ -> assert false) + +(* + Another exhaustiveness check, enforcing variant typing. + Note that it does not check exact exhaustiveness, but whether a + matching could be made exhaustive by closing all variant types. + When this is true of all other columns, the current column is left + open (even if it means that the whole matching is not exhaustive as + a result). + When this is false for the matrix minus the current column, and the + current column is composed of variant tags, we close the variant + (even if it doesn't help in making the matching exhaustive). +*) + +let rec pressure_variants tdefs = function + | [] -> false + | []::_ -> true + | pss -> + let pss = simplify_first_col pss in + if not (all_coherent (first_column pss)) then + true + else begin + let q0 = discr_pat Patterns.Simple.omega pss in + match build_specialized_submatrices ~extend_row:(@) q0 pss with + | { default; constrs = [] } -> pressure_variants tdefs default + | { default; constrs } -> + let rec try_non_omega = function + | (_p,pss) :: rem -> + let ok = pressure_variants tdefs pss in + (* The order below matters : we want [pressure_variants] to be + called on all the specialized submatrices because we might + close some variant in any of them regardless of whether [ok] + is true for [pss] or not *) + try_non_omega rem && ok + | [] -> true + in + if full_match (tdefs=None) constrs then + try_non_omega constrs + else if tdefs = None then + pressure_variants None default + else + let full = full_match true constrs in + let ok = + if full then + try_non_omega constrs + else begin + let { constrs = partial_constrs; _ } = + build_specialized_submatrices ~extend_row:(@) q0 + (mark_partial pss) + in + try_non_omega partial_constrs + end + in + begin match constrs, tdefs with + | [], _ + | _, None -> () + | (d, _) :: _, Some env -> + match d.pat_desc with + | Variant { type_row; _ } -> + let row = type_row () in + if Btype.has_fixed_explanation row + || pressure_variants None default then () + else close_variant env row + | _ -> () + end; + ok + end + + +(* Yet another satisfiable function *) + +(* + This time every_satisfiable pss qs checks the + utility of every expansion of qs. + Expansion means expansion of or-patterns inside qs +*) + +type answer = + | Used (* Useful pattern *) + | Unused (* Useless pattern *) + | Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *) + + + +(* this row type enable column processing inside the matrix + - left -> elements not to be processed, + - right -> elements to be processed +*) +type usefulness_row = + {no_ors : pattern list ; ors : pattern list ; active : pattern list} + +(* +let pretty_row {ors=ors ; no_ors=no_ors; active=active} = + pretty_line ors ; prerr_string " *" ; + pretty_line no_ors ; prerr_string " *" ; + pretty_line active + +let pretty_rows rs = + prerr_endline "begin matrix" ; + List.iter + (fun r -> + pretty_row r ; + prerr_endline "") + rs ; + prerr_endline "end matrix" +*) + +(* Initial build *) +let make_row ps = {ors=[] ; no_ors=[]; active=ps} + +let make_rows pss = List.map make_row pss + + +(* Useful to detect and expand or pats inside as pats *) +let is_var p = match Patterns.General.(view p |> strip_vars).pat_desc with +| `Any -> true +| _ -> false + +let is_var_column rs = + List.for_all + (fun r -> match r.active with + | p::_ -> is_var p + | [] -> assert false) + rs + +(* Standard or-args for left-to-right matching *) +let rec or_args p = match p.pat_desc with +| Tpat_or (p1,p2,_) -> p1,p2 +| Tpat_alias (p,_,_,_) -> or_args p +| _ -> assert false + +(* Just remove current column *) +let remove r = match r.active with +| _::rem -> {r with active=rem} +| [] -> assert false + +let remove_column rs = List.map remove rs + +(* Current column has been processed *) +let push_no_or r = match r.active with +| p::rem -> { r with no_ors = p::r.no_ors ; active=rem} +| [] -> assert false + +let push_or r = match r.active with +| p::rem -> { r with ors = p::r.ors ; active=rem} +| [] -> assert false + +let push_or_column rs = List.map push_or rs +and push_no_or_column rs = List.map push_no_or rs + +let rec simplify_first_usefulness_col = function + | [] -> [] + | row :: rows -> + match row.active with + | [] -> assert false (* the rows are non-empty! *) + | p :: ps -> + let add_column p ps k = + (p, { row with active = ps }) :: k in + simplify_head_pat ~add_column p ps + (simplify_first_usefulness_col rows) + +(* Back to normal matrices *) +let make_vector r = List.rev r.no_ors + +let make_matrix rs = List.map make_vector rs + + +(* Standard union on answers *) +let union_res r1 r2 = match r1, r2 with +| (Unused,_) +| (_, Unused) -> Unused +| Used,_ -> r2 +| _, Used -> r1 +| Upartial u1, Upartial u2 -> Upartial (u1@u2) + +(* propose or pats for expansion *) +let extract_elements qs = + let rec do_rec seen = function + | [] -> [] + | q::rem -> + {no_ors= List.rev_append seen rem @ qs.no_ors ; + ors=[] ; + active = [q]}:: + do_rec (q::seen) rem in + do_rec [] qs.ors + +(* idem for matrices *) +let transpose rs = match rs with +| [] -> assert false +| r::rem -> + let i = List.map (fun x -> [x]) r in + List.fold_left + (List.map2 (fun r x -> x::r)) + i rem + +let extract_columns pss qs = match pss with +| [] -> List.map (fun _ -> []) qs.ors +| _ -> + let rows = List.map extract_elements pss in + transpose rows + +(* Core function + The idea is to first look for or patterns (recursive case), then + check or-patterns argument usefulness (terminal case) +*) + +let rec every_satisfiables pss qs = match qs.active with +| [] -> + (* qs is now partitioned, check usefulness *) + begin match qs.ors with + | [] -> (* no or-patterns *) + if satisfiable (make_matrix pss) (make_vector qs) then + Used + else + Unused + | _ -> (* n or-patterns -> 2n expansions *) + List.fold_right2 + (fun pss qs r -> match r with + | Unused -> Unused + | _ -> + match qs.active with + | [q] -> + let q1,q2 = or_args q in + let r_loc = every_both pss qs q1 q2 in + union_res r r_loc + | _ -> assert false) + (extract_columns pss qs) (extract_elements qs) + Used + end +| q::rem -> + begin match Patterns.General.(view q |> strip_vars).pat_desc with + | `Any -> + if is_var_column pss then + (* forget about ``all-variable'' columns now *) + every_satisfiables (remove_column pss) (remove qs) + else + (* otherwise this is direct food for satisfiable *) + every_satisfiables (push_no_or_column pss) (push_no_or qs) + | `Or (q1,q2,_) -> + if + q1.pat_loc.Location.loc_ghost && + q2.pat_loc.Location.loc_ghost + then + (* syntactically generated or-pats should not be expanded *) + every_satisfiables (push_no_or_column pss) (push_no_or qs) + else + (* this is a real or-pattern *) + every_satisfiables (push_or_column pss) (push_or qs) + | `Variant (l,_,r) when is_absent l r -> (* Ah Jacques... *) + Unused + | #Patterns.Simple.view as view -> + let q = { q with pat_desc = view } in + (* standard case, filter matrix *) + let pss = simplify_first_usefulness_col pss in + let hq, args = Patterns.Head.deconstruct q in + (* The handling of incoherent matrices is kept in line with + [satisfiable] *) + if not (all_coherent (hq :: first_column pss)) then + Unused + else begin + let q0 = discr_pat q pss in + every_satisfiables + (build_specialized_submatrix q0 pss + ~extend_row:(fun ps r -> { r with active = ps @ r.active })) + {qs with active=simple_match_args q0 hq args @ rem} + end + end + +(* + This function ``every_both'' performs the usefulness check + of or-pat q1|q2. + The trick is to call every_satisfied twice with + current active columns restricted to q1 and q2, + That way, + - others orpats in qs.ors will not get expanded. + - all matching work performed on qs.no_ors is not performed again. + *) +and every_both pss qs q1 q2 = + let qs1 = {qs with active=[q1]} + and qs2 = {qs with active=[q2]} in + let r1 = every_satisfiables pss qs1 + and r2 = every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in + match r1 with + | Unused -> + begin match r2 with + | Unused -> Unused + | Used -> Upartial [q1] + | Upartial u2 -> Upartial (q1::u2) + end + | Used -> + begin match r2 with + | Unused -> Upartial [q2] + | _ -> r2 + end + | Upartial u1 -> + begin match r2 with + | Unused -> Upartial (u1@[q2]) + | Used -> r1 + | Upartial u2 -> Upartial (u1 @ u2) + end + + + + +(* le_pat p q means, forall V, V matches q implies V matches p *) +let rec le_pat p q = + match (p.pat_desc, q.pat_desc) with + | (Tpat_var _|Tpat_any),_ -> true + | Tpat_alias(p,_,_,_), _ -> le_pat p q + | _, Tpat_alias(q,_,_,_) -> le_pat p q + | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 + | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) -> + Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs + | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> + (l1 = l2 && le_pat p1 p2) + | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) -> + l1 = l2 + | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false + | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs + | Tpat_lazy p, Tpat_lazy q -> le_pat p q + | Tpat_record (l1,_), Tpat_record (l2,_) -> + let ps,qs = records_args l1 l2 in + le_pats ps qs + | Tpat_array(ps), Tpat_array(qs) -> + List.length ps = List.length qs && le_pats ps qs +(* In all other cases, enumeration is performed *) + | _,_ -> not (satisfiable [[p]] [q]) + +and le_pats ps qs = + match ps,qs with + p::ps, q::qs -> le_pat p q && le_pats ps qs + | _, _ -> true + +let get_mins le ps = + let rec select_rec r = function + [] -> r + | p::ps -> + if List.exists (fun p0 -> le p0 p) ps + then select_rec r ps + else select_rec (p::r) ps in + (* [select_rec] removes the elements that are followed by a smaller element. + An element that is preceded by a smaller element may stay in the list. + We thus do two passes on the list, which is returned reversed + the first time. *) + select_rec [] (select_rec [] ps) + +(* + lub p q is a pattern that matches all values matched by p and q + may raise Empty, when p and q are not compatible +*) + +let rec lub p q = match p.pat_desc,q.pat_desc with +| Tpat_alias (p,_,_,_),_ -> lub p q +| _,Tpat_alias (q,_,_,_) -> lub p q +| (Tpat_any|Tpat_var _),_ -> q +| _,(Tpat_any|Tpat_var _) -> p +| Tpat_or (p1,p2,_),_ -> orlub p1 p2 q +| _,Tpat_or (q1,q2,_) -> orlub q1 q2 p (* Thanks god, lub is commutative *) +| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p +| Tpat_tuple ps, Tpat_tuple qs -> + let rs = lubs ps qs in + make_pat (Tpat_tuple rs) p.pat_type p.pat_env +| Tpat_lazy p, Tpat_lazy q -> + let r = lub p q in + make_pat (Tpat_lazy r) p.pat_type p.pat_env +| Tpat_construct (lid,c1,ps1,_), Tpat_construct (_,c2,ps2,_) + when Types.equal_tag c1.cstr_tag c2.cstr_tag -> + let rs = lubs ps1 ps2 in + make_pat (Tpat_construct (lid, c1, rs, None)) + p.pat_type p.pat_env +| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_) + when l1=l2 -> + let r=lub p1 p2 in + make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env +| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_) + when l1 = l2 -> p +| Tpat_record (l1,closed),Tpat_record (l2,_) -> + let rs = record_lubs l1 l2 in + make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env +| Tpat_array ps, Tpat_array qs + when List.length ps = List.length qs -> + let rs = lubs ps qs in + make_pat (Tpat_array rs) p.pat_type p.pat_env +| _,_ -> + raise Empty + +and orlub p1 p2 q = + try + let r1 = lub p1 q in + try + {q with pat_desc=(Tpat_or (r1,lub p2 q,None))} + with + | Empty -> r1 +with +| Empty -> lub p2 q + +and record_lubs l1 l2 = + let rec lub_rec l1 l2 = match l1,l2 with + | [],_ -> l2 + | _,[] -> l1 + | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then + (lid1, lbl1,p1)::lub_rec rem1 l2 + else if lbl2.lbl_pos < lbl1.lbl_pos then + (lid2, lbl2,p2)::lub_rec l1 rem2 + else + (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in + lub_rec l1 l2 + +and lubs ps qs = match ps,qs with +| p::ps, q::qs -> lub p q :: lubs ps qs +| _,_ -> [] + + +(******************************) +(* Exported variant closing *) +(******************************) + +(* Apply pressure to variants *) + +let pressure_variants tdefs patl = + ignore (pressure_variants + (Some tdefs) + (List.map (fun p -> [p; omega]) patl)) + +let pressure_variants_in_computation_pattern tdefs patl = + let add_row pss p_opt = + match p_opt with + | None -> pss + | Some p -> p :: pss + in + let val_pss, exn_pss = + List.fold_right (fun pat (vpss, epss)-> + let (vp, ep) = split_pattern pat in + add_row vpss vp, add_row epss ep + ) patl ([], []) + in + pressure_variants tdefs val_pss; + pressure_variants tdefs exn_pss + +(*****************************) +(* Utilities for diagnostics *) +(*****************************) + +(* + Build up a working pattern matrix by forgetting + about guarded patterns +*) + +let rec initial_matrix = function + [] -> [] + | {has_guard=true} :: rem -> initial_matrix rem + | {has_guard=false; pattern=p} :: rem -> [p] :: initial_matrix rem + +(* + Build up a working pattern matrix by keeping + only the patterns which are guarded +*) +let rec initial_only_guarded = function + | [] -> [] + | { has_guard = false; _} :: rem -> + initial_only_guarded rem + | { pattern = pat; _ } :: rem -> + [pat] :: initial_only_guarded rem + + +(************************) +(* Exhaustiveness check *) +(************************) + +(* Whether the counter-example contains an extension pattern *) +let contains_extension pat = + exists_pattern + (function + | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true + | _ -> false) + pat + +let do_check_partial ~pred loc casel pss = match pss with +| [] -> + (* + This can occur + - For empty matches generated by ocamlp4 (no warning) + - when all patterns have guards (then, casel <> []) + (specific warning) + Then match MUST be considered non-exhaustive, + otherwise compilation of PM is broken. + *) + begin match casel with + | [] -> () + | _ -> + if Warnings.is_active Warnings.All_clauses_guarded then + Location.prerr_warning loc Warnings.All_clauses_guarded + end ; + Partial +| ps::_ -> + let counter_examples = + exhaust None pss (List.length ps) |> Seq.filter_map pred in + match counter_examples () with + | Seq.Nil -> Total + | Seq.Cons (v, _rest) -> + if Warnings.is_active (Warnings.Partial_match "") then begin + let errmsg = + let doc = ref Format_doc.Doc.empty in + let fmt = Format_doc.formatter doc in + Format_doc.fprintf fmt "@[%a" Printpat.top_pretty v; + if do_match (initial_only_guarded casel) [v] then + Format_doc.fprintf fmt + "@,(However, some guarded clause may match this value.)"; + if contains_extension v then + Format_doc.fprintf fmt + "@,@[Matching over values of extensible variant types \ + (the *extension* above)@,\ + must include a wild card pattern@ in order to be exhaustive.@]" + ; + Format_doc.fprintf fmt "@]"; + Format_doc.(asprintf "%a" pp_doc) !doc + in + Location.prerr_warning loc (Warnings.Partial_match errmsg) + end; + Partial + +(*****************) +(* Fragile check *) +(*****************) + +(* Collect all data types in a pattern *) + +let rec add_path path = function + | [] -> [path] + | x::rem as paths -> + if Path.same path x then paths + else x::add_path path rem + +let extendable_path path = + not + (Path.same path Predef.path_bool || + Path.same path Predef.path_list || + Path.same path Predef.path_unit || + Path.same path Predef.path_option) + +let rec collect_paths_from_pat r p = match p.pat_desc with +| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)}, + ps, _) -> + let path = get_constructor_type_path p.pat_type p.pat_env in + List.fold_left + collect_paths_from_pat + (if extendable_path path then add_path path r else r) + ps +| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r +| Tpat_tuple ps | Tpat_array ps +| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps, _)-> + List.fold_left collect_paths_from_pat r ps +| Tpat_record (lps,_) -> + List.fold_left + (fun r (_, _, p) -> collect_paths_from_pat r p) + r lps +| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_) -> + collect_paths_from_pat r p +| Tpat_or (p1,p2,_) -> + collect_paths_from_pat (collect_paths_from_pat r p1) p2 +| Tpat_lazy p + -> + collect_paths_from_pat r p + + +(* + Actual fragile check + 1. Collect data types in the patterns of the match. + 2. One exhaustivity check per datatype, considering that + the type is extended. +*) + +let do_check_fragile loc casel pss = + let exts = + List.fold_left + (fun r c -> collect_paths_from_pat r c.pattern) + [] casel in + match exts with + | [] -> () + | _ -> match pss with + | [] -> () + | ps::_ -> + List.iter + (fun ext -> + let witnesses = exhaust (Some ext) pss (List.length ps) in + match witnesses () with + | Seq.Nil -> + Location.prerr_warning + loc + (Warnings.Fragile_match (Path.name ext)) + | Seq.Cons _ -> ()) + exts + +(********************************) +(* Exported unused clause check *) +(********************************) + +let check_unused pred casel = + if Warnings.is_active Warnings.Redundant_case + || List.exists (fun vc -> vc.needs_refute) casel then + let rec do_rec pref = function + | [] -> () + | {pattern=q; has_guard; needs_refute=refute} :: rem -> + let qs = [q] in + begin try + let pss = + (* prev was accumulated in reverse order; + restore source order to get ordered counter-examples *) + List.rev pref + |> List.filter (compats qs) + |> get_mins le_pats in + (* First look for redundant or partially redundant patterns *) + let r = every_satisfiables (make_rows pss) (make_row qs) in + (* Do not warn for unused [pat -> .] *) + if r = Unused && refute then () else + let r = + (* Do not refine if either: + - we already know the clause is unused + - the clause under consideration is not a refutation clause + and either: + + there are no other lines + + we do not care whether the types prevent this clause to + be reached. + If the clause under consideration *is* a refutation clause + then we do need to check more carefully whether it can be + refuted or not. *) + let skip = + r = Unused || (not refute && pref = []) || + not(refute || Warnings.is_active Warnings.Unreachable_case) in + if skip then r else + (* Then look for empty patterns *) + let sfs = list_satisfying_vectors pss qs in + if sfs = [] then Unused else + let sfs = + List.map (function [u] -> u | _ -> assert false) sfs in + let u = orify_many sfs in + (*Format.eprintf "%a@." pretty_val u;*) + let pattern = {u with pat_loc = q.pat_loc} in + match pred refute pattern with + None when not refute -> + Location.prerr_warning q.pat_loc Warnings.Unreachable_case; + Used + | _ -> r + in + match r with + | Unused -> + Location.prerr_warning + q.pat_loc Warnings.Redundant_case + | Upartial ps -> + List.iter + (fun p -> + Location.prerr_warning + p.pat_loc Warnings.Redundant_subpat) + ps + | Used -> () + with Empty | Not_found -> assert false + end ; + + if has_guard then + do_rec pref rem + else + do_rec ([q]::pref) rem in + + do_rec [] casel + +(*********************************) +(* Exported irrefutability tests *) +(*********************************) + +let irrefutable pat = le_pat pat omega + +let inactive ~partial pat = + match partial with + | Partial -> false + | Total -> begin + let rec loop pat = + match pat.pat_desc with + | Tpat_lazy _ | Tpat_array _ -> + false + | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) -> + true + | Tpat_constant c -> begin + match c with + | Const_string _ + | Const_int _ | Const_char _ | Const_float _ + | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true + end + | Tpat_tuple ps | Tpat_construct (_, _, ps, _) -> + List.for_all (fun p -> loop p) ps + | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) -> + loop p + | Tpat_record (ldps,_) -> + List.for_all + (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) + ldps + | Tpat_or (p,q,_) -> + loop p && loop q + in + loop pat + end + + + + + + + +(*********************************) +(* Exported exhaustiveness check *) +(*********************************) + +(* + Fragile check is performed when required and + on exhaustive matches only. +*) + +let check_partial pred loc casel = + let pss = initial_matrix casel in + let pss = get_mins le_pats pss in + let total = do_check_partial ~pred loc casel pss in + if + total = Total && Warnings.is_active (Warnings.Fragile_match "") + then begin + do_check_fragile loc casel pss + end ; + total + +(*************************************) +(* Ambiguous variable in or-patterns *) +(*************************************) + +(* Specification: ambiguous variables in or-patterns. + + The semantics of or-patterns in OCaml is specified with + a left-to-right bias: a value [v] matches the pattern [p | q] if it + matches [p] or [q], but if it matches both, the environment + captured by the match is the environment captured by [p], never the + one captured by [q]. + + While this property is generally well-understood, one specific case + where users expect a different semantics is when a pattern is + followed by a when-guard: [| p when g -> e]. Consider for example: + + | ((Const x, _) | (_, Const x)) when is_neutral x -> branch + + The semantics is clear: match the scrutinee against the pattern, if + it matches, test the guard, and if the guard passes, take the + branch. + + However, consider the input [(Const a, Const b)], where [a] fails + the test [is_neutral f], while [b] passes the test [is_neutral + b]. With the left-to-right semantics, the clause above is *not* + taken by its input: matching [(Const a, Const b)] against the + or-pattern succeeds in the left branch, it returns the environment + [x -> a], and then the guard [is_neutral a] is tested and fails, + the branch is not taken. Most users, however, intuitively expect + that any pair that has one side passing the test will take the + branch. They assume it is equivalent to the following: + + | (Const x, _) when is_neutral x -> branch + | (_, Const x) when is_neutral x -> branch + + while it is not. + + The code below is dedicated to finding these confusing cases: the + cases where a guard uses "ambiguous" variables, that are bound to + different parts of the scrutinees by different sides of + a or-pattern. In other words, it finds the cases where the + specified left-to-right semantics is not equivalent to + a non-deterministic semantics (any branch can be taken) relatively + to a specific guard. +*) + +let pattern_vars p = Ident.Set.of_list (Typedtree.pat_bound_idents p) + +(* Row for ambiguous variable search, + row is the traditional pattern row, + varsets contain a list of head variable sets (varsets) + + A given varset contains all the variables that appeared at the head + of a pattern in the row at some point during traversal: they would + all be bound to the same value at matching time. On the contrary, + two variables of different varsets appeared at different places in + the pattern and may be bound to distinct sub-parts of the matched + value. + + All rows of a (sub)matrix have rows of the same length, + but also varsets of the same length. + + Varsets are populated when simplifying the first column + -- the variables of the head pattern are collected in a new varset. + For example, + { row = x :: r1; varsets = s1 } + { row = (Some _) as y :: r2; varsets = s2 } + { row = (None as x) as y :: r3; varsets = s3 } + { row = (Some x | (None as x)) :: r4 with varsets = s4 } + becomes + (_, { row = r1; varsets = {x} :: s1 }) + (Some _, { row = r2; varsets = {y} :: s2 }) + (None, { row = r3; varsets = {x, y} :: s3 }) + (Some x, { row = r4; varsets = {} :: s4 }) + (None, { row = r4; varsets = {x} :: s4 }) +*) +type amb_row = { row : pattern list ; varsets : Ident.Set.t list; } + +let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k = + let rec simpl head_bound_variables varsets p ps k = + match (Patterns.General.view p).pat_desc with + | `Alias (p,x,_,_) -> + simpl (Ident.Set.add x head_bound_variables) varsets p ps k + | `Var (x,_,_) -> + simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k + | `Or (p1,p2,_) -> + simpl head_bound_variables varsets p1 ps + (simpl head_bound_variables varsets p2 ps k) + | #Patterns.Simple.view as view -> + add_column (Patterns.Head.deconstruct { p with pat_desc = view }) + { row = ps; varsets = head_bound_variables :: varsets; } k + in simpl head_bound_variables varsets p ps k + +(* + To accurately report ambiguous variables, one must consider + that previous clauses have already matched some values. + Consider for example: + + | (Foo x, Foo y) -> ... + | ((Foo x, _) | (_, Foo x)) when bar x -> ... + + The second line taken in isolation uses an unstable variable, + but the discriminating values, of the shape [(Foo v1, Foo v2)], + would all be filtered by the line above. + + To track this information, the matrices we analyze contain both + *positive* rows, that describe the rows currently being analyzed + (of type Varsets.row, so that their varsets are tracked) and + *negative rows*, that describe the cases already matched against. + + The values matched by a signed matrix are the values matched by + some of the positive rows but none of the negative rows. In + particular, a variable is stable if, for any value not matched by + any of the negative rows, the environment captured by any of the + matching positive rows is identical. +*) +type ('a, 'b) signed = Positive of 'a | Negative of 'b + +let rec simplify_first_amb_col = function + | [] -> [] + | (Negative [] | Positive { row = []; _ }) :: _ -> assert false + | Negative (n :: ns) :: rem -> + let add_column n ns k = (n, Negative ns) :: k in + simplify_head_pat + ~add_column n ns (simplify_first_amb_col rem) + | Positive { row = p::ps; varsets; }::rem -> + let add_column p ps k = (p, Positive ps) :: k in + simplify_head_amb_pat + Ident.Set.empty varsets + ~add_column p ps (simplify_first_amb_col rem) + +(* Compute stable bindings *) + +type stable_vars = + | All + | Vars of Ident.Set.t + +let stable_inter sv1 sv2 = match sv1, sv2 with + | All, sv | sv, All -> sv + | Vars s1, Vars s2 -> Vars (Ident.Set.inter s1 s2) + +let reduce f = function +| [] -> invalid_arg "reduce" +| x::xs -> List.fold_left f x xs + +let rec matrix_stable_vars m = match m with + | [] -> All + | ((Positive {row = []; _} | Negative []) :: _) as empty_rows -> + let exception Negative_empty_row in + (* if at least one empty row is negative, the matrix matches no value *) + let get_varsets = function + | Negative n -> + (* All rows have the same number of columns; + if the first row is empty, they all are. *) + assert (n = []); + raise Negative_empty_row + | Positive p -> + assert (p.row = []); + p.varsets in + begin match List.map get_varsets empty_rows with + | exception Negative_empty_row -> All + | rows_varsets -> + let stables_in_varsets = + reduce (List.map2 Ident.Set.inter) rows_varsets in + (* The stable variables are those stable at any position *) + Vars + (List.fold_left Ident.Set.union Ident.Set.empty stables_in_varsets) + end + | m -> + let is_negative = function + | Negative _ -> true + | Positive _ -> false in + if List.for_all is_negative m then + (* optimization: quit early if there are no positive rows. + This may happen often when the initial matrix has many + negative cases and few positive cases (a small guarded + clause after a long list of clauses) *) + All + else begin + let m = simplify_first_amb_col m in + if not (all_coherent (first_column m)) then + All + else begin + (* If the column is ill-typed but deemed coherent, we might + spuriously warn about some variables being unstable. + As sad as that might be, the warning can be silenced by + splitting the or-pattern... *) + let submatrices = + let extend_row columns = function + | Negative r -> Negative (columns @ r) + | Positive r -> Positive { r with row = columns @ r.row } in + let q0 = discr_pat Patterns.Simple.omega m in + let { default; constrs } = + build_specialized_submatrices ~extend_row q0 m in + let non_default = List.map snd constrs in + if full_match false constrs + then non_default + else default :: non_default in + (* A stable variable must be stable in each submatrix. *) + let submat_stable = List.map matrix_stable_vars submatrices in + List.fold_left stable_inter All submat_stable + end + end + +let pattern_stable_vars ns p = + matrix_stable_vars + (List.fold_left (fun m n -> Negative n :: m) + [Positive {varsets = []; row = [p]}] ns) + +(* All identifier paths that appear in an expression that occurs + as a clause right hand side or guard. +*) + +let all_rhs_idents exp = + let ids = ref Ident.Set.empty in + let open Tast_iterator in + let expr_iter iter exp = + match exp.exp_desc with + | Texp_ident (path, _lid, _descr) -> + List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path) + (* Use default iterator methods for rest of match.*) + | _ -> Tast_iterator.default_iterator.expr iter exp + in + let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in + iterator.expr iterator exp; + !ids + +let check_ambiguous_bindings = + let open Warnings in + let warn0 = Ambiguous_var_in_pattern_guard [] in + fun cases -> + if is_active warn0 then + let check_case ns case = match case with + | { c_lhs = p; c_guard=None ; _} -> [p]::ns + | { c_lhs = p; c_guard=Some g; _} -> + let all = + Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in + if not (Ident.Set.is_empty all) then begin + match pattern_stable_vars ns p with + | All -> () + | Vars stable -> + let ambiguous = Ident.Set.diff all stable in + if not (Ident.Set.is_empty ambiguous) then begin + let pps = + Ident.Set.elements ambiguous |> List.map Ident.name in + let warn = Ambiguous_var_in_pattern_guard pps in + Location.prerr_warning p.pat_loc warn + end + end; + ns + in + ignore (List.fold_left check_case [] cases) diff --git a/upstream/ocaml_503/typing/parmatch.mli b/upstream/ocaml_503/typing/parmatch.mli new file mode 100644 index 000000000..7e40dd29c --- /dev/null +++ b/upstream/ocaml_503/typing/parmatch.mli @@ -0,0 +1,135 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Detection of partial matches and unused match cases. *) + +open Asttypes +open Typedtree +open Types + +(** Most checks in this file need not access all information about a case, + and just need a few pieces of information. [parmatch_case] is those + few pieces of information. +*) +type 'pattern parmatch_case = + { pattern : 'pattern; + has_guard : bool; + needs_refute : bool; + (** true if the program text claims the case is unreachable, a la + [function _ -> .] + *) + } + +type 'category typed_case := 'category general_pattern parmatch_case + +val typed_case : 'category case -> 'category typed_case +val untyped_case : Parsetree.case -> Parsetree.pattern parmatch_case + +val const_compare : constant -> constant -> int +(** [const_compare c1 c2] compares the actual values represented by [c1] and + [c2], while simply using [Stdlib.compare] would compare the + representations. + + cf. MPR#5758 *) + +val le_pat : pattern -> pattern -> bool +(** [le_pat p q] means: forall V, V matches q implies V matches p *) + +val le_pats : pattern list -> pattern list -> bool +(** [le_pats (p1 .. pm) (q1 .. qn)] means: forall i <= m, [le_pat pi qi] *) + +(** Exported compatibility functor, abstracted over constructor equality *) +module Compat : + functor + (_ : sig + val equal : + Types.constructor_description -> + Types.constructor_description -> + bool + end) -> sig + val compat : pattern -> pattern -> bool + val compats : pattern list -> pattern list -> bool + end + +exception Empty + +val lub : pattern -> pattern -> pattern +(** [lub p q] is a pattern that matches all values matched by [p] and [q]. + May raise [Empty], when [p] and [q] are not compatible. *) + +val lubs : pattern list -> pattern list -> pattern list +(** [lubs [p1; ...; pn] [q1; ...; qk]], where [n < k], is + [[lub p1 q1; ...; lub pk qk]]. *) + +val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list + +(** This function recombines one pattern and its arguments: + For instance: + (_,_)::p1::p2::rem -> (p1, p2)::rem +*) +val set_args : pattern -> pattern list -> pattern list + +val pat_of_constr : pattern -> constructor_description -> pattern +val complete_constrs : + constructor_description pattern_data -> + constructor_description list -> + constructor_description list + +(** [pats_of_type] builds a list of patterns from a given expected type, + for explosion of wildcard patterns in Typecore.type_pat. + + There are four interesting cases: + - the type is empty ([]) + - no further explosion is necessary ([Pat_any]) + - a single pattern is generated, from a record or tuple type + or a single-variant type ([tp]) + - a list of patterns, in the case that all branches + are GADT constructors ([tp1; ..; tpn]). + *) +val pats_of_type : Env.t -> type_expr -> pattern list + +val pressure_variants: + Env.t -> pattern list -> unit +val pressure_variants_in_computation_pattern: + Env.t -> computation general_pattern list -> unit + +(** [check_partial pred loc caselist] and [check_unused refute pred caselist] + are called with a function [pred] which will be given counter-example + candidates: they may be partially ill-typed, and have to be type-checked + to extract a valid counter-example. + [pred] returns a valid counter-example or [None]. + [refute] indicates that [check_unused] was called on a refutation clause. + *) +val check_partial: + (pattern -> pattern option) -> Location.t -> value typed_case list + -> partial + +val check_unused: + (bool -> pattern -> pattern option) -> value typed_case list -> unit + +(* Irrefutability tests *) +val irrefutable : pattern -> bool + +(** An inactive pattern is a pattern, matching against which can be duplicated, + erased or delayed without change in observable behavior of the program. + Patterns containing (lazy _) subpatterns or reads of mutable fields are + active. *) +val inactive : partial:partial -> pattern -> bool + +(* Ambiguous bindings. *) +val check_ambiguous_bindings : value case list -> unit + +(* The tag used for open polymorphic variant types with an abstract row *) +val some_private_tag : label diff --git a/upstream/ocaml_503/typing/path.ml b/upstream/ocaml_503/typing/path.ml new file mode 100644 index 000000000..038ae48f8 --- /dev/null +++ b/upstream/ocaml_503/typing/path.ml @@ -0,0 +1,148 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + Pident of Ident.t + | Pdot of t * string + | Papply of t * t + | Pextra_ty of t * extra_ty +and extra_ty = + | Pcstr_ty of string + | Pext_ty + +let rec same p1 p2 = + p1 == p2 + || match (p1, p2) with + (Pident id1, Pident id2) -> Ident.same id1 id2 + | (Pdot(p1, s1), Pdot(p2, s2)) -> + s1 = s2 && same p1 p2 + | (Papply(fun1, arg1), Papply(fun2, arg2)) -> + same fun1 fun2 && same arg1 arg2 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let same_extra = match t1, t2 with + | (Pcstr_ty s1, Pcstr_ty s2) -> s1 = s2 + | (Pext_ty, Pext_ty) -> true + | ((Pcstr_ty _ | Pext_ty), _) -> false + in same_extra && same p1 p2 + | (_, _) -> false + +let rec compare p1 p2 = + if p1 == p2 then 0 + else match (p1, p2) with + (Pident id1, Pident id2) -> Ident.compare id1 id2 + | (Pdot(p1, s1), Pdot(p2, s2)) -> + let h = compare p1 p2 in + if h <> 0 then h else String.compare s1 s2 + | (Papply(fun1, arg1), Papply(fun2, arg2)) -> + let h = compare fun1 fun2 in + if h <> 0 then h else compare arg1 arg2 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let h = compare_extra t1 t2 in + if h <> 0 then h else compare p1 p2 + | (Pident _, (Pdot _ | Papply _ | Pextra_ty _)) + | (Pdot _, (Papply _ | Pextra_ty _)) + | (Papply _, Pextra_ty _) + -> -1 + | ((Pextra_ty _ | Papply _ | Pdot _), Pident _) + | ((Pextra_ty _ | Papply _) , Pdot _) + | (Pextra_ty _, Papply _) + -> 1 +and compare_extra t1 t2 = + match (t1, t2) with + Pcstr_ty s1, Pcstr_ty s2 -> String.compare s1 s2 + | (Pext_ty, Pext_ty) + -> 0 + | (Pcstr_ty _, Pext_ty) + -> -1 + | (Pext_ty, Pcstr_ty _) + -> 1 + +let rec find_free_opt ids = function + Pident id -> List.find_opt (Ident.same id) ids + | Pdot(p, _) | Pextra_ty (p, _) -> find_free_opt ids p + | Papply(p1, p2) -> begin + match find_free_opt ids p1 with + | None -> find_free_opt ids p2 + | Some _ as res -> res + end + +let exists_free ids p = + match find_free_opt ids p with + | None -> false + | _ -> true + +let rec scope = function + Pident id -> Ident.scope id + | Pdot(p, _) | Pextra_ty (p, _) -> scope p + | Papply(p1, p2) -> Int.max (scope p1) (scope p2) + +let kfalse _ = false + +let maybe_escape s = + if Lexer.is_keyword s then "\\#" ^ s else s + +let rec name ?(paren=kfalse) = function + Pident id -> maybe_escape (Ident.name id) + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + let s = maybe_escape s in + name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s + | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" + | Pextra_ty (p, Pext_ty) -> name ~paren p + +let rec print ppf = function + | Pident id -> Ident.print_with_scope ppf id + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + Format_doc.fprintf ppf "%a.%s" print p s + | Papply(p1, p2) -> Format_doc.fprintf ppf "%a(%a)" print p1 print p2 + | Pextra_ty (p, Pext_ty) -> print ppf p + +let rec head = function + Pident id -> id + | Pdot(p, _) | Pextra_ty (p, _) -> head p + | Papply _ -> assert false + +let flatten = + let rec flatten acc = function + | Pident id -> `Ok (id, acc) + | Pdot (p, s) | Pextra_ty (p, Pcstr_ty s) -> flatten (s :: acc) p + | Papply _ -> `Contains_apply + | Pextra_ty (p, Pext_ty) -> flatten acc p + in + fun t -> flatten [] t + +let heads p = + let rec heads p acc = match p with + | Pident id -> id :: acc + | Pdot (p, _) | Pextra_ty (p, _) -> heads p acc + | Papply(p1, p2) -> + heads p1 (heads p2 acc) + in heads p [] + +let rec last = function + | Pident id -> Ident.name id + | Pdot(_, s) | Pextra_ty (_, Pcstr_ty s) -> s + | Papply(_, p) | Pextra_ty (p, Pext_ty) -> last p + +let is_constructor_typath p = + match p with + | Pident _ | Pdot _ | Papply _ -> false + | Pextra_ty _ -> true + +module T = struct + type nonrec t = t + let compare = compare +end +module Set = Set.Make(T) +module Map = Map.Make(T) diff --git a/upstream/ocaml_503/typing/path.mli b/upstream/ocaml_503/typing/path.mli new file mode 100644 index 000000000..034be0042 --- /dev/null +++ b/upstream/ocaml_503/typing/path.mli @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Access paths *) + +type t = + | Pident of Ident.t + (** Examples: x, List, int *) + | Pdot of t * string + (** Examples: List.map, Float.Array *) + | Papply of t * t + (** Examples: Set.Make(Int), Map.Make(Set.Make(Int)) *) + | Pextra_ty of t * extra_ty + (** [Pextra_ty (p, extra)] are additional paths of types + introduced by specific OCaml constructs. See below. + *) +and extra_ty = + | Pcstr_ty of string + (** [Pextra_ty (p, Pcstr_ty c)] is the type of the inline record for + constructor [c] inside type [p]. + + For example, in + {[ + type 'a t = Nil | Cons of {hd : 'a; tl : 'a t} + ]} + + The inline record type [{hd : 'a; tl : 'a t}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `t`, Pcstr_ty "Cons")]. + *) + | Pext_ty + (** [Pextra_ty (p, Pext_ty)] is the type of the inline record for + the extension constructor [p]. + + For example, in + {[ + type exn += Error of {loc : loc; msg : string} + ]} + + The inline record type [{loc : loc; msg : string}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `Error`, Pext_ty)]. + *) + +val same: t -> t -> bool +val compare: t -> t -> int +val compare_extra: extra_ty -> extra_ty -> int +val find_free_opt: Ident.t list -> t -> Ident.t option +val exists_free: Ident.t list -> t -> bool +val scope: t -> int +val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ] + +val name: ?paren:(string -> bool) -> t -> string + (* [paren] tells whether a path suffix needs parentheses *) +val head: t -> Ident.t + +val print: t Format_doc.printer + +val heads: t -> Ident.t list + +val last: t -> string + +val is_constructor_typath: t -> bool + +module Map : Map.S with type key = t +module Set : Set.S with type elt = t diff --git a/upstream/ocaml_503/typing/patterns.ml b/upstream/ocaml_503/typing/patterns.ml new file mode 100644 index 000000000..456f8dff3 --- /dev/null +++ b/upstream/ocaml_503/typing/patterns.ml @@ -0,0 +1,254 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Partout, INRIA Paris-Saclay *) +(* Thomas Refis, Jane Street Europe *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Types +open Typedtree + +(* useful pattern auxiliary functions *) + +let omega = { + pat_desc = Tpat_any; + pat_loc = Location.none; + pat_extra = []; + pat_type = Ctype.none; + pat_env = Env.empty; + pat_attributes = []; +} + +let rec omegas i = + if i <= 0 then [] else omega :: omegas (i-1) + +let omega_list l = List.map (fun _ -> omega) l + +module Non_empty_row = struct + type 'a t = 'a * Typedtree.pattern list + + let of_initial = function + | [] -> assert false + | pat :: patl -> (pat, patl) + + let map_first f (p, patl) = (f p, patl) +end + +(* "views" on patterns are polymorphic variants + that allow to restrict the set of pattern constructors + statically allowed at a particular place *) + +module Simple = struct + type view = [ + | `Any + | `Constant of constant + | `Tuple of pattern list + | `Construct of + Longident.t loc * constructor_description * pattern list + | `Variant of label * pattern option * row_desc ref + | `Record of + (Longident.t loc * label_description * pattern) list * closed_flag + | `Array of pattern list + | `Lazy of pattern + ] + + type pattern = view pattern_data + + let omega = { omega with pat_desc = `Any } +end + +module Half_simple = struct + type view = [ + | Simple.view + | `Or of pattern * pattern * row_desc option + ] + + type pattern = view pattern_data +end + +module General = struct + type view = [ + | Half_simple.view + | `Var of Ident.t * string loc * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t + ] + type pattern = view pattern_data + + let view_desc = function + | Tpat_any -> + `Any + | Tpat_var (id, str, uid) -> + `Var (id, str, uid) + | Tpat_alias (p, id, str, uid) -> + `Alias (p, id, str, uid) + | Tpat_constant cst -> + `Constant cst + | Tpat_tuple ps -> + `Tuple ps + | Tpat_construct (cstr, cstr_descr, args, _) -> + `Construct (cstr, cstr_descr, args) + | Tpat_variant (cstr, arg, row_desc) -> + `Variant (cstr, arg, row_desc) + | Tpat_record (fields, closed) -> + `Record (fields, closed) + | Tpat_array ps -> `Array ps + | Tpat_or (p, q, row_desc) -> `Or (p, q, row_desc) + | Tpat_lazy p -> `Lazy p + + let view p : pattern = + { p with pat_desc = view_desc p.pat_desc } + + let erase_desc = function + | `Any -> Tpat_any + | `Var (id, str, uid) -> Tpat_var (id, str, uid) + | `Alias (p, id, str, uid) -> Tpat_alias (p, id, str, uid) + | `Constant cst -> Tpat_constant cst + | `Tuple ps -> Tpat_tuple ps + | `Construct (cstr, cst_descr, args) -> + Tpat_construct (cstr, cst_descr, args, None) + | `Variant (cstr, arg, row_desc) -> + Tpat_variant (cstr, arg, row_desc) + | `Record (fields, closed) -> + Tpat_record (fields, closed) + | `Array ps -> Tpat_array ps + | `Or (p, q, row_desc) -> Tpat_or (p, q, row_desc) + | `Lazy p -> Tpat_lazy p + + let erase p : Typedtree.pattern = + { p with pat_desc = erase_desc p.pat_desc } + + let rec strip_vars (p : pattern) : Half_simple.pattern = + match p.pat_desc with + | `Alias (p, _, _, _) -> strip_vars (view p) + | `Var _ -> { p with pat_desc = `Any } + | #Half_simple.view as view -> { p with pat_desc = view } +end + +(* the head constructor of a simple pattern *) + +module Head : sig + type desc = + | Any + | Construct of constructor_description + | Constant of constant + | Tuple of int + | Record of label_description list + | Variant of + { tag: label; has_arg: bool; + cstr_row: row_desc ref; + type_row : unit -> row_desc; } + | Array of int + | Lazy + + type t = desc pattern_data + + val arity : t -> int + + (** [deconstruct p] returns the head of [p] and the list of sub patterns. *) + val deconstruct : Simple.pattern -> t * pattern list + + (** reconstructs a pattern, putting wildcards as sub-patterns. *) + val to_omega_pattern : t -> pattern + + val omega : t +end = struct + type desc = + | Any + | Construct of constructor_description + | Constant of constant + | Tuple of int + | Record of label_description list + | Variant of + { tag: label; has_arg: bool; + cstr_row: row_desc ref; + type_row : unit -> row_desc; } + (* the row of the type may evolve if [close_variant] is called, + hence the (unit -> ...) delay *) + | Array of int + | Lazy + + type t = desc pattern_data + + let deconstruct (q : Simple.pattern) = + let deconstruct_desc = function + | `Any -> Any, [] + | `Constant c -> Constant c, [] + | `Tuple args -> + Tuple (List.length args), args + | `Construct (_, c, args) -> + Construct c, args + | `Variant (tag, arg, cstr_row) -> + let has_arg, pats = + match arg with + | None -> false, [] + | Some a -> true, [a] + in + let type_row () = + match get_desc (Ctype.expand_head q.pat_env q.pat_type) with + | Tvariant type_row -> type_row + | _ -> assert false + in + Variant {tag; has_arg; cstr_row; type_row}, pats + | `Array args -> + Array (List.length args), args + | `Record (largs, _) -> + let lbls = List.map (fun (_,lbl,_) -> lbl) largs in + let pats = List.map (fun (_,_,pat) -> pat) largs in + Record lbls, pats + | `Lazy p -> + Lazy, [p] + in + let desc, pats = deconstruct_desc q.pat_desc in + { q with pat_desc = desc }, pats + + let arity t = + match t.pat_desc with + | Any -> 0 + | Constant _ -> 0 + | Construct c -> c.cstr_arity + | Tuple n | Array n -> n + | Record l -> List.length l + | Variant { has_arg; _ } -> if has_arg then 1 else 0 + | Lazy -> 1 + + let to_omega_pattern t = + let pat_desc = + let mkloc x = Location.mkloc x t.pat_loc in + match t.pat_desc with + | Any -> Tpat_any + | Lazy -> Tpat_lazy omega + | Constant c -> Tpat_constant c + | Tuple n -> Tpat_tuple (omegas n) + | Array n -> Tpat_array (omegas n) + | Construct c -> + let lid_loc = mkloc (Longident.Lident c.cstr_name) in + Tpat_construct (lid_loc, c, omegas c.cstr_arity, None) + | Variant { tag; has_arg; cstr_row } -> + let arg_opt = if has_arg then Some omega else None in + Tpat_variant (tag, arg_opt, cstr_row) + | Record lbls -> + let lst = + List.map (fun lbl -> + let lid_loc = mkloc (Longident.Lident lbl.lbl_name) in + (lid_loc, lbl, omega) + ) lbls + in + Tpat_record (lst, Closed) + in + { t with + pat_desc; + pat_extra = []; + } + + let omega = { omega with pat_desc = Any } +end diff --git a/upstream/ocaml_503/typing/patterns.mli b/upstream/ocaml_503/typing/patterns.mli new file mode 100644 index 000000000..2ad645b0d --- /dev/null +++ b/upstream/ocaml_503/typing/patterns.mli @@ -0,0 +1,109 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Partout, INRIA Paris-Saclay *) +(* Thomas Refis, Jane Street Europe *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree +open Types + +val omega : pattern +(** aka. "Tpat_any" or "_" *) + +val omegas : int -> pattern list +(** [List.init (fun _ -> omega)] *) + +val omega_list : 'a list -> pattern list +(** [List.map (fun _ -> omega)] *) + +module Non_empty_row : sig + type 'a t = 'a * Typedtree.pattern list + + val of_initial : Typedtree.pattern list -> Typedtree.pattern t + (** 'assert false' on empty rows *) + + val map_first : ('a -> 'b) -> 'a t -> 'b t +end + +module Simple : sig + type view = [ + | `Any + | `Constant of constant + | `Tuple of pattern list + | `Construct of + Longident.t loc * constructor_description * pattern list + | `Variant of label * pattern option * row_desc ref + | `Record of + (Longident.t loc * label_description * pattern) list * closed_flag + | `Array of pattern list + | `Lazy of pattern + ] + type pattern = view pattern_data + + val omega : [> view ] pattern_data +end + +module Half_simple : sig + type view = [ + | Simple.view + | `Or of pattern * pattern * row_desc option + ] + type pattern = view pattern_data +end + +module General : sig + type view = [ + | Half_simple.view + | `Var of Ident.t * string loc * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t + ] + type pattern = view pattern_data + + val view : Typedtree.pattern -> pattern + val erase : [< view ] pattern_data -> Typedtree.pattern + + val strip_vars : pattern -> Half_simple.pattern +end + +module Head : sig + type desc = + | Any + | Construct of constructor_description + | Constant of constant + | Tuple of int + | Record of label_description list + | Variant of + { tag: label; has_arg: bool; + cstr_row: row_desc ref; + type_row : unit -> row_desc; } + (* the row of the type may evolve if [close_variant] is called, + hence the (unit -> ...) delay *) + | Array of int + | Lazy + + type t = desc pattern_data + + val arity : t -> int + + (** [deconstruct p] returns the head of [p] and the list of sub patterns. + + @raise [Invalid_arg _] if [p] is an or- or an exception-pattern. *) + val deconstruct : Simple.pattern -> t * pattern list + + (** reconstructs a pattern, putting wildcards as sub-patterns. *) + val to_omega_pattern : t -> pattern + + val omega : t + +end diff --git a/upstream/ocaml_503/typing/persistent_env.ml b/upstream/ocaml_503/typing/persistent_env.ml new file mode 100644 index 000000000..bb7052573 --- /dev/null +++ b/upstream/ocaml_503/typing/persistent_env.ml @@ -0,0 +1,384 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Persistent structure descriptions *) + +open Misc +open Cmi_format + +module Consistbl = Consistbl.Make (Misc.Stdlib.String) + +let add_delayed_check_forward = ref (fun _ -> assert false) + +type error = + | Illegal_renaming of modname * modname * filepath + | Inconsistent_import of modname * filepath * filepath + | Need_recursive_types of modname + +exception Error of error +let error err = raise (Error err) + +module Persistent_signature = struct + type t = + { filename : string; + cmi : Cmi_format.cmi_infos; + visibility : Load_path.visibility } + + let load = ref (fun ~allow_hidden ~unit_name -> + match Load_path.find_normalized_with_visibility (unit_name ^ ".cmi") with + | filename, visibility when allow_hidden -> + Some { filename; cmi = read_cmi filename; visibility} + | filename, Visible -> + Some { filename; cmi = read_cmi filename; visibility = Visible} + | _, Hidden + | exception Not_found -> None) +end + +type can_load_cmis = + | Can_load_cmis + | Cannot_load_cmis of Lazy_backtrack.log + +type pers_struct = { + ps_name: string; + ps_crcs: (string * Digest.t option) list; + ps_filename: string; + ps_flags: pers_flags list; + ps_visibility: Load_path.visibility; +} + +module String = Misc.Stdlib.String + +(* If a .cmi file is missing (or invalid), we + store it as Missing in the cache. *) +type 'a pers_struct_info = + | Missing + | Found of pers_struct * 'a + +type 'a t = { + persistent_structures : (string, 'a pers_struct_info) Hashtbl.t; + imported_units: String.Set.t ref; + imported_opaque_units: String.Set.t ref; + crc_units: Consistbl.t; + can_load_cmis: can_load_cmis ref; +} + +let empty () = { + persistent_structures = Hashtbl.create 17; + imported_units = ref String.Set.empty; + imported_opaque_units = ref String.Set.empty; + crc_units = Consistbl.create (); + can_load_cmis = ref Can_load_cmis; +} + +let clear penv = + let { + persistent_structures; + imported_units; + imported_opaque_units; + crc_units; + can_load_cmis; + } = penv in + Hashtbl.clear persistent_structures; + imported_units := String.Set.empty; + imported_opaque_units := String.Set.empty; + Consistbl.clear crc_units; + can_load_cmis := Can_load_cmis; + () + +let clear_missing {persistent_structures; _} = + let missing_entries = + Hashtbl.fold + (fun name r acc -> if r = Missing then name :: acc else acc) + persistent_structures [] + in + List.iter (Hashtbl.remove persistent_structures) missing_entries + +let add_import {imported_units; _} s = + imported_units := String.Set.add s !imported_units + +let register_import_as_opaque {imported_opaque_units; _} s = + imported_opaque_units := String.Set.add s !imported_opaque_units + +let find_in_cache {persistent_structures; _} s = + match Hashtbl.find persistent_structures s with + | exception Not_found -> None + | Missing -> None + | Found (_ps, pm) -> Some pm + +let import_crcs penv ~source crcs = + let {crc_units; _} = penv in + let import_crc (name, crco) = + match crco with + | None -> () + | Some crc -> + add_import penv name; + Consistbl.check crc_units name crc source + in List.iter import_crc crcs + +let check_consistency penv ps = + try import_crcs penv ~source:ps.ps_filename ps.ps_crcs + with Consistbl.Inconsistency { + unit_name = name; + inconsistent_source = source; + original_source = auth; + } -> + error (Inconsistent_import(name, auth, source)) + +let can_load_cmis penv = + !(penv.can_load_cmis) +let set_can_load_cmis penv setting = + penv.can_load_cmis := setting + +let without_cmis penv f x = + let log = Lazy_backtrack.log () in + let res = + Misc.(protect_refs + [R (penv.can_load_cmis, Cannot_load_cmis log)] + (fun () -> f x)) + in + Lazy_backtrack.backtrack log; + res + +let fold {persistent_structures; _} f x = + Hashtbl.fold (fun modname pso x -> match pso with + | Missing -> x + | Found (_, pm) -> f modname pm x) + persistent_structures x + +(* Reading persistent structures from .cmi files *) + +let save_pers_struct penv crc ps pm = + let {persistent_structures; crc_units; _} = penv in + let modname = ps.ps_name in + Hashtbl.add persistent_structures modname (Found (ps, pm)); + List.iter + (function + | Rectypes -> () + | Alerts _ -> () + | Opaque -> register_import_as_opaque penv modname) + ps.ps_flags; + Consistbl.check crc_units modname crc ps.ps_filename; + add_import penv modname + +let acknowledge_pers_struct penv check modname pers_sig pm = + let { Persistent_signature.filename; cmi; visibility } = pers_sig in + let name = cmi.cmi_name in + let crcs = cmi.cmi_crcs in + let flags = cmi.cmi_flags in + let ps = { ps_name = name; + ps_crcs = crcs; + ps_filename = filename; + ps_flags = flags; + ps_visibility = visibility; + } in + if ps.ps_name <> modname then + error (Illegal_renaming(modname, ps.ps_name, filename)); + List.iter + (function + | Rectypes -> + if not !Clflags.recursive_types then + error (Need_recursive_types(ps.ps_name)) + | Alerts _ -> () + | Opaque -> register_import_as_opaque penv modname) + ps.ps_flags; + if check then check_consistency penv ps; + let {persistent_structures; _} = penv in + Hashtbl.add persistent_structures modname (Found (ps, pm)); + ps + +let read_pers_struct penv val_of_pers_sig check cmi = + let modname = Unit_info.Artifact.modname cmi in + let filename = Unit_info.Artifact.filename cmi in + add_import penv modname; + let cmi = read_cmi filename in + let pers_sig = { Persistent_signature.filename; cmi; visibility = Visible } in + let pm = val_of_pers_sig pers_sig in + let ps = acknowledge_pers_struct penv check modname pers_sig pm in + (ps, pm) + +let find_pers_struct ~allow_hidden penv val_of_pers_sig check name = + let {persistent_structures; _} = penv in + if name = "*predef*" then raise Not_found; + match Hashtbl.find persistent_structures name with + | Found (ps, pm) when allow_hidden || ps.ps_visibility = Load_path.Visible -> + (ps, pm) + | Found _ -> raise Not_found + | Missing -> raise Not_found + | exception Not_found -> + match can_load_cmis penv with + | Cannot_load_cmis _ -> raise Not_found + | Can_load_cmis -> + let psig = + match !Persistent_signature.load ~allow_hidden ~unit_name:name with + | Some psig -> psig + | None -> + if allow_hidden then Hashtbl.add persistent_structures name Missing; + raise Not_found + in + add_import penv name; + let pm = val_of_pers_sig psig in + let ps = acknowledge_pers_struct penv check name psig pm in + (ps, pm) + +module Style = Misc.Style +(* Emits a warning if there is no valid cmi for name *) +let check_pers_struct ~allow_hidden penv f ~loc name = + try + ignore (find_pers_struct ~allow_hidden penv f false name) + with + | Not_found -> + let warn = Warnings.No_cmi_file(name, None) in + Location.prerr_warning loc warn + | Cmi_format.Error err -> + let msg = Format.asprintf "%a" + Cmi_format.report_error err in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + | Error err -> + let msg = + match err with + | Illegal_renaming(name, ps_name, filename) -> + Format_doc.doc_printf + " %a@ contains the compiled interface for @ \ + %a when %a was expected" + Location.Doc.quoted_filename filename + Style.inline_code ps_name + Style.inline_code name + | Inconsistent_import _ -> assert false + | Need_recursive_types name -> + Format_doc.doc_printf + "%a uses recursive types" + Style.inline_code name + in + let msg = Format_doc.(asprintf "%a" pp_doc) msg in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + +let read penv f a = + snd (read_pers_struct penv f true a) + +let find ~allow_hidden penv f name = + snd (find_pers_struct ~allow_hidden penv f true name) + +let check ~allow_hidden penv f ~loc name = + let {persistent_structures; _} = penv in + if not (Hashtbl.mem persistent_structures name) then begin + (* PR#6843: record the weak dependency ([add_import]) regardless of + whether the check succeeds, to help make builds more + deterministic. *) + add_import penv name; + if (Warnings.is_active (Warnings.No_cmi_file("", None))) then + !add_delayed_check_forward + (fun () -> check_pers_struct ~allow_hidden penv f ~loc name) + end + +let crc_of_unit penv f name = + let (ps, _pm) = find_pers_struct ~allow_hidden:true penv f true name in + let crco = + try + List.assoc name ps.ps_crcs + with Not_found -> + assert false + in + match crco with + None -> assert false + | Some crc -> crc + +let imports {imported_units; crc_units; _} = + Consistbl.extract (String.Set.elements !imported_units) crc_units + +let looked_up {persistent_structures; _} modname = + Hashtbl.mem persistent_structures modname + +let is_imported {imported_units; _} s = + String.Set.mem s !imported_units + +let is_imported_opaque {imported_opaque_units; _} s = + String.Set.mem s !imported_opaque_units + +let make_cmi penv modname sign alerts = + let flags = + List.concat [ + if !Clflags.recursive_types then [Cmi_format.Rectypes] else []; + if !Clflags.opaque then [Cmi_format.Opaque] else []; + [Alerts alerts]; + ] + in + let crcs = imports penv in + { + cmi_name = modname; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags + } + +let save_cmi penv psig pm = + let { Persistent_signature.filename; cmi; visibility } = psig in + Misc.try_finally (fun () -> + let { + cmi_name = modname; + cmi_sign = _; + cmi_crcs = imports; + cmi_flags = flags; + } = cmi in + let crc = + output_to_file_via_temporary (* see MPR#7472, MPR#4991 *) + ~mode: [Open_binary] filename + (fun temp_filename oc -> output_cmi temp_filename oc cmi) in + (* Enter signature in persistent table so that imports() + will also return its crc *) + let ps = + { ps_name = modname; + ps_crcs = (cmi.cmi_name, Some crc) :: imports; + ps_filename = filename; + ps_flags = flags; + ps_visibility = visibility + } in + save_pers_struct penv crc ps pm + ) + ~exceptionally:(fun () -> remove_file filename) + +let report_error_doc ppf = + let open Format_doc in + function + | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf + "Wrong file naming: %a@ contains the compiled interface for@ \ + %a when %a was expected" + Location.Doc.quoted_filename filename + Style.inline_code ps_name + Style.inline_code modname + | Inconsistent_import(name, source1, source2) -> fprintf ppf + "@[The files %a@ and %a@ \ + make inconsistent assumptions@ over interface %a@]" + Location.Doc.quoted_filename source1 + Location.Doc.quoted_filename source2 + Style.inline_code name + | Need_recursive_types(import) -> + fprintf ppf + "@[Invalid import of %a, which uses recursive types.@ \ + The compilation flag %a is required@]" + Style.inline_code import + Style.inline_code "-rectypes" + +let () = + Location.register_error_of_exn + (function + | Error err -> + Some (Location.error_of_printer_file report_error_doc err) + | _ -> None + ) + +let report_error = Format_doc.compat report_error_doc diff --git a/upstream/ocaml_503/typing/persistent_env.mli b/upstream/ocaml_503/typing/persistent_env.mli new file mode 100644 index 000000000..6cbdfc81c --- /dev/null +++ b/upstream/ocaml_503/typing/persistent_env.mli @@ -0,0 +1,106 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +module Consistbl : module type of struct + include Consistbl.Make (Misc.Stdlib.String) +end + +type error = + | Illegal_renaming of modname * modname * filepath + | Inconsistent_import of modname * filepath * filepath + | Need_recursive_types of modname + +exception Error of error + +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer + +module Persistent_signature : sig + type t = + { filename : string; (** Name of the file containing the signature. *) + cmi : Cmi_format.cmi_infos; + visibility : Load_path.visibility + } + + (** Function used to load a persistent signature. The default is to look for + the .cmi file in the load path. This function can be overridden to load + it from memory, for instance to build a self-contained toplevel. *) + val load : (allow_hidden:bool -> unit_name:string -> t option) ref +end + +type can_load_cmis = + | Can_load_cmis + | Cannot_load_cmis of Lazy_backtrack.log + +type 'a t + +val empty : unit -> 'a t + +val clear : 'a t -> unit +val clear_missing : 'a t -> unit + +val fold : 'a t -> (modname -> 'a -> 'b -> 'b) -> 'b -> 'b + +val read : 'a t -> (Persistent_signature.t -> 'a) -> Unit_info.Artifact.t -> 'a +val find : allow_hidden:bool -> 'a t -> (Persistent_signature.t -> 'a) + -> modname -> 'a + +val find_in_cache : 'a t -> modname -> 'a option + +val check : allow_hidden:bool -> 'a t -> (Persistent_signature.t -> 'a) + -> loc:Location.t -> modname -> unit + +(* [looked_up penv md] checks if one has already tried + to read the signature for [md] in the environment + [penv] (it may have failed) *) +val looked_up : 'a t -> modname -> bool + +(* [is_imported penv md] checks if [md] has been successfully + imported in the environment [penv] *) +val is_imported : 'a t -> modname -> bool + +(* [is_imported_opaque penv md] checks if [md] has been imported + in [penv] as an opaque module *) +val is_imported_opaque : 'a t -> modname -> bool + +(* [register_import_as_opaque penv md] registers [md] in [penv] as an + opaque module *) +val register_import_as_opaque : 'a t -> modname -> unit + +val make_cmi : 'a t -> modname -> Types.signature -> alerts + -> Cmi_format.cmi_infos + +val save_cmi : 'a t -> Persistent_signature.t -> 'a -> unit + +val can_load_cmis : 'a t -> can_load_cmis +val set_can_load_cmis : 'a t -> can_load_cmis -> unit +val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c +(* [without_cmis penv f arg] applies [f] to [arg], but does not + allow [penv] to openi cmis during its execution *) + +(* may raise Consistbl.Inconsistency *) +val import_crcs : 'a t -> source:filepath -> crcs -> unit + +(* Return the set of compilation units imported, with their CRC *) +val imports : 'a t -> crcs + +(* Return the CRC of the interface of the given compilation unit *) +val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) -> modname -> Digest.t + +(* Forward declaration to break mutual recursion with Typecore. *) +val add_delayed_check_forward: ((unit -> unit) -> unit) ref diff --git a/upstream/ocaml_503/typing/predef.ml b/upstream/ocaml_503/typing/predef.ml new file mode 100644 index 000000000..e7b24bd8f --- /dev/null +++ b/upstream/ocaml_503/typing/predef.ml @@ -0,0 +1,290 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Predefined type constructors (with special typing rules in typecore) *) + +open Path +open Types +open Btype + +let builtin_idents = ref [] + +let wrap create s = + let id = create s in + builtin_idents := (s, id) :: !builtin_idents; + id + +let ident_create = wrap Ident.create_predef + +let ident_int = ident_create "int" +and ident_char = ident_create "char" +and ident_bytes = ident_create "bytes" +and ident_float = ident_create "float" +and ident_bool = ident_create "bool" +and ident_unit = ident_create "unit" +and ident_exn = ident_create "exn" +and ident_eff = ident_create "eff" +and ident_continuation = ident_create "continuation" +and ident_array = ident_create "array" +and ident_list = ident_create "list" +and ident_option = ident_create "option" +and ident_nativeint = ident_create "nativeint" +and ident_int32 = ident_create "int32" +and ident_int64 = ident_create "int64" +and ident_lazy_t = ident_create "lazy_t" +and ident_string = ident_create "string" +and ident_extension_constructor = ident_create "extension_constructor" +and ident_floatarray = ident_create "floatarray" + +let path_int = Pident ident_int +and path_char = Pident ident_char +and path_bytes = Pident ident_bytes +and path_float = Pident ident_float +and path_bool = Pident ident_bool +and path_unit = Pident ident_unit +and path_exn = Pident ident_exn +and path_eff = Pident ident_eff +and path_continuation = Pident ident_continuation +and path_array = Pident ident_array +and path_list = Pident ident_list +and path_option = Pident ident_option +and path_nativeint = Pident ident_nativeint +and path_int32 = Pident ident_int32 +and path_int64 = Pident ident_int64 +and path_lazy_t = Pident ident_lazy_t +and path_string = Pident ident_string +and path_extension_constructor = Pident ident_extension_constructor +and path_floatarray = Pident ident_floatarray + +let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) +and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) +and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil)) +and type_float = newgenty (Tconstr(path_float, [], ref Mnil)) +and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil)) +and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil)) +and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) +and type_eff t = newgenty (Tconstr(path_eff, [t], ref Mnil)) +and type_continuation t1 t2 = + newgenty (Tconstr(path_continuation, [t1; t2], ref Mnil)) +and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) +and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) +and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) +and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil)) +and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil)) +and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) +and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) +and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) +and type_extension_constructor = + newgenty (Tconstr(path_extension_constructor, [], ref Mnil)) +and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil)) + +let ident_match_failure = ident_create "Match_failure" +and ident_out_of_memory = ident_create "Out_of_memory" +and ident_invalid_argument = ident_create "Invalid_argument" +and ident_failure = ident_create "Failure" +and ident_not_found = ident_create "Not_found" +and ident_sys_error = ident_create "Sys_error" +and ident_end_of_file = ident_create "End_of_file" +and ident_division_by_zero = ident_create "Division_by_zero" +and ident_stack_overflow = ident_create "Stack_overflow" +and ident_sys_blocked_io = ident_create "Sys_blocked_io" +and ident_assert_failure = ident_create "Assert_failure" +and ident_undefined_recursive_module = + ident_create "Undefined_recursive_module" +and ident_continuation_already_taken = ident_create "Continuation_already_taken" + + +let all_predef_exns = [ + ident_match_failure; + ident_out_of_memory; + ident_invalid_argument; + ident_failure; + ident_not_found; + ident_sys_error; + ident_end_of_file; + ident_division_by_zero; + ident_stack_overflow; + ident_sys_blocked_io; + ident_assert_failure; + ident_undefined_recursive_module; + ident_continuation_already_taken; +] + +let path_match_failure = Pident ident_match_failure +and path_assert_failure = Pident ident_assert_failure +and path_undefined_recursive_module = Pident ident_undefined_recursive_module + +let cstr id args = + { + cd_id = id; + cd_args = Cstr_tuple args; + cd_res = None; + cd_loc = Location.none; + cd_attributes = []; + cd_uid = Uid.of_predef_id id; + } + +let ident_false = ident_create "false" +and ident_true = ident_create "true" +and ident_void = ident_create "()" +and ident_nil = ident_create "[]" +and ident_cons = ident_create "::" +and ident_none = ident_create "None" +and ident_some = ident_create "Some" + +let mk_add_type add_type type_ident ?manifest + ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract Definition) env = + let decl = + {type_params = []; + type_arity = 0; + type_kind = kind; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = manifest; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_immediate = immediate; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env + +let build_initial_env add_type add_extension empty_env = + let add_type = mk_add_type add_type + and add_type1 type_ident + ~variance ~separability ?(kind=fun _ -> Type_abstract Definition) env = + let param = newgenvar () in + let decl = + {type_params = [param]; + type_arity = 1; + type_kind = kind param; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = [variance]; + type_separability = [separability]; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env + and add_continuation type_ident env = + let tvar1 = newgenvar() in + let tvar2 = newgenvar() in + let arity = 2 in + let decl = + {type_params = [tvar1; tvar2]; + type_arity = arity; + type_kind = Type_abstract Definition; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = [Variance.contravariant; Variance.covariant]; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env + in + let add_extension id l = + add_extension id + { ext_type_path = path_exn; + ext_type_params = []; + ext_args = Cstr_tuple l; + ext_ret_type = None; + ext_private = Asttypes.Public; + ext_loc = Location.none; + ext_attributes = [Ast_helper.Attr.mk + (Location.mknoloc "ocaml.warn_on_literal_pattern") + (Parsetree.PStr [])]; + ext_uid = Uid.of_predef_id id; + } + in + let variant constrs = Type_variant (constrs, Variant_regular) in + empty_env + (* Predefined types - alphabetical order *) + |> add_type1 ident_array + ~variance:Variance.full + ~separability:Separability.Ind + |> add_type ident_bool + ~immediate:Always + ~kind:(variant [cstr ident_false []; cstr ident_true []]) + |> add_type ident_char ~immediate:Always + |> add_type ident_exn ~kind:Type_open + |> add_type1 ident_eff + ~variance:Variance.full + ~separability:Separability.Ind + ~kind:(fun _ -> Type_open) + |> add_continuation ident_continuation + |> add_type ident_extension_constructor + |> add_type ident_float + |> add_type ident_floatarray + |> add_type ident_int ~immediate:Always + |> add_type ident_int32 + |> add_type ident_int64 + |> add_type1 ident_lazy_t + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type1 ident_list + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]) + |> add_type ident_nativeint + |> add_type1 ident_option + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_none []; cstr ident_some [tvar]]) + |> add_type ident_string + |> add_type ident_bytes + |> add_type ident_unit + ~immediate:Always + ~kind:(variant [cstr ident_void []]) + (* Predefined exceptions - alphabetical order *) + |> add_extension ident_assert_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_division_by_zero [] + |> add_extension ident_end_of_file [] + |> add_extension ident_failure [type_string] + |> add_extension ident_invalid_argument [type_string] + |> add_extension ident_match_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_not_found [] + |> add_extension ident_out_of_memory [] + |> add_extension ident_stack_overflow [] + |> add_extension ident_sys_blocked_io [] + |> add_extension ident_sys_error [type_string] + |> add_extension ident_undefined_recursive_module + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_continuation_already_taken [] + +let builtin_values = + List.map (fun id -> (Ident.name id, id)) all_predef_exns + +let builtin_idents = List.rev !builtin_idents diff --git a/upstream/ocaml_503/typing/predef.mli b/upstream/ocaml_503/typing/predef.mli new file mode 100644 index 000000000..465351433 --- /dev/null +++ b/upstream/ocaml_503/typing/predef.mli @@ -0,0 +1,91 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Predefined type constructors (with special typing rules in typecore) *) + +open Types + +val type_int: type_expr +val type_char: type_expr +val type_string: type_expr +val type_bytes: type_expr +val type_float: type_expr +val type_bool: type_expr +val type_unit: type_expr +val type_exn: type_expr +val type_eff: type_expr -> type_expr +val type_continuation: type_expr -> type_expr -> type_expr +val type_array: type_expr -> type_expr +val type_list: type_expr -> type_expr +val type_option: type_expr -> type_expr +val type_nativeint: type_expr +val type_int32: type_expr +val type_int64: type_expr +val type_lazy_t: type_expr -> type_expr +val type_extension_constructor:type_expr +val type_floatarray:type_expr + +val path_int: Path.t +val path_char: Path.t +val path_string: Path.t +val path_bytes: Path.t +val path_float: Path.t +val path_bool: Path.t +val path_unit: Path.t +val path_exn: Path.t +val path_eff: Path.t +val path_array: Path.t +val path_list: Path.t +val path_option: Path.t +val path_nativeint: Path.t +val path_int32: Path.t +val path_int64: Path.t +val path_lazy_t: Path.t +val path_extension_constructor: Path.t +val path_floatarray: Path.t +val path_continuation: Path.t + +val path_match_failure: Path.t +val path_assert_failure : Path.t +val path_undefined_recursive_module : Path.t + +val ident_false : Ident.t +val ident_true : Ident.t +val ident_void : Ident.t +val ident_nil : Ident.t +val ident_cons : Ident.t +val ident_none : Ident.t +val ident_some : Ident.t + +(* To build the initial environment. Since there is a nasty mutual + recursion between predef and env, we break it by parameterizing + over Env.t, Env.add_type and Env.add_extension. *) + +val build_initial_env: + (Ident.t -> type_declaration -> 'a -> 'a) -> + (Ident.t -> extension_constructor -> 'a -> 'a) -> + 'a -> 'a + +(* To initialize linker tables *) + +val builtin_values: (string * Ident.t) list +val builtin_idents: (string * Ident.t) list + +(** All predefined exceptions, exposed as [Ident.t] for flambda (for + building value approximations). + The [Ident.t] for division by zero is also exported explicitly + so flambda can generate code to raise it. *) +val ident_division_by_zero: Ident.t +val all_predef_exns : Ident.t list diff --git a/upstream/ocaml_503/typing/primitive.ml b/upstream/ocaml_503/typing/primitive.ml new file mode 100644 index 000000000..a0cb5d712 --- /dev/null +++ b/upstream/ocaml_503/typing/primitive.ml @@ -0,0 +1,257 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Description of primitive functions *) + +open Misc +open Parsetree + +type boxed_integer = Pnativeint | Pint32 | Pint64 + +type native_repr = + | Same_as_ocaml_repr + | Unboxed_float + | Unboxed_integer of boxed_integer + | Untagged_immediate + +type description = + { prim_name: string; (* Name of primitive or C function *) + prim_arity: int; (* Number of arguments *) + prim_alloc: bool; (* Does it allocates or raise? *) + prim_native_name: string; (* Name of C function for the nat. code gen. *) + prim_native_repr_args: native_repr list; + prim_native_repr_res: native_repr } + +type error = + | Old_style_float_with_native_repr_attribute + | Old_style_noalloc_with_noalloc_attribute + | No_native_primitive_with_repr_attribute + +exception Error of Location.t * error + +let is_ocaml_repr = function + | Same_as_ocaml_repr -> true + | Unboxed_float + | Unboxed_integer _ + | Untagged_immediate -> false + +let is_unboxed = function + | Same_as_ocaml_repr + | Untagged_immediate -> false + | Unboxed_float + | Unboxed_integer _ -> true + +let is_untagged = function + | Untagged_immediate -> true + | Same_as_ocaml_repr + | Unboxed_float + | Unboxed_integer _ -> false + +let rec make_native_repr_args arity x = + if arity = 0 then + [] + else + x :: make_native_repr_args (arity - 1) x + +let simple ~name ~arity ~alloc = + {prim_name = name; + prim_arity = arity; + prim_alloc = alloc; + prim_native_name = ""; + prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr; + prim_native_repr_res = Same_as_ocaml_repr} + +let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res = + {prim_name = name; + prim_arity = List.length native_repr_args; + prim_alloc = alloc; + prim_native_name = native_name; + prim_native_repr_args = native_repr_args; + prim_native_repr_res = native_repr_res} + +let parse_declaration valdecl ~native_repr_args ~native_repr_res = + let arity = List.length native_repr_args in + let name, native_name, old_style_noalloc, old_style_float = + match valdecl.pval_prim with + | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true) + | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false) + | name :: name2 :: "float" :: _ -> (name, name2, false, true) + | name :: "noalloc" :: _ -> (name, "", true, false) + | name :: name2 :: _ -> (name, name2, false, false) + | name :: _ -> (name, "", false, false) + | [] -> + fatal_error "Primitive.parse_declaration" + in + let noalloc_attribute = + Attr_helper.has_no_payload_attribute "noalloc" valdecl.pval_attributes + in + if old_style_float && + not (List.for_all is_ocaml_repr native_repr_args && + is_ocaml_repr native_repr_res) then + raise (Error (valdecl.pval_loc, + Old_style_float_with_native_repr_attribute)); + if old_style_noalloc && noalloc_attribute then + raise (Error (valdecl.pval_loc, + Old_style_noalloc_with_noalloc_attribute)); + (* The compiler used to assume "noalloc" with "float", we just make this + explicit now (GPR#167): *) + let old_style_noalloc = old_style_noalloc || old_style_float in + if old_style_float then + Location.deprecated valdecl.pval_loc + "[@@unboxed] + [@@noalloc] should be used\n\ + instead of \"float\"" + else if old_style_noalloc then + Location.deprecated valdecl.pval_loc + "[@@noalloc] should be used instead of \"noalloc\""; + if native_name = "" && + not (List.for_all is_ocaml_repr native_repr_args && + is_ocaml_repr native_repr_res) then + raise (Error (valdecl.pval_loc, + No_native_primitive_with_repr_attribute)); + let noalloc = old_style_noalloc || noalloc_attribute in + let native_repr_args, native_repr_res = + if old_style_float then + (make_native_repr_args arity Unboxed_float, Unboxed_float) + else + (native_repr_args, native_repr_res) + in + {prim_name = name; + prim_arity = arity; + prim_alloc = not noalloc; + prim_native_name = native_name; + prim_native_repr_args = native_repr_args; + prim_native_repr_res = native_repr_res} + +open Outcometree + +let rec add_native_repr_attributes ty attrs = + match ty, attrs with + | Otyp_arrow (label, a, b), attr_opt :: rest -> + let b = add_native_repr_attributes b rest in + let a = + match attr_opt with + | None -> a + | Some attr -> Otyp_attribute (a, attr) + in + Otyp_arrow (label, a, b) + | _, [Some attr] -> Otyp_attribute (ty, attr) + | _ -> + assert (List.for_all (fun x -> x = None) attrs); + ty + +let oattr_unboxed = { oattr_name = "unboxed" } +let oattr_untagged = { oattr_name = "untagged" } +let oattr_noalloc = { oattr_name = "noalloc" } + +let print p osig_val_decl = + let prims = + if p.prim_native_name <> "" then + [p.prim_name; p.prim_native_name] + else + [p.prim_name] + in + let for_all f = + List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res + in + let all_unboxed = for_all is_unboxed in + let all_untagged = for_all is_untagged in + let attrs = if p.prim_alloc then [] else [oattr_noalloc] in + let attrs = + if all_unboxed then + oattr_unboxed :: attrs + else if all_untagged then + oattr_untagged :: attrs + else + attrs + in + let attr_of_native_repr = function + | Same_as_ocaml_repr -> None + | Unboxed_float + | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed + | Untagged_immediate -> if all_untagged then None else Some oattr_untagged + in + let type_attrs = + List.map attr_of_native_repr p.prim_native_repr_args @ + [attr_of_native_repr p.prim_native_repr_res] + in + { osig_val_decl with + oval_prims = prims; + oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs; + oval_attributes = attrs } + +let native_name p = + if p.prim_native_name <> "" + then p.prim_native_name + else p.prim_name + +let byte_name p = + p.prim_name + +let equal_boxed_integer bi1 bi2 = + match bi1, bi2 with + | Pnativeint, Pnativeint + | Pint32, Pint32 + | Pint64, Pint64 -> + true + | (Pnativeint | Pint32 | Pint64), _ -> + false + +let equal_native_repr nr1 nr2 = + match nr1, nr2 with + | Same_as_ocaml_repr, Same_as_ocaml_repr -> true + | Same_as_ocaml_repr, + (Unboxed_float | Unboxed_integer _ | Untagged_immediate) -> false + | Unboxed_float, Unboxed_float -> true + | Unboxed_float, + (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_immediate) -> false + | Unboxed_integer bi1, Unboxed_integer bi2 -> equal_boxed_integer bi1 bi2 + | Unboxed_integer _, + (Same_as_ocaml_repr | Unboxed_float | Untagged_immediate) -> false + | Untagged_immediate, Untagged_immediate -> true + | Untagged_immediate, + (Same_as_ocaml_repr | Unboxed_float | Unboxed_integer _) -> false + +let native_name_is_external p = + let nat_name = native_name p in + nat_name <> "" && nat_name.[0] <> '%' + +module Style = Misc.Style + +let report_error ppf err = + match err with + | Old_style_float_with_native_repr_attribute -> + Format_doc.fprintf ppf "Cannot use %a in conjunction with %a/%a." + Style.inline_code "float" + Style.inline_code "[@unboxed]" + Style.inline_code "[@untagged]" + | Old_style_noalloc_with_noalloc_attribute -> + Format_doc.fprintf ppf "Cannot use %a in conjunction with %a." + Style.inline_code "noalloc" + Style.inline_code "[@@noalloc]" + | No_native_primitive_with_repr_attribute -> + Format_doc.fprintf ppf + "@[The native code version of the primitive is mandatory@ \ + when attributes %a or %a are present.@]" + Style.inline_code "[@untagged]" + Style.inline_code "[@unboxed]" + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/upstream/ocaml_503/typing/primitive.mli b/upstream/ocaml_503/typing/primitive.mli new file mode 100644 index 000000000..3d3ae8854 --- /dev/null +++ b/upstream/ocaml_503/typing/primitive.mli @@ -0,0 +1,79 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Description of primitive functions *) + +type boxed_integer = Pnativeint | Pint32 | Pint64 + +(* Representation of arguments/result for the native code version + of a primitive *) +type native_repr = + | Same_as_ocaml_repr + | Unboxed_float + | Unboxed_integer of boxed_integer + | Untagged_immediate + +type description = private + { prim_name: string; (* Name of primitive or C function *) + prim_arity: int; (* Number of arguments *) + prim_alloc: bool; (* Does it allocates or raise? *) + prim_native_name: string; (* Name of C function for the nat. code gen. *) + prim_native_repr_args: native_repr list; + prim_native_repr_res: native_repr } + +(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *) + +val simple + : name:string + -> arity:int + -> alloc:bool + -> description + +val make + : name:string + -> alloc:bool + -> native_name:string + -> native_repr_args: native_repr list + -> native_repr_res: native_repr + -> description + +val parse_declaration + : Parsetree.value_description + -> native_repr_args:native_repr list + -> native_repr_res:native_repr + -> description + +val print + : description + -> Outcometree.out_val_decl + -> Outcometree.out_val_decl + +val native_name: description -> string +val byte_name: description -> string + +val equal_boxed_integer : boxed_integer -> boxed_integer -> bool +val equal_native_repr : native_repr -> native_repr -> bool + +(** [native_name_is_externa] returns [true] iff the [native_name] for the + given primitive identifies that the primitive is not implemented in the + compiler itself. *) +val native_name_is_external : description -> bool + +type error = + | Old_style_float_with_native_repr_attribute + | Old_style_noalloc_with_noalloc_attribute + | No_native_primitive_with_repr_attribute + +exception Error of Location.t * error diff --git a/upstream/ocaml_503/typing/printpat.ml b/upstream/ocaml_503/typing/printpat.ml new file mode 100644 index 000000000..d4897294d --- /dev/null +++ b/upstream/ocaml_503/typing/printpat.ml @@ -0,0 +1,173 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Values as patterns pretty printer *) + +open Asttypes +open Typedtree +open Types +open Format_doc + +let is_cons = function +| {cstr_name = "::"} -> true +| _ -> false + +let pretty_const c = match c with +| Const_int i -> Printf.sprintf "%d" i +| Const_char c -> Printf.sprintf "%C" c +| Const_string (s, _, _) -> Printf.sprintf "%S" s +| Const_float f -> Printf.sprintf "%s" f +| Const_int32 i -> Printf.sprintf "%ldl" i +| Const_int64 i -> Printf.sprintf "%LdL" i +| Const_nativeint i -> Printf.sprintf "%ndn" i + +let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest = + match cstr with + | Tpat_unpack -> + fprintf ppf "@[(module %a)@]" pretty_rest rest + | Tpat_constraint _ -> + fprintf ppf "@[(%a : _)@]" pretty_rest rest + | Tpat_type _ -> + fprintf ppf "@[(# %a)@]" pretty_rest rest + | Tpat_open _ -> + fprintf ppf "@[(# %a)@]" pretty_rest rest + +let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> + match v.pat_extra with + | extra :: rem -> + pretty_extra ppf extra + pretty_val { v with pat_extra = rem } + | [] -> + match v.pat_desc with + | Tpat_any -> fprintf ppf "_" + | Tpat_var (x,_,_) -> fprintf ppf "%s" (Ident.name x) + | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) + | Tpat_tuple vs -> + fprintf ppf "@[(%a)@]" (pretty_vals ",") vs + | Tpat_construct (_, cstr, [], _) -> + fprintf ppf "%s" cstr.cstr_name + | Tpat_construct (_, cstr, [w], None) -> + fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w + | Tpat_construct (_, cstr, vs, vto) -> + let name = cstr.cstr_name in + begin match (name, vs, vto) with + ("::", [v1;v2], None) -> + fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 + | (_, _, None) -> + fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs + | (_, _, Some ([], _t)) -> + fprintf ppf "@[<2>%s@ @[(%a : _)@]@]" name (pretty_vals ",") vs + | (_, _, Some (vl, _t)) -> + let vars = List.map (fun x -> Ident.name x.txt) vl in + fprintf ppf "@[<2>%s@ (type %s)@ @[(%a : _)@]@]" + name (String.concat " " vars) (pretty_vals ",") vs + end + | Tpat_variant (l, None, _) -> + fprintf ppf "`%s" l + | Tpat_variant (l, Some w, _) -> + fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w + | Tpat_record (lvs,_) -> + let filtered_lvs = List.filter + (function + | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) + | _ -> true) lvs in + begin match filtered_lvs with + | [] -> fprintf ppf "{ _ }" + | (_, lbl, _) :: q -> + let elision_mark ppf = + (* we assume that there is no label repetitions here *) + if Array.length lbl.lbl_all > 1 + List.length q then + fprintf ppf ";@ _@ " + else () in + fprintf ppf "@[{%a%t}@]" + pretty_lvals filtered_lvs elision_mark + end + | Tpat_array vs -> + fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs + | Tpat_lazy v -> + fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v + | Tpat_alias (v, x,_,_) -> + fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.doc_print x + | Tpat_value v -> + fprintf ppf "%a" pretty_val (v :> pattern) + | Tpat_exception v -> + fprintf ppf "@[<2>exception@ %a@]" pretty_arg v + | Tpat_or _ -> + fprintf ppf "@[(%a)@]" pretty_or v + +and pretty_car ppf v = match v.pat_desc with +| Tpat_construct (_,cstr, [_ ; _], None) + when is_cons cstr -> + fprintf ppf "(%a)" pretty_val v +| _ -> pretty_val ppf v + +and pretty_cdr ppf v = match v.pat_desc with +| Tpat_construct (_,cstr, [v1 ; v2], None) + when is_cons cstr -> + fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 +| _ -> pretty_val ppf v + +and pretty_arg ppf v = match v.pat_desc with +| Tpat_construct (_,_,_::_,None) +| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v +| _ -> pretty_val ppf v + +and pretty_or : type k . _ -> k general_pattern -> _ = fun ppf v -> + match v.pat_desc with + | Tpat_or (v,w,_) -> + fprintf ppf "%a|@,%a" pretty_or v pretty_or w + | _ -> pretty_val ppf v + +and pretty_vals sep ppf = function + | [] -> () + | [v] -> pretty_val ppf v + | v::vs -> + fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs + +and pretty_lvals ppf = function + | [] -> () + | [_,lbl,v] -> + fprintf ppf "%s=%a" lbl.lbl_name pretty_val v + | (_, lbl,v)::rest -> + fprintf ppf "%s=%a;@ %a" + lbl.lbl_name pretty_val v pretty_lvals rest + +let top_pretty ppf v = + fprintf ppf "@[%a@]" pretty_val v + +let pretty_pat ppf p = + top_pretty ppf p ; + pp_print_flush ppf () + +type 'k matrix = 'k general_pattern list list + +let pretty_line ppf line = + fprintf ppf "@["; + List.iter (fun p -> + fprintf ppf "<%a>@ " + pretty_val p + ) line; + fprintf ppf "@]" + +let pretty_matrix ppf (pss : 'k matrix) = + fprintf ppf "@[ %a@]" + (pp_print_list ~pp_sep:pp_print_cut pretty_line) + pss + +module Compat = struct + let pretty_pat ppf x = compat pretty_pat ppf x + let pretty_line ppf x = compat pretty_line ppf x + let pretty_matrix ppf x = compat pretty_matrix ppf x +end diff --git a/upstream/ocaml_503/typing/printpat.mli b/upstream/ocaml_503/typing/printpat.mli new file mode 100644 index 000000000..2d9a93ce6 --- /dev/null +++ b/upstream/ocaml_503/typing/printpat.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + + +val pretty_const + : Asttypes.constant -> string + +val top_pretty: 'k Typedtree.general_pattern Format_doc.printer + +module Compat: sig + val pretty_pat: Format.formatter -> 'k Typedtree.general_pattern -> unit + val pretty_line: Format.formatter -> 'k Typedtree.general_pattern list -> unit + val pretty_matrix: + Format.formatter -> 'k Typedtree.general_pattern list list -> unit +end diff --git a/upstream/ocaml_503/typing/printtyp.ml b/upstream/ocaml_503/typing/printtyp.ml new file mode 100644 index 000000000..649f4b94c --- /dev/null +++ b/upstream/ocaml_503/typing/printtyp.ml @@ -0,0 +1,174 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Out_type +module Fmt = Format_doc + +let namespaced_ident namespace id = + Out_name.print (ident_name (Some namespace) id) + +module Doc = struct + let wrap_printing_env = wrap_printing_env + + let longident = Pprintast.Doc.longident + + let ident ppf id = Fmt.pp_print_string ppf + (Out_name.print (ident_name None id)) + + + + let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + + let type_expansion k ppf e = + pp_type_expansion ppf (trees_of_type_expansion k e) + + let type_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) + + let type_expr ppf ty = + (* [type_expr] is used directly by error message printers, + we mark eventual loops ourself to avoid any misuse and stack overflow *) + prepare_for_printing [ty]; + prepared_type_expr ppf ty + + let shared_type_scheme ppf ty = + add_type_to_preparation ty; + typexp Type_scheme ppf ty + + let type_scheme ppf ty = + prepare_for_printing [ty]; + prepared_type_scheme ppf ty + + let path ppf p = + !Oprint.out_ident ppf (tree_of_path ~disambiguation:false p) + + let () = Env.print_path := path + + let type_path ppf p = !Oprint.out_ident ppf (tree_of_type_path p) + + let value_description id ppf decl = + !Oprint.out_sig_item ppf (tree_of_value_description id decl) + + let class_type ppf cty = + reset (); + prepare_class_type cty; + !Oprint.out_class_type ppf (tree_of_class_type Type cty) + + let class_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) + + let cltype_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) + + let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) + let modtype_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) + + let constructor ppf c = + reset_except_conflicts (); + add_constructor_to_preparation c; + prepared_constructor ppf c + + let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) + + let label ppf l = + prepare_for_printing [l.Types.ld_type]; + !Oprint.out_label ppf (tree_of_label l) + + let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) + + (* Print an extension declaration *) + + + + let extension_only_constructor id ppf (ext:Types.extension_constructor) = + reset_except_conflicts (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter add_type_to_preparation ext.ext_ret_type; + let name = Ident.name id in + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type + in + Fmt.fprintf ppf "@[%a@]" + !Oprint.out_constr { + Outcometree.ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + + (* Print a signature body (used by -i when compiling a .ml) *) + + let print_signature ppf tree = + Fmt.fprintf ppf "@[%a@]" !Oprint.out_signature tree + + let signature ppf sg = + Fmt.fprintf ppf "%a" print_signature (tree_of_signature sg) + +end +open Doc +let string_of_path p = Fmt.asprintf "%a" path p + +let strings_of_paths namespace p = + let trees = List.map (namespaced_tree_of_path namespace) p in + List.map (Fmt.asprintf "%a" !Oprint.out_ident) trees + +let wrap_printing_env = wrap_printing_env +let ident = Fmt.compat ident +let longident = Fmt.compat longident +let path = Fmt.compat path +let type_path = Fmt.compat type_path +let type_expr = Fmt.compat type_expr +let type_scheme = Fmt.compat type_scheme +let shared_type_scheme = Fmt.compat shared_type_scheme + +let type_declaration = Fmt.compat1 type_declaration +let type_expansion = Fmt.compat1 type_expansion +let value_description = Fmt.compat1 value_description +let label = Fmt.compat label +let constructor = Fmt.compat constructor +let constructor_arguments = Fmt.compat constructor_arguments +let extension_constructor = Fmt.compat1 extension_constructor +let extension_only_constructor = Fmt.compat1 extension_only_constructor + +let modtype = Fmt.compat modtype +let modtype_declaration = Fmt.compat1 modtype_declaration +let signature = Fmt.compat signature + +let class_declaration = Fmt.compat1 class_declaration +let class_type = Fmt.compat class_type +let cltype_declaration = Fmt.compat1 cltype_declaration + + +(* Print a signature body (used by -i when compiling a .ml) *) +let printed_signature sourcefile ppf sg = + (* we are tracking any collision event for warning 63 *) + Ident_conflicts.reset (); + let t = tree_of_signature sg in + if Warnings.(is_active @@ Erroneous_printed_signature "") then + begin match Ident_conflicts.err_msg () with + | None -> () + | Some msg -> + let conflicts = Fmt.asprintf "%a" Fmt.pp_doc msg in + Location.prerr_warning (Location.in_file sourcefile) + (Warnings.Erroneous_printed_signature conflicts); + Warnings.check_fatal () + end; + Fmt.compat print_signature ppf t diff --git a/upstream/ocaml_503/typing/printtyp.mli b/upstream/ocaml_503/typing/printtyp.mli new file mode 100644 index 000000000..75955f426 --- /dev/null +++ b/upstream/ocaml_503/typing/printtyp.mli @@ -0,0 +1,103 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Printing functions *) + + +open Types + +type namespace := Shape.Sig_component_kind.t + +val namespaced_ident: namespace -> Ident.t -> string +val string_of_path: Path.t -> string +val strings_of_paths: namespace -> Path.t list -> string list +(** Print a list of paths, using the same naming context to + avoid name collisions *) + +(** [printed_signature sourcefile ppf sg] print the signature [sg] of + [sourcefile] with potential warnings for name collisions *) +val printed_signature: string -> Format.formatter -> signature -> unit + +module type Printers := sig + + val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a + (** Call the function using the environment for type path shortening This + affects all the printing functions below Also, if [~error:true], then + disable the loading of cmis *) + + type 'a printer + val longident: Longident.t printer + val ident: Ident.t printer + val path: Path.t printer + val type_path: Path.t printer + (** Print a type path taking account of [-short-paths]. + Calls should be within [wrap_printing_env]. *) + + + (** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want + multiple types to use common names for type variables, see + {!Out_type.prepare_for_printing} and {!Out_type.prepared_type_expr}. *) + val type_expr: type_expr printer + + val type_scheme: type_expr printer + + val shared_type_scheme: type_expr printer + (** [shared_type_scheme] is very similar to [type_scheme], but does not + reset the printing context first. This is intended to be used in cases + where the printing should have a particularly wide context, such as + documentation generators; most use cases, such as error messages, have + narrower contexts for which [type_scheme] is better suited. *) + + val type_expansion: + Out_type.type_or_scheme -> Errortrace.expanded_type printer + + val label : label_declaration printer + + val constructor : constructor_declaration printer + val constructor_arguments: constructor_arguments printer + + val extension_constructor: + Ident.t -> extension_constructor printer + (** Prints extension constructor with the type signature: + type ('a, 'b) bar += A of float + *) + + val extension_only_constructor: + Ident.t -> extension_constructor printer + (** Prints only extension constructor without type signature: + A of float + *) + + + val value_description: Ident.t -> value_description printer + val type_declaration: Ident.t -> type_declaration printer + val modtype_declaration: Ident.t -> modtype_declaration printer + val class_declaration: Ident.t -> class_declaration printer + val cltype_declaration: Ident.t -> class_type_declaration printer + + + val modtype: module_type printer + val signature: signature printer + val class_type: class_type printer + + end + +module Doc : Printers with type 'a printer := 'a Format_doc.printer + +(** For compatibility with Format printers *) +include Printers with type 'a printer := 'a Format_doc.format_printer diff --git a/upstream/ocaml_503/typing/printtyped.ml b/upstream/ocaml_503/typing/printtyped.ml new file mode 100644 index 000000000..c68c7a6c3 --- /dev/null +++ b/upstream/ocaml_503/typing/printtyped.ml @@ -0,0 +1,1003 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Format +open Lexing +open Location +open Typedtree + +let fmt_position f l = + if l.pos_lnum = -1 + then fprintf f "%s[%d]" l.pos_fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) + +let fmt_location f loc = + if not !Clflags.locations then () + else begin + fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; + end + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s; + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt + +let fmt_ident = Ident.print + +let fmt_modname f = function + | None -> fprintf f "_"; + | Some id -> Ident.print f id + +let rec fmt_path_aux f x = + match x with + | Path.Pident (s) -> fprintf f "%a" fmt_ident s + | Path.Pdot (y, s) | Path.(Pextra_ty (y, Pcstr_ty s)) -> + fprintf f "%a.%s" fmt_path_aux y s + | Path.Papply (y, z) -> + fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z + | Path.Pextra_ty (y, Pext_ty) -> fmt_path_aux f y + +let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x + +let fmt_constant f x = + match x with + | Const_int (i) -> fprintf f "Const_int %d" i + | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c) + | Const_string (s, strloc, None) -> + fprintf f "Const_string(%S,%a,None)" s fmt_location strloc + | Const_string (s, strloc, Some delim) -> + fprintf f "Const_string (%S,%a,Some %S)" s fmt_location strloc delim + | Const_float (s) -> fprintf f "Const_float %s" s + | Const_int32 (i) -> fprintf f "Const_int32 %ld" i + | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i + | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable" + | Mutable -> fprintf f "Mutable" + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual" + | Concrete -> fprintf f "Concrete" + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" + +let fmt_closed_flag f x = + match x with + | Closed -> fprintf f "Closed" + | Open -> fprintf f "Open" + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec" + | Recursive -> fprintf f "Rec" + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up" + | Downto -> fprintf f "Down" + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public" + | Private -> fprintf f "Private" + +let fmt_partiality f x = + match x with + | Total -> () + | Partial -> fprintf f " (Partial)" + +let line i f s (*...*) = + fprintf f "%s" (String.make (2*i) ' '); + fprintf f s (*...*) + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n" + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n" + +let array i f ppf a = + if Array.length a = 0 then + line i ppf "[]\n" + else begin + line i ppf "[\n"; + Array.iter (f (i+1) ppf) a; + line i ppf "]\n" + end + +let option i f ppf x = + match x with + | None -> line i ppf "None\n" + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x + +let longident i ppf li = line i ppf "%a\n" fmt_longident li +let string i ppf s = line i ppf "\"%s\"\n" s +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional s -> line i ppf "Optional \"%s\"\n" s + | Labelled s -> line i ppf "Labelled \"%s\"\n" s + +let typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +let record_representation i ppf = let open Types in function + | Record_regular -> line i ppf "Record_regular\n" + | Record_float -> line i ppf "Record_float\n" + | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b + | Record_inlined i -> line i ppf "Record_inlined %d\n" i + | Record_extension p -> line i ppf "Record_extension %a\n" fmt_path p + +let attribute i ppf k a = + line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt; + Printast.payload i ppf a.Parsetree.attr_payload + +let attributes i ppf l = + let i = i + 1 in + List.iter (fun a -> + line i ppf "attribute \"%s\"\n" a.Parsetree.attr_name.txt; + Printast.payload (i + 1) ppf a.Parsetree.attr_payload + ) l + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ctyp_loc; + attributes i ppf x.ctyp_attributes; + let i = i+1 in + match x.ctyp_desc with + | Ttyp_any -> line i ppf "Ttyp_any\n"; + | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s; + | Ttyp_arrow (l, ct1, ct2) -> + line i ppf "Ttyp_arrow\n"; + arg_label i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ttyp_tuple l -> + line i ppf "Ttyp_tuple\n"; + list i core_type ppf l; + | Ttyp_constr (li, _, l) -> + line i ppf "Ttyp_constr %a\n" fmt_path li; + list i core_type ppf l; + | Ttyp_variant (l, closed, low) -> + line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ttyp_object (l, c) -> + line i ppf "Ttyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter (fun {of_desc; of_attributes; _} -> + match of_desc with + | OTtag (s, t) -> + line i ppf "method %s\n" s.txt; + attributes i ppf of_attributes; + core_type (i + 1) ppf t + | OTinherit ct -> + line i ppf "OTinherit\n"; + core_type (i + 1) ppf ct + ) l + | Ttyp_class (li, _, l) -> + line i ppf "Ttyp_class %a\n" fmt_path li; + list i core_type ppf l; + | Ttyp_alias (ct, s) -> + line i ppf "Ttyp_alias \"%s\"\n" s.txt; + core_type i ppf ct; + | Ttyp_poly (sl, ct) -> + line i ppf "Ttyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; + core_type i ppf ct; + | Ttyp_package { pack_path = s; pack_fields = l } -> + line i ppf "Ttyp_package %a\n" fmt_path s; + list i package_with ppf l; + | Ttyp_open (path, _mod_ident, t) -> + line i ppf "Ttyp_open %a\n" fmt_path path; + core_type i ppf t + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident s; + core_type i ppf t + +and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> + line i ppf "pattern %a\n" fmt_location x.pat_loc; + attributes i ppf x.pat_attributes; + let i = i+1 in + begin match x.pat_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (pattern_extra (i+1) ppf) extra; + end; + match x.pat_desc with + | Tpat_any -> line i ppf "Tpat_any\n"; + | Tpat_var (s,_,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; + | Tpat_alias (p, s,_,_) -> + line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; + pattern i ppf p; + | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c; + | Tpat_tuple (l) -> + line i ppf "Tpat_tuple\n"; + list i pattern ppf l; + | Tpat_construct (li, _, po, vto) -> + line i ppf "Tpat_construct %a\n" fmt_longident li; + list i pattern ppf po; + option i + (fun i ppf (vl,ct) -> + let names = List.map (fun {txt} -> "\""^Ident.name txt^"\"") vl in + line i ppf "[%s]\n" (String.concat "; " names); + core_type i ppf ct) + ppf vto + | Tpat_variant (l, po, _) -> + line i ppf "Tpat_variant \"%s\"\n" l; + option i pattern ppf po; + | Tpat_record (l, _c) -> + line i ppf "Tpat_record\n"; + list i longident_x_pattern ppf l; + | Tpat_array (l) -> + line i ppf "Tpat_array\n"; + list i pattern ppf l; + | Tpat_lazy p -> + line i ppf "Tpat_lazy\n"; + pattern i ppf p; + | Tpat_exception p -> + line i ppf "Tpat_exception\n"; + pattern i ppf p; + | Tpat_value p -> + line i ppf "Tpat_value\n"; + pattern i ppf (p :> pattern); + | Tpat_or (p1, p2, _) -> + line i ppf "Tpat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + +and pattern_extra i ppf (extra_pat, _, attrs) = + match extra_pat with + | Tpat_unpack -> + line i ppf "Tpat_extra_unpack\n"; + attributes i ppf attrs; + | Tpat_constraint cty -> + line i ppf "Tpat_extra_constraint\n"; + attributes i ppf attrs; + core_type i ppf cty; + | Tpat_type (id, _) -> + line i ppf "Tpat_extra_type %a\n" fmt_path id; + attributes i ppf attrs; + | Tpat_open (id,_,_) -> + line i ppf "Tpat_extra_open %a\n" fmt_path id; + attributes i ppf attrs; + +and function_body i ppf (body : function_body) = + match[@warning "+9"] body with + | Tfunction_body e -> + line i ppf "Tfunction_body\n"; + expression (i+1) ppf e + | Tfunction_cases + { cases; loc; exp_extra; attributes = attrs; param = _; partial } + -> + line i ppf "Tfunction_cases%a %a\n" + fmt_partiality partial + fmt_location loc; + attributes (i+1) ppf attrs; + Option.iter (fun e -> expression_extra (i+1) ppf e []) exp_extra; + list (i+1) case ppf cases + +and expression_extra i ppf x attrs = + match x with + | Texp_constraint ct -> + line i ppf "Texp_constraint\n"; + attributes i ppf attrs; + core_type i ppf ct; + | Texp_coerce (cto1, cto2) -> + line i ppf "Texp_coerce\n"; + attributes i ppf attrs; + option i core_type ppf cto1; + core_type i ppf cto2; + | Texp_poly cto -> + line i ppf "Texp_poly\n"; + attributes i ppf attrs; + option i core_type ppf cto; + | Texp_newtype s -> + line i ppf "Texp_newtype \"%s\"\n" s; + attributes i ppf attrs; + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.exp_loc; + attributes i ppf x.exp_attributes; + let i = i+1 in + begin match x.exp_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (fun (x, _, attrs) -> expression_extra (i+1) ppf x attrs) extra; + end; + match x.exp_desc with + | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li; + | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li; + | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c; + | Texp_let (rf, l, e) -> + line i ppf "Texp_let %a\n" fmt_rec_flag rf; + list i (value_binding rf) ppf l; + expression i ppf e; + | Texp_function (params, body) -> + line i ppf "Texp_function\n"; + list i function_param ppf params; + function_body i ppf body; + | Texp_apply (e, l) -> + line i ppf "Texp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Texp_match (e, l1, l2, partial) -> + line i ppf "Texp_match%a\n" fmt_partiality partial; + expression i ppf e; + list i case ppf l1; + list i case ppf l2; + | Texp_try (e, l1, l2) -> + line i ppf "Texp_try\n"; + expression i ppf e; + list i case ppf l1; + list i case ppf l2; + | Texp_tuple (l) -> + line i ppf "Texp_tuple\n"; + list i expression ppf l; + | Texp_construct (li, _, eo) -> + line i ppf "Texp_construct %a\n" fmt_longident li; + list i expression ppf eo; + | Texp_variant (l, eo) -> + line i ppf "Texp_variant \"%s\"\n" l; + option i expression ppf eo; + | Texp_record { fields; representation; extended_expression } -> + line i ppf "Texp_record\n"; + let i = i+1 in + line i ppf "fields =\n"; + array (i+1) record_field ppf fields; + line i ppf "representation =\n"; + record_representation (i+1) ppf representation; + line i ppf "extended_expression =\n"; + option (i+1) expression ppf extended_expression; + | Texp_field (e, li, _) -> + line i ppf "Texp_field\n"; + expression i ppf e; + longident i ppf li; + | Texp_setfield (e1, li, _, e2) -> + line i ppf "Texp_setfield\n"; + expression i ppf e1; + longident i ppf li; + expression i ppf e2; + | Texp_array (l) -> + line i ppf "Texp_array\n"; + list i expression ppf l; + | Texp_ifthenelse (e1, e2, eo) -> + line i ppf "Texp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Texp_sequence (e1, e2) -> + line i ppf "Texp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_while (e1, e2) -> + line i ppf "Texp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_for (s, _, e1, e2, df, e3) -> + line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Texp_send (e, Tmeth_name s) -> + line i ppf "Texp_send \"%s\"\n" s; + expression i ppf e + | Texp_send (e, Tmeth_val s) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | Texp_send (e, Tmeth_ancestor(s, _)) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li; + | Texp_setinstvar (_, s, _, e) -> + line i ppf "Texp_setinstvar %a\n" fmt_path s; + expression i ppf e; + | Texp_override (_, l) -> + line i ppf "Texp_override\n"; + list i string_x_expression ppf l; + | Texp_letmodule (s, _, _, me, e) -> + line i ppf "Texp_letmodule \"%a\"\n" fmt_modname s; + module_expr i ppf me; + expression i ppf e; + | Texp_letexception (cd, e) -> + line i ppf "Texp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e; + | Texp_assert (e, _) -> + line i ppf "Texp_assert"; + expression i ppf e; + | Texp_lazy (e) -> + line i ppf "Texp_lazy"; + expression i ppf e; + | Texp_object (s, _) -> + line i ppf "Texp_object"; + class_structure i ppf s + | Texp_pack me -> + line i ppf "Texp_pack"; + module_expr i ppf me + | Texp_letop {let_; ands; param = _; body; partial } -> + line i ppf "Texp_letop%a" + fmt_partiality partial; + binding_op (i+1) ppf let_; + list (i+1) binding_op ppf ands; + case i ppf body + | Texp_unreachable -> + line i ppf "Texp_unreachable" + | Texp_extension_constructor (li, _) -> + line i ppf "Texp_extension_constructor %a" fmt_longident li + | Texp_open (o, e) -> + line i ppf "Texp_open %a\n" + fmt_override_flag o.open_override; + module_expr i ppf o.open_expr; + attributes i ppf o.open_attributes; + expression i ppf e; + +and value_description i ppf x = + line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location + x.val_loc; + attributes i ppf x.val_attributes; + core_type (i+1) ppf x.val_desc; + list (i+1) string ppf x.val_prim; + +and binding_op i ppf x = + line i ppf "binding_op %a %a\n" fmt_path x.bop_op_path + fmt_location x.bop_loc; + expression i ppf x.bop_exp + +and function_param i ppf x = + let p = x.fp_arg_label in + arg_label i ppf p; + match x.fp_kind with + | Tparam_pat pat -> + line i ppf "Param_pat%a\n" + fmt_partiality x.fp_partial; + pattern (i+1) ppf pat + | Tparam_optional_default (pat, expr) -> + line i ppf "Param_optional_default%a\n" + fmt_partiality x.fp_partial; + pattern (i+1) ppf pat; + expression (i+1) ppf expr + +and type_parameter i ppf (x, _variance) = core_type i ppf x + +and type_declaration i ppf x = + line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location + x.typ_loc; + attributes i ppf x.typ_attributes; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) type_parameter ppf x.typ_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.typ_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.typ_manifest; + +and type_kind i ppf x = + match x with + | Ttype_abstract -> + line i ppf "Ttype_abstract\n" + | Ttype_variant l -> + line i ppf "Ttype_variant\n"; + list (i+1) constructor_decl ppf l; + | Ttype_record l -> + line i ppf "Ttype_record\n"; + list (i+1) label_decl ppf l; + | Ttype_open -> + line i ppf "Ttype_open\n" + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.tyext_attributes; + let i = i+1 in + line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path; + line i ppf "ptyext_params =\n"; + list (i+1) type_parameter ppf x.tyext_params; + line i ppf "ptyext_constructors =\n"; + list (i+1) extension_constructor ppf x.tyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private; + +and type_exception i ppf x = + line i ppf "type_exception\n"; + attributes i ppf x.tyexn_attributes; + let i = i+1 in + line i ppf "ptyext_constructor =\n"; + let i = i+1 in + extension_constructor i ppf x.tyexn_constructor + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.ext_loc; + attributes i ppf x.ext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.ext_kind; + +and extension_constructor_kind i ppf x = + match x with + Text_decl(v, a, r) -> + line i ppf "Text_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + constructor_arguments (i+1) ppf a; + option (i+1) core_type ppf r; + | Text_rebind(p, _) -> + line i ppf "Text_rebind\n"; + line (i+1) ppf "%a\n" fmt_path p; + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.cltyp_loc; + attributes i ppf x.cltyp_attributes; + let i = i+1 in + match x.cltyp_desc with + | Tcty_constr (li, _, l) -> + line i ppf "Tcty_constr %a\n" fmt_path li; + list i core_type ppf l; + | Tcty_signature (cs) -> + line i ppf "Tcty_signature\n"; + class_signature i ppf cs; + | Tcty_arrow (l, co, cl) -> + line i ppf "Tcty_arrow\n"; + arg_label i ppf l; + core_type i ppf co; + class_type i ppf cl; + | Tcty_open (o, e) -> + line i ppf "Tcty_open %a %a\n" + fmt_override_flag o.open_override + fmt_path (fst o.open_expr); + class_type i ppf e + +and class_signature i ppf { csig_self = ct; csig_fields = l } = + line i ppf "class_signature\n"; + core_type (i+1) ppf ct; + list (i+1) class_type_field ppf l; + +and class_type_field i ppf x = + line i ppf "class_type_field %a\n" fmt_location x.ctf_loc; + let i = i+1 in + attributes i ppf x.ctf_attributes; + match x.ctf_desc with + | Tctf_inherit (ct) -> + line i ppf "Tctf_inherit\n"; + class_type i ppf ct; + | Tctf_val (s, mf, vf, ct) -> + line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Tctf_method (s, pf, vf, ct) -> + line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Tctf_constraint (ct1, ct2) -> + line i ppf "Tctf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Tctf_attribute a -> + attribute i ppf "Tctf_attribute" a + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.ci_loc; + attributes i ppf x.ci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.ci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.ci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.cl_loc; + attributes i ppf x.cl_attributes; + let i = i+1 in + match x.cl_desc with + | Tcl_ident (li, _, l) -> + line i ppf "Tcl_ident %a\n" fmt_path li; + list i core_type ppf l; + | Tcl_structure (cs) -> + line i ppf "Tcl_structure\n"; + class_structure i ppf cs; + | Tcl_fun (l, p, _, ce, _) -> + line i ppf "Tcl_fun\n"; + arg_label i ppf l; + pattern i ppf p; + class_expr i ppf ce + | Tcl_apply (ce, l) -> + line i ppf "Tcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Tcl_let (rf, l1, l2, ce) -> + line i ppf "Tcl_let %a\n" fmt_rec_flag rf; + list i (value_binding rf) ppf l1; + list i ident_x_expression_def ppf l2; + class_expr i ppf ce; + | Tcl_constraint (ce, Some ct, _, _, _) -> + line i ppf "Tcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct + | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce + | Tcl_open (o, e) -> + line i ppf "Tcl_open %a %a\n" + fmt_override_flag o.open_override + fmt_path (fst o.open_expr); + class_expr i ppf e + +and class_structure i ppf { cstr_self = p; cstr_fields = l } = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = + line i ppf "class_field %a\n" fmt_location x.cf_loc; + let i = i + 1 in + attributes i ppf x.cf_attributes; + match x.cf_desc with + | Tcf_inherit (ovf, ce, so, _, _) -> + line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf; + class_expr (i+1) ppf ce; + option (i+1) string ppf so; + | Tcf_val (s, mf, _, k, _) -> + line i ppf "Tcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf; + class_field_kind (i+1) ppf k + | Tcf_method (s, pf, k) -> + line i ppf "Tcf_method \"%s\" %a\n" s.txt fmt_private_flag pf; + class_field_kind (i+1) ppf k + | Tcf_constraint (ct1, ct2) -> + line i ppf "Tcf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Tcf_initializer (e) -> + line i ppf "Tcf_initializer\n"; + expression (i+1) ppf e; + | Tcf_attribute a -> + attribute i ppf "Tcf_attribute" a + +and class_field_kind i ppf = function + | Tcfk_concrete (o, e) -> + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e + | Tcfk_virtual t -> + line i ppf "Virtual\n"; + core_type i ppf t + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.ci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.mty_loc; + attributes i ppf x.mty_attributes; + let i = i+1 in + match x.mty_desc with + | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li; + | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li; + | Tmty_signature (s) -> + line i ppf "Tmty_signature\n"; + signature i ppf s; + | Tmty_functor (Unit, mt2) -> + line i ppf "Tmty_functor ()\n"; + module_type i ppf mt2; + | Tmty_functor (Named (s, _, mt1), mt2) -> + line i ppf "Tmty_functor \"%a\"\n" fmt_modname s; + module_type i ppf mt1; + module_type i ppf mt2; + | Tmty_with (mt, l) -> + line i ppf "Tmty_with\n"; + module_type i ppf mt; + list i longident_x_with_constraint ppf l; + | Tmty_typeof m -> + line i ppf "Tmty_typeof\n"; + module_expr i ppf m; + +and signature i ppf x = list i signature_item ppf x.sig_items + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.sig_loc; + let i = i+1 in + match x.sig_desc with + | Tsig_value vd -> + line i ppf "Tsig_value\n"; + value_description i ppf vd; + | Tsig_type (rf, l) -> + line i ppf "Tsig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Tsig_typesubst l -> + line i ppf "Tsig_typesubst\n"; + list i type_declaration ppf l; + | Tsig_typext e -> + line i ppf "Tsig_typext\n"; + type_extension i ppf e; + | Tsig_exception ext -> + line i ppf "Tsig_exception\n"; + type_exception i ppf ext + | Tsig_module md -> + line i ppf "Tsig_module \"%a\"\n" fmt_modname md.md_id; + attributes i ppf md.md_attributes; + module_type i ppf md.md_type + | Tsig_modsubst ms -> + line i ppf "Tsig_modsubst \"%a\" = %a\n" + fmt_ident ms.ms_id fmt_path ms.ms_manifest; + attributes i ppf ms.ms_attributes; + | Tsig_recmodule decls -> + line i ppf "Tsig_recmodule\n"; + list i module_declaration ppf decls; + | Tsig_modtype x -> + line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type + | Tsig_modtypesubst x -> + line i ppf "Tsig_modtypesubst \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type + | Tsig_open od -> + line i ppf "Tsig_open %a %a\n" + fmt_override_flag od.open_override + fmt_path (fst od.open_expr); + attributes i ppf od.open_attributes + | Tsig_include incl -> + line i ppf "Tsig_include\n"; + attributes i ppf incl.incl_attributes; + module_type i ppf incl.incl_mod + | Tsig_class (l) -> + line i ppf "Tsig_class\n"; + list i class_description ppf l; + | Tsig_class_type (l) -> + line i ppf "Tsig_class_type\n"; + list i class_type_declaration ppf l; + | Tsig_attribute a -> + attribute i ppf "Tsig_attribute" a + +and module_declaration i ppf md = + line i ppf "%a" fmt_modname md.md_id; + attributes i ppf md.md_attributes; + module_type (i+1) ppf md.md_type; + +and module_binding i ppf x = + line i ppf "%a\n" fmt_modname x.mb_id; + attributes i ppf x.mb_attributes; + module_expr (i+1) ppf x.mb_expr + +and modtype_declaration i ppf = function + | None -> line i ppf "#abstract" + | Some mt -> module_type (i + 1) ppf mt + +and with_constraint i ppf x = + match x with + | Twith_type (td) -> + line i ppf "Twith_type\n"; + type_declaration (i+1) ppf td; + | Twith_typesubst (td) -> + line i ppf "Twith_typesubst\n"; + type_declaration (i+1) ppf td; + | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li; + | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li; + | Twith_modtype mty -> + line i ppf "Twith_modtype\n"; + module_type (i+1) ppf mty + | Twith_modtypesubst mty -> + line i ppf "Twith_modtype\n"; + module_type (i+1) ppf mty + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.mod_loc; + attributes i ppf x.mod_attributes; + let i = i+1 in + match x.mod_desc with + | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li; + | Tmod_structure (s) -> + line i ppf "Tmod_structure\n"; + structure i ppf s; + | Tmod_functor (Unit, me) -> + line i ppf "Tmod_functor ()\n"; + module_expr i ppf me; + | Tmod_functor (Named (s, _, mt), me) -> + line i ppf "Tmod_functor \"%a\"\n" fmt_modname s; + module_type i ppf mt; + module_expr i ppf me; + | Tmod_apply (me1, me2, _) -> + line i ppf "Tmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Tmod_apply_unit me1 -> + line i ppf "Tmod_apply_unit\n"; + module_expr i ppf me1; + | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> + line i ppf "Tmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me + | Tmod_unpack (e, _) -> + line i ppf "Tmod_unpack\n"; + expression i ppf e; + +and structure i ppf x = list i structure_item ppf x.str_items + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.str_loc; + let i = i+1 in + match x.str_desc with + | Tstr_eval (e, attrs) -> + line i ppf "Tstr_eval\n"; + attributes i ppf attrs; + expression i ppf e; + | Tstr_value (rf, l) -> + line i ppf "Tstr_value %a\n" fmt_rec_flag rf; + list i (value_binding rf) ppf l; + | Tstr_primitive vd -> + line i ppf "Tstr_primitive\n"; + value_description i ppf vd; + | Tstr_type (rf, l) -> + line i ppf "Tstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Tstr_typext te -> + line i ppf "Tstr_typext\n"; + type_extension i ppf te + | Tstr_exception ext -> + line i ppf "Tstr_exception\n"; + type_exception i ppf ext; + | Tstr_module x -> + line i ppf "Tstr_module\n"; + module_binding i ppf x + | Tstr_recmodule bindings -> + line i ppf "Tstr_recmodule\n"; + list i module_binding ppf bindings + | Tstr_modtype x -> + line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type + | Tstr_open od -> + line i ppf "Tstr_open %a\n" + fmt_override_flag od.open_override; + module_expr i ppf od.open_expr; + attributes i ppf od.open_attributes + | Tstr_class (l) -> + line i ppf "Tstr_class\n"; + list i class_declaration ppf (List.map (fun (cl, _) -> cl) l); + | Tstr_class_type (l) -> + line i ppf "Tstr_class_type\n"; + list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); + | Tstr_include incl -> + line i ppf "Tstr_include"; + attributes i ppf incl.incl_attributes; + module_expr i ppf incl.incl_mod; + | Tstr_attribute a -> + attribute i ppf "Tstr_attribute" a + +and longident_x_with_constraint i ppf (li, _, wc) = + line i ppf "%a\n" fmt_path li; + with_constraint (i+1) ppf wc; + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf " %a\n" fmt_location l; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + +and constructor_decl i ppf {cd_id; cd_name = _; cd_vars; + cd_args; cd_res; cd_loc; cd_attributes} = + line i ppf "%a\n" fmt_location cd_loc; + line (i+1) ppf "%a\n" fmt_ident cd_id; + if cd_vars <> [] then line (i+1) ppf "cd_vars =%a\n" typevars cd_vars; + attributes i ppf cd_attributes; + constructor_arguments (i+1) ppf cd_args; + option (i+1) core_type ppf cd_res + +and constructor_arguments i ppf = function + | Cstr_tuple l -> list i core_type ppf l + | Cstr_record l -> list i label_decl ppf l + +and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; + ld_attributes} = + line i ppf "%a\n" fmt_location ld_loc; + attributes i ppf ld_attributes; + line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable; + line (i+1) ppf "%a" fmt_ident ld_id; + core_type (i+1) ppf ld_type + +and longident_x_pattern i ppf (li, _, p) = + line i ppf "%a\n" fmt_longident li; + pattern (i+1) ppf p; + +and case + : type k . _ -> _ -> k case -> unit + = fun i ppf {c_lhs; c_guard; c_rhs} -> + line i ppf "\n"; + pattern (i+1) ppf c_lhs; + begin match c_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf c_rhs; + +and value_binding rec_flag i ppf x = + begin match rec_flag, x.vb_rec_kind with + | Nonrecursive, _ -> line i ppf "\n" + | Recursive, Static -> line i ppf "\n" + | Recursive, Dynamic -> line i ppf "\n" + end; + attributes (i+1) ppf x.vb_attributes; + pattern (i+1) ppf x.vb_pat; + expression (i+1) ppf x.vb_expr + +and string_x_expression i ppf (s, _, e) = + line i ppf " \"%a\"\n" fmt_ident s; + expression (i+1) ppf e; + +and record_field i ppf = function + | _, Overridden (li, e) -> + line i ppf "%a\n" fmt_longident li; + expression (i+1) ppf e; + | _, Kept _ -> + line i ppf "" + +and label_x_expression i ppf (l, e) = + line i ppf "\n"; + arg_label (i+1) ppf l; + (match e with None -> () | Some e -> expression (i+1) ppf e) + +and ident_x_expression_def i ppf (l, e) = + line i ppf " \"%a\"\n" fmt_ident l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x.rf_desc with + | Ttag (l, b, ctl) -> + line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i+1) ppf x.rf_attributes; + list (i+1) core_type ppf ctl + | Tinherit (ct) -> + line i ppf "Tinherit\n"; + core_type (i+1) ppf ct + +let interface ppf x = list 0 signature_item ppf x.sig_items + +let implementation ppf x = list 0 structure_item ppf x.str_items + +let implementation_with_coercion ppf Typedtree.{structure; _} = + implementation ppf structure diff --git a/upstream/ocaml_503/typing/printtyped.mli b/upstream/ocaml_503/typing/printtyped.mli new file mode 100644 index 000000000..43539ead9 --- /dev/null +++ b/upstream/ocaml_503/typing/printtyped.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Typedtree +open Format + +val interface : formatter -> signature -> unit +val implementation : formatter -> structure -> unit + +val implementation_with_coercion : + formatter -> Typedtree.implementation -> unit diff --git a/upstream/ocaml_503/typing/rawprinttyp.ml b/upstream/ocaml_503/typing/rawprinttyp.ml new file mode 100644 index 000000000..00d94fc24 --- /dev/null +++ b/upstream/ocaml_503/typing/rawprinttyp.ml @@ -0,0 +1,147 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jacques Garrigue, Graduate School of Mathematics, Nagoya University *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +(* Print a raw type expression, with sharing *) + +open Format +open Types +open Asttypes +let longident = Pprintast.longident + +let raw_list pr ppf = function + [] -> fprintf ppf "[]" + | a :: l -> + fprintf ppf "@[<1>[%a%t]@]" pr a + (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) + +let kind_vars = ref [] +let kind_count = ref 0 + +let string_of_field_kind v = + match field_kind_repr v with + | Fpublic -> "Fpublic" + | Fabsent -> "Fabsent" + | Fprivate -> "Fprivate" + +let rec safe_repr v t = + match Transient_expr.coerce t with + {desc = Tlink t} when not (List.memq t v) -> + safe_repr (t::v) t + | t' -> t' + +let rec list_of_memo = function + Mnil -> [] + | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem + | Mlink rem -> list_of_memo !rem + +let print_name ppf = function + None -> fprintf ppf "None" + | Some name -> fprintf ppf "\"%s\"" name + +let path = Format_doc.compat Path.print + +let visited = ref [] +let rec raw_type ppf ty = + let ty = safe_repr [] ty in + if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin + visited := ty :: !visited; + fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;marks=%x;desc=@,%a}@]" + ty.id ty.level + (Transient_expr.get_scope ty) (Transient_expr.get_marks ty) + raw_type_desc ty.desc + end +and raw_type_list tl = raw_list raw_type tl +and raw_lid_type_list tl = + raw_list (fun ppf (lid, typ) -> + fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) + tl +and raw_type_desc ppf = function + Tvar name -> fprintf ppf "Tvar %a" print_name name + | Tarrow(l,t1,t2,c) -> + fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tconstr (p, tl, abbrev) -> + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p + raw_type_list tl + (raw_list path) (list_of_memo !abbrev) + | Tobject (t, nm) -> + fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t + (fun ppf -> + match !nm with None -> fprintf ppf " None" + | Some(p,tl) -> + fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) + | Tfield (f, k, t1, t2) -> + fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (string_of_field_kind k) + raw_type t1 raw_type t2 + | Tnil -> fprintf ppf "Tnil" + | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t + | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t + | Tsubst (t, Some t') -> + fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' + | Tunivar name -> fprintf ppf "Tunivar %a" print_name name + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + fprintf ppf + "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" + "row_fields=" + (raw_list (fun ppf (l, f) -> + fprintf ppf "@[%s,@ %a@]" l raw_field f)) + fields + "row_more=" raw_type more + "row_closed=" closed + "row_fixed=" raw_row_fixed fixed + "row_name=" + (fun ppf -> + match name with None -> fprintf ppf "None" + | Some(p,tl) -> + fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) + | Tpackage (p, fl) -> + fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl +and raw_row_fixed ppf = function +| None -> fprintf ppf "None" +| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" +| Some Types.Rigid -> fprintf ppf "Some Rigid" +| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t +| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p + +and raw_field ppf rf = + match_row_field + ~absent:(fun _ -> fprintf ppf "RFabsent") + ~present:(function + | None -> + fprintf ppf "RFpresent None" + | Some t -> + fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) + ~either:(fun c tl m (_,e) -> + fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c + raw_type_list tl m + (fun ppf -> + match e with None -> fprintf ppf " RFnone" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) + rf + +let type_expr ppf t = + visited := []; kind_vars := []; kind_count := 0; + raw_type ppf t; + visited := []; kind_vars := [] diff --git a/upstream/ocaml_503/typing/rawprinttyp.mli b/upstream/ocaml_503/typing/rawprinttyp.mli new file mode 100644 index 000000000..205bf299e --- /dev/null +++ b/upstream/ocaml_503/typing/rawprinttyp.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jacques Garrigue, Graduate School of Mathematics, Nagoya University *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module provides function(s) for printing the internal representation of + type expressions. It is targetted at internal use when debbuging the + compiler itself. *) + +val type_expr: Format.formatter -> Types.type_expr -> unit diff --git a/upstream/ocaml_503/typing/shape.ml b/upstream/ocaml_503/typing/shape.ml new file mode 100644 index 000000000..67e6b7a19 --- /dev/null +++ b/upstream/ocaml_503/typing/shape.ml @@ -0,0 +1,368 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Uid = struct + type t = + | Compilation_unit of string + | Item of { comp_unit: string; id: int; from: Unit_info.intf_or_impl } + | Internal + | Predef of string + + include Identifiable.Make(struct + type nonrec t = t + + let equal (x : t) y = x = y + let compare (x : t) y = compare x y + let hash (x : t) = Hashtbl.hash x + + let pp_intf_or_impl fmt = function + | Unit_info.Intf -> Format.pp_print_string fmt "[intf]" + | Unit_info.Impl -> () + + let print fmt = function + | Internal -> Format.pp_print_string fmt "" + | Predef name -> Format.fprintf fmt "" name + | Compilation_unit s -> Format.pp_print_string fmt s + | Item { comp_unit; id; from } -> + Format.fprintf fmt "%a%s.%d" pp_intf_or_impl from comp_unit id + + let output oc t = + let fmt = Format.formatter_of_out_channel oc in + print fmt t + end) + + let id = ref (-1) + + let reinit () = id := (-1) + + let mk ~current_unit = + let comp_unit, from = + let open Unit_info in + match current_unit with + | None -> "", Impl + | Some ui -> modname ui, kind ui + in + incr id; + Item { comp_unit; id = !id; from } + + let of_compilation_unit_id id = + if not (Ident.persistent id) then + Misc.fatal_errorf "Types.Uid.of_compilation_unit_id %S" (Ident.name id); + Compilation_unit (Ident.name id) + + let of_predef_id id = + if not (Ident.is_predef id) then + Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id); + Predef (Ident.name id) + + let internal_not_actually_unique = Internal + + let for_actual_declaration = function + | Item _ -> true + | _ -> false +end + +module Sig_component_kind = struct + type t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + let to_string = function + | Value -> "value" + | Type -> "type" + | Constructor -> "constructor" + | Label -> "label" + | Module -> "module" + | Module_type -> "module type" + | Extension_constructor -> "extension constructor" + | Class -> "class" + | Class_type -> "class type" + + let can_appear_in_types = function + | Value + | Extension_constructor -> + false + | Type + | Constructor + | Label + | Module + | Module_type + | Class + | Class_type -> + true +end + +module Item = struct + module T = struct + type t = string * Sig_component_kind.t + let compare = compare + + let name (name, _) = name + let kind (_, kind) = kind + + let make str ns = str, ns + + let value id = Ident.name id, Sig_component_kind.Value + let type_ id = Ident.name id, Sig_component_kind.Type + let constr id = Ident.name id, Sig_component_kind.Constructor + let label id = Ident.name id, Sig_component_kind.Label + let module_ id = Ident.name id, Sig_component_kind.Module + let module_type id = Ident.name id, Sig_component_kind.Module_type + let extension_constructor id = + Ident.name id, Sig_component_kind.Extension_constructor + let class_ id = + Ident.name id, Sig_component_kind.Class + let class_type id = + Ident.name id, Sig_component_kind.Class_type + + let print fmt (name, ns) = + Format.fprintf fmt "%S[%s]" + name + (Sig_component_kind.to_string ns) + end + + include T + + module Map = Map.Make(T) +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc; approximated: bool } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Alias of t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + | Error of string + +let print fmt t = + let print_uid_opt = + Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) + in + let rec aux fmt { uid; desc } = + match desc with + | Var id -> + Format.fprintf fmt "%s%a" (Ident.name id) print_uid_opt uid + | Abs (id, t) -> + let rec collect_idents = function + | { uid = None; desc = Abs(id, t) } -> + let (ids, body) = collect_idents t in + id :: ids, body + | body -> + ([], body) + in + let (other_idents, body) = collect_idents t in + let pp_idents fmt idents = + let idents_names = List.map Ident.name idents in + let pp_sep fmt () = Format.fprintf fmt ",@ " in + Format.pp_print_list ~pp_sep Format.pp_print_string fmt idents_names + in + Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" + print_uid_opt uid pp_idents (id :: other_idents) aux body + | App (t1, t2) -> + Format.fprintf fmt "@[%a(@,%a)%a@]" aux t1 aux t2 + print_uid_opt uid + | Leaf -> + Format.fprintf fmt "<%a>" (Format.pp_print_option Uid.print) uid + | Proj (t, item) -> + begin match uid with + | None -> + Format.fprintf fmt "@[%a@ .@ %a@]" + aux t + Item.print item + | Some uid -> + Format.fprintf fmt "@[(%a@ .@ %a)<%a>@]" + aux t + Item.print item + Uid.print uid + end + | Comp_unit name -> Format.fprintf fmt "CU %s" name + | Struct map -> + let print_map fmt = + Item.Map.iter (fun item t -> + Format.fprintf fmt "@[%a ->@ %a;@]@," + Item.print item + aux t + ) + in + if Item.Map.is_empty map then + Format.fprintf fmt "@[{%a}@]" print_uid_opt uid + else + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + | Alias t -> + Format.fprintf fmt "Alias@[(@[%a@,%a@])@]" print_uid_opt uid aux t + | Error s -> + Format.fprintf fmt "Error %s" s + in + if t.approximated then + Format.fprintf fmt "@[(approx)@ %a@]@;" aux t + else + Format.fprintf fmt "@[%a@]@;" aux t + +let rec strip_head_aliases = function + | { desc = Alias t; _ } -> strip_head_aliases t + | t -> t + +let fresh_var ?(name="shape-var") uid = + let var = Ident.create_local name in + var, { uid = Some uid; desc = Var var; approximated = false } + +let for_unnamed_functor_param = Ident.create_local "()" + +let var uid id = + { uid = Some uid; desc = Var id; approximated = false } + +let abs ?uid var body = + { uid; desc = Abs (var, body); approximated = false } + +let str ?uid map = + { uid; desc = Struct map; approximated = false } + +let alias ?uid t = + { uid; desc = Alias t; approximated = false} + +let leaf uid = + { uid = Some uid; desc = Leaf; approximated = false } + +let approx t = { t with approximated = true} + +let proj ?uid t item = + match t.desc with + | Leaf -> + (* When stuck projecting in a leaf we propagate the leaf + as a best effort *) + approx t + | Struct map -> + begin try Item.Map.find item map + with Not_found -> approx t (* ill-typed program *) + end + | _ -> + { uid; desc = Proj (t, item); approximated = false } + +let app ?uid f ~arg = + { uid; desc = App (f, arg); approximated = false } + +let decompose_abs t = + match t.desc with + | Abs (x, t) -> Some (x, t) + | _ -> None + +let dummy_mod = + { uid = None; desc = Struct Item.Map.empty; approximated = false } + +let of_path ~find_shape ~namespace path = + (* We need to handle the following cases: + Path of constructor: + M.t.C + Path of label: + M.t.lbl + Path of label of inline record: + M.t.C.lbl *) + let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function + | Pident id -> find_shape ns id + | Pdot (path, name) -> + let namespace : Sig_component_kind.t = + match (ns : Sig_component_kind.t) with + | Constructor -> Type + | Label -> Type + | _ -> Module + in + proj (aux namespace path) (name, ns) + | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) + | Pextra_ty (path, extra) -> begin + match extra with + Pcstr_ty name -> proj (aux Type path) (name, Constructor) + | Pext_ty -> aux Extension_constructor path + end + in + aux namespace path + +let for_persistent_unit s = + { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); + desc = Comp_unit s; approximated = false } + +let leaf_for_unpack = { uid = None; desc = Leaf; approximated = false } + +let set_uid_if_none t uid = + match t.uid with + | None -> { t with uid = Some uid } + | _ -> t + +module Map = struct + type shape = t + type nonrec t = t Item.Map.t + + let empty = Item.Map.empty + + let add t item shape = Item.Map.add item shape t + + let add_value t id uid = Item.Map.add (Item.value id) (leaf uid) t + let add_value_proj t id shape = + let item = Item.value id in + Item.Map.add item (proj shape item) t + + let add_type t id shape = Item.Map.add (Item.type_ id) shape t + let add_type_proj t id shape = + let item = Item.type_ id in + Item.Map.add item (proj shape item) t + + let add_constr t id shape = Item.Map.add (Item.constr id) shape t + let add_constr_proj t id shape = + let item = Item.constr id in + Item.Map.add item (proj shape item) t + + let add_label t id uid = Item.Map.add (Item.label id) (leaf uid) t + let add_label_proj t id shape = + let item = Item.label id in + Item.Map.add item (proj shape item) t + + let add_module t id shape = Item.Map.add (Item.module_ id) shape t + let add_module_proj t id shape = + let item = Item.module_ id in + Item.Map.add item (proj shape item) t + + let add_module_type t id uid = + Item.Map.add (Item.module_type id) (leaf uid) t + let add_module_type_proj t id shape = + let item = Item.module_type id in + Item.Map.add item (proj shape item) t + + let add_extcons t id shape = + Item.Map.add (Item.extension_constructor id) shape t + let add_extcons_proj t id shape = + let item = Item.extension_constructor id in + Item.Map.add item (proj shape item) t + + let add_class t id uid = Item.Map.add (Item.class_ id) (leaf uid) t + let add_class_proj t id shape = + let item = Item.class_ id in + Item.Map.add item (proj shape item) t + + let add_class_type t id uid = Item.Map.add (Item.class_type id) (leaf uid) t + let add_class_type_proj t id shape = + let item = Item.class_type id in + Item.Map.add item (proj shape item) t +end diff --git a/upstream/ocaml_503/typing/shape.mli b/upstream/ocaml_503/typing/shape.mli new file mode 100644 index 000000000..8da909fb7 --- /dev/null +++ b/upstream/ocaml_503/typing/shape.mli @@ -0,0 +1,201 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Shapes are an abstract representation of modules' implementations which + allow the tracking of definitions through functor applications and other + module-level operations. + + The Shape of a compilation unit is elaborated during typing, partially + reduced (without loading external shapes) and written to the [cmt] file. + + External tools can retrieve the definition of any value (or type, or module, + etc) by following this procedure: + + - Build the Shape corresponding to the value's path: + [let shape = Env.shape_of_path ~namespace env path] + + - Instantiate the [Shape_reduce.Make] functor with a way to load shapes from + external units and to looks for shapes in the environment (usually using + [Env.shape_of_path]). + + - Completely reduce the shape: + [let shape = My_reduce.(weak_)reduce env shape] + + - The [Uid.t] stored in the reduced shape should be the one of the + definition. However, if the [approximate] field of the reduced shape is + [true] then the [Uid.t] will not correspond to the definition, but to the + closest parent module's uid. This happens when Shape reduction gets stuck, + for example when hitting first-class modules. + + - The location of the definition can be easily found with the + [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit. + + See: + - {{:https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling} + the design document} + - {{:https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf} + a talk about the reduction strategy +*) + +(** A [Uid.t] is associated to every declaration in signatures and + implementations. They uniquely identify bindings in the program. When + associated with these bindings' locations they are useful to external tools + when trying to jump to an identifier's declaration or definition. They are + stored to that effect in the [uid_to_decl] table of cmt files. *) +module Uid : sig + type t = private + | Compilation_unit of string + | Item of { comp_unit: string; id: int; from: Unit_info.intf_or_impl } + | Internal + | Predef of string + + val reinit : unit -> unit + + val mk : current_unit:(Unit_info.t option) -> t + val of_compilation_unit_id : Ident.t -> t + val of_predef_id : Ident.t -> t + val internal_not_actually_unique : t + + val for_actual_declaration : t -> bool + + include Identifiable.S with type t := t +end + +module Sig_component_kind : sig + type t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + val to_string : t -> string + + (** Whether the name of a component of that kind can appear in a type. *) + val can_appear_in_types : t -> bool +end + +(** Shape's items are elements of a structure or, in the case of constructors + and labels, elements of a record or variants definition seen as a structure. + These structures model module components and nested types' constructors and + labels. *) +module Item : sig + type t = string * Sig_component_kind.t + val name : t -> string + val kind : t -> Sig_component_kind.t + + val make : string -> Sig_component_kind.t -> t + + val value : Ident.t -> t + val type_ : Ident.t -> t + val constr : Ident.t -> t + val label : Ident.t -> t + val module_ : Ident.t -> t + val module_type : Ident.t -> t + val extension_constructor : Ident.t -> t + val class_ : Ident.t -> t + val class_type : Ident.t -> t + + val print : Format.formatter -> t -> unit + + module Map : Map.S with type key = t +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc; approximated: bool } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Alias of t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + | Error of string + +val print : Format.formatter -> t -> unit + +val strip_head_aliases : t -> t + +(* Smart constructors *) + +val for_unnamed_functor_param : var +val fresh_var : ?name:string -> Uid.t -> var * t + +val var : Uid.t -> Ident.t -> t +val abs : ?uid:Uid.t -> var -> t -> t +val app : ?uid:Uid.t -> t -> arg:t -> t +val str : ?uid:Uid.t -> t Item.Map.t -> t +val alias : ?uid:Uid.t -> t -> t +val proj : ?uid:Uid.t -> t -> Item.t -> t +val leaf : Uid.t -> t + +val decompose_abs : t -> (var * t) option + +val for_persistent_unit : string -> t +val leaf_for_unpack : t + +module Map : sig + type shape = t + type nonrec t = t Item.Map.t + + val empty : t + + val add : t -> Item.t -> shape -> t + + val add_value : t -> Ident.t -> Uid.t -> t + val add_value_proj : t -> Ident.t -> shape -> t + + val add_type : t -> Ident.t -> shape -> t + val add_type_proj : t -> Ident.t -> shape -> t + + val add_constr : t -> Ident.t -> shape -> t + val add_constr_proj : t -> Ident.t -> shape -> t + + val add_label : t -> Ident.t -> Uid.t -> t + val add_label_proj : t -> Ident.t -> shape -> t + + val add_module : t -> Ident.t -> shape -> t + val add_module_proj : t -> Ident.t -> shape -> t + + val add_module_type : t -> Ident.t -> Uid.t -> t + val add_module_type_proj : t -> Ident.t -> shape -> t + + val add_extcons : t -> Ident.t -> shape -> t + val add_extcons_proj : t -> Ident.t -> shape -> t + + val add_class : t -> Ident.t -> Uid.t -> t + val add_class_proj : t -> Ident.t -> shape -> t + + val add_class_type : t -> Ident.t -> Uid.t -> t + val add_class_type_proj : t -> Ident.t -> shape -> t +end + +val dummy_mod : t + +(** This function returns the shape corresponding to a given path. It requires a + callback to find shapes in the environment. It is generally more useful to + rely directly on the [Env.shape_of_path] function to get the shape + associated with a given path. *) +val of_path : + find_shape:(Sig_component_kind.t -> Ident.t -> t) -> + namespace:Sig_component_kind.t -> Path.t -> t + +val set_uid_if_none : t -> Uid.t -> t diff --git a/upstream/ocaml_503/typing/shape_reduce.ml b/upstream/ocaml_503/typing/shape_reduce.ml new file mode 100644 index 000000000..9f793e7b8 --- /dev/null +++ b/upstream/ocaml_503/typing/shape_reduce.ml @@ -0,0 +1,342 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* Nathanaëlle Courant, OCamlPro *) +(* Gabriel Scherer, projet Picube, INRIA Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Shape + +type result = + | Resolved of Uid.t + | Resolved_alias of Uid.t * result + | Unresolved of t + | Approximated of Uid.t option + | Internal_error_missing_uid + +let rec print_result fmt result = + match result with + | Resolved uid -> + Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid + | Resolved_alias (uid, r) -> + Format.fprintf fmt "@[Alias: %a -> %a@]@;" + Uid.print uid print_result r + | Unresolved shape -> + Format.fprintf fmt "@[Unresolved: %a@]@;" print shape + | Approximated (Some uid) -> + Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid + | Approximated None -> + Format.fprintf fmt "@[Approximated: No uid@]@;" + | Internal_error_missing_uid -> + Format.fprintf fmt "@[Missing uid@]@;" + + +let find_shape env id = + let namespace = Shape.Sig_component_kind.Module in + Env.shape_of_path ~namespace env (Pident id) + +module Make(Params : sig + val fuel : int + val read_unit_shape : unit_name:string -> t option +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NAlias of delayed_nf + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NError of string + + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let approx_nf nf = { nf with approximated = true } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Env.t; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let local_env = env.local_env in + let memo_key = (local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. + *) + + and force env (Thunk (local_env, t)) = + reduce_ { env with local_env } t + + and reduce__ + ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let return desc = { uid = t.uid; desc; approximated = t.approximated } in + let rec force_aliases nf = match nf.desc with + | NAlias delayed_nf -> + let nf = force env delayed_nf in + force_aliases nf + | _ -> nf + in + let reset_uid_if_new_binding t' = + match t.uid with + | None -> t' + | Some _ as uid -> { t' with uid } + in + if !fuel < 0 then approx_nf (return (NError "NoFuelLeft")) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f |> force_aliases in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body |> reset_uid_if_new_binding + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str |> force_aliases in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> force env nf |> reset_uid_if_new_binding + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> + begin match force env def with + | { uid = Some _; _ } as nf -> nf + (* This var already has a binding uid *) + | { uid = None; _ } as nf -> { nf with uid = t.uid } + (* Set the var's binding uid *) + end + | exception Not_found -> + match find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + | Alias t -> return (NAlias (delay_reduce env t)) + | Error s -> approx_nf (return (NError s)) + + and read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid ; + desc = read_back_desc env nf.desc; + approximated = nf.approximated } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force dnf = read_back (force env dnf) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NAlias nf -> Alias (read_back_force nf) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NError s -> Error s + + (* Sharing the memo tables is safe at the level of a compilation unit since + idents should be unique *) + let reduce_memo_table = Local_store.s_table Hashtbl.create 42 + let read_back_memo_table = Local_store.s_table Hashtbl.create 42 + + let reduce global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table = !reduce_memo_table; + read_back_memo_table = !read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env + + let rec is_stuck_on_comp_unit (nf : nf) = + match nf.desc with + | NVar _ -> + (* This should not happen if we only reduce closed terms *) + false + | NApp (nf, _) | NProj (nf, _) -> is_stuck_on_comp_unit nf + | NStruct _ | NAbs _ -> false + | NAlias _ -> false + | NComp_unit _ -> true + | NError _ -> false + | NLeaf -> false + + let rec reduce_aliases_for_uid env (nf : nf) = + match nf with + | { uid = Some uid; desc = NAlias dnf; approximated = false; _ } -> + let result = reduce_aliases_for_uid env (force env dnf) in + Resolved_alias (uid, result) + | { uid = Some uid; approximated = false; _ } -> Resolved uid + | { uid; approximated = true } -> Approximated uid + | { uid = None; approximated = false; _ } -> + (* A missing Uid after a complete reduction means the Uid was first + missing in the shape which is a code error. Having the + [Missing_uid] reported will allow Merlin (or another tool working + with the index) to ask users to report the issue if it does happen. + *) + Internal_error_missing_uid + + let reduce_for_uid global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table = !reduce_memo_table; + read_back_memo_table = !read_back_memo_table; + local_env; + } in + let nf = reduce_ env t in + if is_stuck_on_comp_unit nf then + Unresolved (read_back env nf) + else + reduce_aliases_for_uid env nf +end + +module Local_reduce = + Make(struct + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + end) + +let local_reduce = Local_reduce.reduce +let local_reduce_for_uid = Local_reduce.reduce_for_uid diff --git a/upstream/ocaml_503/typing/shape_reduce.mli b/upstream/ocaml_503/typing/shape_reduce.mli new file mode 100644 index 000000000..307bc7683 --- /dev/null +++ b/upstream/ocaml_503/typing/shape_reduce.mli @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* Nathanaëlle Courant, OCamlPro *) +(* Gabriel Scherer, projet Picube, INRIA Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** The result of reducing a shape and looking for its uid *) +type result = + | Resolved of Shape.Uid.t (** Shape reduction succeeded and a uid was found *) + | Resolved_alias of Shape.Uid.t * result (** Reduction led to an alias *) + | Unresolved of Shape.t (** Result still contains [Comp_unit] terms *) + | Approximated of Shape.Uid.t option + (** Reduction failed: it can arrive with first-class modules for example *) + | Internal_error_missing_uid + (** Reduction succeeded but no uid was found, this should never happen *) + +val print_result : Format.formatter -> result -> unit + +(** The [Make] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) + + Usage warning: To ensure good performances, every reduction made with the + same instance of that functor share the same ident-based memoization tables. + Such an instance should only be used to perform reduction inside a unique + compilation unit to prevent conflicting entries in these memoization tables. +*) +module Make(_ : sig + val fuel : int + + val read_unit_shape : unit_name:string -> Shape.t option + end) : sig + val reduce : Env.t -> Shape.t -> Shape.t + + (** Perform weak reduction and return the head's uid if any. If reduction was + incomplete the partially reduced shape is returned. *) + val reduce_for_uid : Env.t -> Shape.t -> result +end + +(** [local_reduce] will not reduce shapes that require loading external + compilation units. *) +val local_reduce : Env.t -> Shape.t -> Shape.t + +(** [local_reduce_for_uid] will not reduce shapes that require loading external + compilation units. *) +val local_reduce_for_uid : Env.t -> Shape.t -> result diff --git a/upstream/ocaml_503/typing/signature_group.ml b/upstream/ocaml_503/typing/signature_group.ml new file mode 100644 index 000000000..b98a9eb67 --- /dev/null +++ b/upstream/ocaml_503/typing/signature_group.ml @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Fold on a signature by syntactic group of items *) + +(** Classes and class types generate ghosts signature items, we group them + together before printing *) +type sig_item = + { + src: Types.signature_item; + post_ghosts: Types.signature_item list + (** ghost classes types are post-declared *); + } +let flatten x = x.src :: x.post_ghosts + +type core_rec_group = + | Not_rec of sig_item + | Rec_group of sig_item list + +let rec_items = function + | Not_rec x -> [x] + | Rec_group x -> x + +(** Private row types are manifested as a sequence of definitions + preceding a recursive group, we collect them and separate them from the + syntactic recursive group. *) +type rec_group = + { pre_ghosts: Types.signature_item list; group:core_rec_group } + +let next_group = function + | [] -> None + | src :: q -> + let ghosts, q = + match src with + | Types.Sig_class _ -> + (* a class declaration for [c] is followed by the ghost + declarations of class type [c], and type [c] *) + begin match q with + | ct::t::q -> [ct;t], q + | _ -> assert false + end + | Types.Sig_class_type _ -> + (* a class type declaration for [ct] is followed by the ghost + declaration of type [ct] *) + begin match q with + | t::q -> [t], q + | _ -> assert false + end + | Types.(Sig_module _ | Sig_value _ | Sig_type _ | Sig_typext _ + | Sig_modtype _) -> + [],q + in + Some({src; post_ghosts=ghosts}, q) + +let recursive_sigitem = function + | Types.Sig_type(ident, _, rs, _) + | Types.Sig_class(ident,_,rs,_) + | Types.Sig_class_type (ident,_,rs,_) + | Types.Sig_module(ident, _, _, rs, _) -> Some (ident,rs) + | Types.(Sig_value _ | Sig_modtype _ | Sig_typext _ ) -> None + +let next x = + let cons_group pre group q = + let group = Rec_group (List.rev group) in + Some({ pre_ghosts=List.rev pre; group },q) + in + let rec not_in_group pre l = match next_group l with + | None -> + assert (pre=[]); + None + | Some(elt, q) -> + match recursive_sigitem elt.src with + | Some (id, _) when Btype.is_row_name (Ident.name id) -> + not_in_group (elt.src::pre) q + | None | Some (_, Types.Trec_not) -> + let sgroup = { pre_ghosts=List.rev pre; group=Not_rec elt } in + Some (sgroup,q) + | Some (id, Types.(Trec_first | Trec_next) ) -> + in_group ~pre ~ids:[id] ~group:[elt] q + and in_group ~pre ~ids ~group rem = match next_group rem with + | None -> cons_group pre group [] + | Some (elt,next) -> + match recursive_sigitem elt.src with + | Some (id, Types.Trec_next) -> + in_group ~pre ~ids:(id::ids) ~group:(elt::group) next + | None | Some (_, Types.(Trec_not|Trec_first)) -> + cons_group pre group rem + in + not_in_group [] x + +let seq l = Seq.unfold next l +let iter f l = Seq.iter f (seq l) +let fold f acc l = Seq.fold_left f acc (seq l) + +let update_rec_next rs rem = + match rs with + | Types.Trec_next -> rem + | Types.(Trec_first | Trec_not) -> + match rem with + | Types.Sig_type (id, decl, Trec_next, priv) :: rem -> + Types.Sig_type (id, decl, rs, priv) :: rem + | Types.Sig_module (id, pres, mty, Trec_next, priv) :: rem -> + Types.Sig_module (id, pres, mty, rs, priv) :: rem + | _ -> rem + +type in_place_patch = { + ghosts: Types.signature; + replace_by: Types.signature_item option; +} + + +let replace_in_place f sg = + let rec next_group f before signature = + match next signature with + | None -> None + | Some(item,sg) -> + core_group f ~before ~ghosts:item.pre_ghosts ~before_group:[] + (rec_items item.group) ~sg + and core_group f ~before ~ghosts ~before_group current ~sg = + let commit ghosts = before_group @ List.rev_append ghosts before in + match current with + | [] -> next_group f (commit ghosts) sg + | a :: q -> + match f ~ghosts a.src with + | Some (info, {ghosts; replace_by}) -> + let after = List.concat_map flatten q @ sg in + let after = match recursive_sigitem a.src, replace_by with + | None, _ | _, Some _ -> after + | Some (_,rs), None -> update_rec_next rs after + in + let before = match replace_by with + | None -> commit ghosts + | Some x -> x :: commit ghosts + in + let sg = List.rev_append before after in + Some(info, sg) + | None -> + let before_group = + List.rev_append a.post_ghosts (a.src :: before_group) + in + core_group f ~before ~ghosts ~before_group q ~sg + in + next_group f [] sg diff --git a/upstream/ocaml_503/typing/signature_group.mli b/upstream/ocaml_503/typing/signature_group.mli new file mode 100644 index 000000000..a84925db3 --- /dev/null +++ b/upstream/ocaml_503/typing/signature_group.mli @@ -0,0 +1,83 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Iterate on signature by syntactic group of items + + Classes, class types and private row types adds ghost components to + the signature where they are defined. + + When editing or printing a signature it is therefore important to + identify those ghost components. + + This module provides type grouping together ghost components + with the corresponding core item (or recursive group) and + the corresponding iterators. +*) + +(** Classes and class types generate ghosts signature items, we group them + together before printing *) +type sig_item = + { + src: Types.signature_item (** the syntactic item *) +; + post_ghosts: Types.signature_item list + (** ghost classes types are post-declared *); + } + +(** [flatten sig_item] is [x.src :: x.post_ghosts] *) +val flatten: sig_item -> Types.signature + +(** A group of mutually recursive definition *) +type core_rec_group = + | Not_rec of sig_item + | Rec_group of sig_item list + +(** [rec_items group] is the list of sig_items in the group *) +val rec_items: core_rec_group -> sig_item list + +(** Private #row types are manifested as a sequence of definitions + preceding a recursive group, we collect them and separate them from the + syntactic recursive group. *) +type rec_group = + { pre_ghosts: Types.signature_item list; group:core_rec_group } + +(** The sequence [seq signature] iterates over [signature] {!rec_group} by + {!rec_group}. + The second element of the tuple in the {!full_seq} case is the not-yet + traversed part of the signature. +*) +val next: Types.signature -> (rec_group * Types.signature) option +val seq: Types.signature -> rec_group Seq.t + +val iter: (rec_group -> unit) -> Types.signature -> unit +val fold: ('acc -> rec_group -> 'acc) -> 'acc -> Types.signature -> 'acc + +(** Describe how to amend one element of a signature *) +type in_place_patch = { + ghosts: Types.signature; (** updated list of ghost items *) + replace_by: Types.signature_item option; + (** replacement for the selected item *) +} + +(** + [!replace_in_place patch sg] replaces the first element of the signature + for which [patch ~ghosts component] returns [Some (value,patch)]. + The [ghosts] list is the current prefix of ghost components associated to + [component] +*) +val replace_in_place: + ( ghosts:Types.signature -> Types.signature_item + -> ('a * in_place_patch) option ) + -> Types.signature -> ('a * Types.signature) option diff --git a/upstream/ocaml_503/typing/stypes.ml b/upstream/ocaml_503/typing/stypes.ml new file mode 100644 index 000000000..400b2a84b --- /dev/null +++ b/upstream/ocaml_503/typing/stypes.ml @@ -0,0 +1,197 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Recording and dumping (partial) type information *) + +(* + We record all types in a list as they are created. + This means we can dump type information even if type inference fails, + which is extremely important, since type information is most + interesting in case of errors. +*) + +open Annot +open Lexing +open Location +open Typedtree + +let output_int oc i = output_string oc (Int.to_string i) + +type annotation = + | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation + | Ti_expr of expression + | Ti_class of class_expr + | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident + +let get_location ti = + match ti with + | Ti_pat (_, p) -> p.pat_loc + | Ti_expr e -> e.exp_loc + | Ti_class c -> c.cl_loc + | Ti_mod m -> m.mod_loc + | An_call (l, _k) -> l + | An_ident (l, _s, _k) -> l + +let annotations = ref ([] : annotation list) +let phrases = ref ([] : Location.t list) + +let record ti = + if !Clflags.annotations && not (get_location ti).Location.loc_ghost then + annotations := ti :: !annotations + +let record_phrase loc = + if !Clflags.annotations then phrases := loc :: !phrases + +(* comparison order: + the intervals are sorted by order of increasing upper bound + same upper bound -> sorted by decreasing lower bound +*) +let cmp_loc_inner_first loc1 loc2 = + match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with + | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum + | x -> x + +let cmp_ti_inner_first ti1 ti2 = + cmp_loc_inner_first (get_location ti1) (get_location ti2) + +let print_position pp pos = + if pos = dummy_pos then + output_string pp "--" + else begin + output_char pp '\"'; + output_string pp (String.escaped pos.pos_fname); + output_string pp "\" "; + output_int pp pos.pos_lnum; + output_char pp ' '; + output_int pp pos.pos_bol; + output_char pp ' '; + output_int pp pos.pos_cnum; + end + +let print_location pp loc = + print_position pp loc.loc_start; + output_char pp ' '; + print_position pp loc.loc_end + +let sort_filter_phrases () = + let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in + let rec loop accu cur l = + match l with + | [] -> accu + | loc :: t -> + if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum + && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum + then loop accu cur t + else loop (loc :: accu) loc t + in + phrases := loop [] Location.none ph + +let rec printtyp_reset_maybe loc = + match !phrases with + | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> + Out_type.reset (); + phrases := t; + printtyp_reset_maybe loc; + | _ -> () + +let call_kind_string k = + match k with + | Tail -> "tail" + | Stack -> "stack" + | Inline -> "inline" + +let print_ident_annot pp str k = + match k with + | Idef l -> + output_string pp "def "; + output_string pp str; + output_char pp ' '; + print_location pp l; + output_char pp '\n' + | Iref_internal l -> + output_string pp "int_ref "; + output_string pp str; + output_char pp ' '; + print_location pp l; + output_char pp '\n' + | Iref_external -> + output_string pp "ext_ref "; + output_string pp str; + output_char pp '\n' + +(* The format of the annotation file is documented in emacs/caml-types.el. *) + +let print_info pp prev_loc ti = + match ti with + | Ti_class _ | Ti_mod _ -> prev_loc + | Ti_pat (_, {pat_loc = loc; pat_type = typ; pat_env = env}) + | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} -> + if loc <> prev_loc then begin + print_location pp loc; + output_char pp '\n' + end; + output_string pp "type(\n"; + printtyp_reset_maybe loc; + Format.pp_print_string Format.str_formatter " "; + Printtyp.wrap_printing_env ~error:false env + (fun () -> + Printtyp.shared_type_scheme Format.str_formatter typ + ); + Format.pp_print_newline Format.str_formatter (); + let s = Format.flush_str_formatter () in + output_string pp s; + output_string pp ")\n"; + loc + | An_call (loc, k) -> + if loc <> prev_loc then begin + print_location pp loc; + output_char pp '\n' + end; + output_string pp "call(\n "; + output_string pp (call_kind_string k); + output_string pp "\n)\n"; + loc + | An_ident (loc, str, k) -> + if loc <> prev_loc then begin + print_location pp loc; + output_char pp '\n' + end; + output_string pp "ident(\n "; + print_ident_annot pp str k; + output_string pp ")\n"; + loc + +let get_info () = + let info = List.fast_sort cmp_ti_inner_first !annotations in + annotations := []; + info + +let dump filename = + if !Clflags.annotations then begin + let do_dump _temp_filename pp = + let info = get_info () in + sort_filter_phrases (); + ignore (List.fold_left (print_info pp) Location.none info) in + begin match filename with + | None -> do_dump "" stdout + | Some filename -> + Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump + end; + phrases := []; + end else begin + annotations := []; + end diff --git a/upstream/ocaml_503/typing/stypes.mli b/upstream/ocaml_503/typing/stypes.mli new file mode 100644 index 000000000..3a86d27a5 --- /dev/null +++ b/upstream/ocaml_503/typing/stypes.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Recording and dumping (partial) type information *) + +(* Clflags.save_types must be true *) + +open Typedtree + +type annotation = + | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation + | Ti_expr of expression + | Ti_class of class_expr + | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident + +val record : annotation -> unit +val record_phrase : Location.t -> unit +val dump : string option -> unit + +val get_location : annotation -> Location.t +val get_info : unit -> annotation list diff --git a/upstream/ocaml_503/typing/subst.ml b/upstream/ocaml_503/typing/subst.ml new file mode 100644 index 000000000..87b6ec6e9 --- /dev/null +++ b/upstream/ocaml_503/typing/subst.ml @@ -0,0 +1,834 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Substitutions *) + +open Misc +open Path +open Types +open Btype + +open Local_store + +type type_replacement = + | Path of Path.t + | Type_function of { params : type_expr list; body : type_expr } + +type t = + { types: type_replacement Path.Map.t; + modules: Path.t Path.Map.t; + modtypes: module_type Path.Map.t; + for_saving: bool; + loc: Location.t option; + } + +let identity = + { types = Path.Map.empty; + modules = Path.Map.empty; + modtypes = Path.Map.empty; + for_saving = false; + loc = None; + } + +let add_type_path id p s = { s with types = Path.Map.add id (Path p) s.types } +let add_type id p s = add_type_path (Pident id) p s + +let add_type_function id ~params ~body s = + { s with types = Path.Map.add id (Type_function { params; body }) s.types } + +let add_module_path id p s = { s with modules = Path.Map.add id p s.modules } +let add_module id p s = add_module_path (Pident id) p s + +let add_modtype_path p ty s = { s with modtypes = Path.Map.add p ty s.modtypes } +let add_modtype id ty s = add_modtype_path (Pident id) ty s + +let for_saving s = { s with for_saving = true } + +let change_locs s loc = { s with loc = Some loc } + +let loc s x = + match s.loc with + | Some l -> l + | None -> + if s.for_saving && not !Clflags.keep_locs then Location.none else x + +let remove_loc = + let open Ast_mapper in + {default_mapper with location = (fun _this _loc -> Location.none)} + +let is_not_doc = function + | {Parsetree.attr_name = {Location.txt = "ocaml.doc"}; _} -> false + | {Parsetree.attr_name = {Location.txt = "ocaml.text"}; _} -> false + | {Parsetree.attr_name = {Location.txt = "doc"}; _} -> false + | {Parsetree.attr_name = {Location.txt = "text"}; _} -> false + | _ -> true + +let attrs s x = + let x = + if s.for_saving && not !Clflags.keep_docs then + List.filter is_not_doc x + else x + in + if s.for_saving && not !Clflags.keep_locs + then remove_loc.Ast_mapper.attributes remove_loc x + else x + +let rec module_path s path = + try Path.Map.find path s.modules + with Not_found -> + match path with + | Pident _ -> path + | Pdot(p, n) -> + Pdot(module_path s p, n) + | Papply(p1, p2) -> + Papply(module_path s p1, module_path s p2) + | Pextra_ty _ -> + fatal_error "Subst.module_path" + +let modtype_path s path = + match Path.Map.find path s.modtypes with + | Mty_ident p -> p + | Mty_alias _ | Mty_signature _ | Mty_functor _ -> + fatal_error "Subst.modtype_path" + | exception Not_found -> + match path with + | Pdot(p, n) -> + Pdot(module_path s p, n) + | Papply _ | Pextra_ty _ -> + fatal_error "Subst.modtype_path" + | Pident _ -> path + +(* For values, extension constructors, classes and class types *) +let value_path s path = + match path with + | Pident _ -> path + | Pdot(p, n) -> Pdot(module_path s p, n) + | Papply _ | Pextra_ty _ -> fatal_error "Subst.value_path" + +let rec type_path s path = + match Path.Map.find path s.types with + | Path p -> p + | Type_function _ -> assert false + | exception Not_found -> + match path with + | Pident _ -> path + | Pdot(p, n) -> + Pdot(module_path s p, n) + | Papply _ -> + fatal_error "Subst.type_path" + | Pextra_ty (p, extra) -> + match extra with + | Pcstr_ty _ -> Pextra_ty (type_path s p, extra) + | Pext_ty -> Pextra_ty (value_path s p, extra) + +let to_subst_by_type_function s p = + match Path.Map.find p s.types with + | Path _ -> false + | Type_function _ -> true + | exception Not_found -> false + +(* Special type ids for saved signatures *) + +let new_id = s_ref (-1) +let reset_for_saving () = new_id := -1 + +let newpersty desc = + decr new_id; + create_expr + desc ~level:generic_level ~scope:Btype.lowest_level ~id:!new_id + +(* ensure that all occurrences of 'Tvar None' are physically shared *) +let tvar_none = Tvar None +let tunivar_none = Tunivar None +let norm = function + | Tvar None -> tvar_none + | Tunivar None -> tunivar_none + | d -> d + +let apply_type_function params args body = + For_copy.with_scope (fun copy_scope -> + List.iter2 + (fun param arg -> + For_copy.redirect_desc copy_scope param (Tsubst (arg, None))) + params args; + let rec copy ty = + assert (get_level ty = generic_level); + match get_desc ty with + | Tsubst (ty, _) -> ty + | Tvariant row -> + let t = newgenstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let more = row_more row in + assert (get_level more = generic_level); + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + let desc' = + match mored with + | Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + let more' = + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) + | Tconstr _ | Tnil -> + copy more + | Tvar _ | Tunivar _ -> + newgenty mored + | _ -> assert false + in + let row = + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~fixed:(Some (Reified x)) + | _ -> row + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst(more', Some t)); + (* Return a new copy *) + Tvariant (copy_row copy true row false more') + in + Transient_expr.set_stub_desc t desc'; + t + | desc -> + let t = newgenstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let desc' = copy_type_desc copy desc in + Transient_expr.set_stub_desc t desc'; + t + in + copy body) + + +(* Similar to [Ctype.nondep_type_rec]. *) +let rec typexp copy_scope s ty = + let desc = get_desc ty in + match desc with + Tvar _ | Tunivar _ -> + if s.for_saving || get_id ty < 0 then + let ty' = + if s.for_saving then newpersty (norm desc) + else newty2 ~level:(get_level ty) desc + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + ty' + else ty + | Tsubst (ty, _) -> + ty + | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method + && field_kind_repr k <> Fabsent && get_level ty < generic_level -> + (* do not copy the type of self when it is not generalized *) + ty +(* cannot do it, since it would omit substitution + | Tvariant row when not (static_row row) -> + ty +*) + | _ -> + let tm = row_of_type ty in + let has_fixed_row = + not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in + (* Make a stub *) + let ty' = + if s.for_saving then newpersty (Tvar None) + else newgenstub ~scope:(get_scope ty) + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + let desc = + if has_fixed_row then + match get_desc tm with (* PR#7348 *) + Tconstr (Pdot(m,i), tl, _abbrev) -> + let i' = String.sub i 0 (String.length i - 4) in + Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil) + | _ -> assert false + else match desc with + | Tconstr (p, args, _abbrev) -> + let args = List.map (typexp copy_scope s) args in + begin match Path.Map.find p s.types with + | exception Not_found -> Tconstr(type_path s p, args, ref Mnil) + | Path _ -> Tconstr(type_path s p, args, ref Mnil) + | Type_function { params; body } -> + Tlink (apply_type_function params args body) + end + | Tpackage(p, fl) -> + Tpackage(modtype_path s p, + List.map (fun (n, ty) -> (n, typexp copy_scope s ty)) fl) + | Tobject (t1, name) -> + let t1' = typexp copy_scope s t1 in + let name' = + match !name with + | None -> None + | Some (p, tl) -> + if to_subst_by_type_function s p + then None + else Some (type_path s p, List.map (typexp copy_scope s) tl) + in + Tobject (t1', ref name') + | Tvariant row -> + let more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + let dup = + s.for_saving || get_level more = generic_level || + static_row row || is_Tconstr more in + (* Various cases for the row variable *) + let more' = + match mored with + Tsubst (ty, None) -> ty + | Tconstr _ | Tnil -> typexp copy_scope s more + | Tunivar _ | Tvar _ -> + if s.for_saving then newpersty (norm mored) + else if dup && is_Tvar more then newgenty mored + else more + | _ -> assert false + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst (more', Some ty')); + (* TODO: check if more' can be eliminated *) + (* Return a new copy *) + let row = + copy_row (typexp copy_scope s) true row (not dup) more' in + match row_name row with + | Some (p, tl) -> + let name = + if to_subst_by_type_function s p then None + else Some (type_path s p, tl) + in + Tvariant (set_row_name row name) + | None -> + Tvariant row + end + | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> + Tlink (typexp copy_scope s t2) + | _ -> copy_type_desc (typexp copy_scope s) desc + in + Transient_expr.set_stub_desc ty' desc; + ty' + +(* + Always make a copy of the type. If this is not done, type levels + might not be correct. +*) +let type_expr s ty = + For_copy.with_scope (fun copy_scope -> typexp copy_scope s ty) + +let label_declaration copy_scope s l = + { + ld_id = l.ld_id; + ld_mutable = l.ld_mutable; + ld_type = typexp copy_scope s l.ld_type; + ld_loc = loc s l.ld_loc; + ld_attributes = attrs s l.ld_attributes; + ld_uid = l.ld_uid; + } + +let constructor_arguments copy_scope s = function + | Cstr_tuple l -> + Cstr_tuple (List.map (typexp copy_scope s) l) + | Cstr_record l -> + Cstr_record (List.map (label_declaration copy_scope s) l) + +let constructor_declaration copy_scope s c = + { + cd_id = c.cd_id; + cd_args = constructor_arguments copy_scope s c.cd_args; + cd_res = Option.map (typexp copy_scope s) c.cd_res; + cd_loc = loc s c.cd_loc; + cd_attributes = attrs s c.cd_attributes; + cd_uid = c.cd_uid; + } + +let type_declaration' copy_scope s decl = + { type_params = List.map (typexp copy_scope s) decl.type_params; + type_arity = decl.type_arity; + type_kind = + begin match decl.type_kind with + Type_abstract r -> Type_abstract r + | Type_variant (cstrs, rep) -> + Type_variant (List.map (constructor_declaration copy_scope s) cstrs, + rep) + | Type_record(lbls, rep) -> + Type_record (List.map (label_declaration copy_scope s) lbls, rep) + | Type_open -> Type_open + end; + type_manifest = + begin + match decl.type_manifest with + None -> None + | Some ty -> Some(typexp copy_scope s ty) + end; + type_private = decl.type_private; + type_variance = decl.type_variance; + type_separability = decl.type_separability; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc s decl.type_loc; + type_attributes = attrs s decl.type_attributes; + type_immediate = decl.type_immediate; + type_unboxed_default = decl.type_unboxed_default; + type_uid = decl.type_uid; + } + +let type_declaration s decl = + For_copy.with_scope (fun copy_scope -> type_declaration' copy_scope s decl) + +let class_signature copy_scope s sign = + { csig_self = typexp copy_scope s sign.csig_self; + csig_self_row = typexp copy_scope s sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, t) -> (m, v, typexp copy_scope s t)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, t) -> (p, v, typexp copy_scope s t)) + sign.csig_meths; + } + +let rec class_type copy_scope s = function + | Cty_constr (p, tyl, cty) -> + let p' = type_path s p in + let tyl' = List.map (typexp copy_scope s) tyl in + let cty' = class_type copy_scope s cty in + Cty_constr (p', tyl', cty') + | Cty_signature sign -> + Cty_signature (class_signature copy_scope s sign) + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, typexp copy_scope s ty, class_type copy_scope s cty) + +let class_declaration' copy_scope s decl = + { cty_params = List.map (typexp copy_scope s) decl.cty_params; + cty_variance = decl.cty_variance; + cty_type = class_type copy_scope s decl.cty_type; + cty_path = type_path s decl.cty_path; + cty_new = + begin match decl.cty_new with + | None -> None + | Some ty -> Some (typexp copy_scope s ty) + end; + cty_loc = loc s decl.cty_loc; + cty_attributes = attrs s decl.cty_attributes; + cty_uid = decl.cty_uid; + } + +let class_declaration s decl = + For_copy.with_scope (fun copy_scope -> class_declaration' copy_scope s decl) + +let cltype_declaration' copy_scope s decl = + { clty_params = List.map (typexp copy_scope s) decl.clty_params; + clty_variance = decl.clty_variance; + clty_type = class_type copy_scope s decl.clty_type; + clty_path = type_path s decl.clty_path; + clty_hash_type = type_declaration' copy_scope s decl.clty_hash_type ; + clty_loc = loc s decl.clty_loc; + clty_attributes = attrs s decl.clty_attributes; + clty_uid = decl.clty_uid; + } + +let cltype_declaration s decl = + For_copy.with_scope (fun copy_scope -> cltype_declaration' copy_scope s decl) + +let class_type s cty = + For_copy.with_scope (fun copy_scope -> class_type copy_scope s cty) + +let value_description' copy_scope s descr = + { val_type = typexp copy_scope s descr.val_type; + val_kind = descr.val_kind; + val_loc = loc s descr.val_loc; + val_attributes = attrs s descr.val_attributes; + val_uid = descr.val_uid; + } + +let value_description s descr = + For_copy.with_scope (fun copy_scope -> value_description' copy_scope s descr) + +let extension_constructor' copy_scope s ext = + { ext_type_path = type_path s ext.ext_type_path; + ext_type_params = List.map (typexp copy_scope s) ext.ext_type_params; + ext_args = constructor_arguments copy_scope s ext.ext_args; + ext_ret_type = Option.map (typexp copy_scope s) ext.ext_ret_type; + ext_private = ext.ext_private; + ext_attributes = attrs s ext.ext_attributes; + ext_loc = if s.for_saving then Location.none else ext.ext_loc; + ext_uid = ext.ext_uid; + } + +let extension_constructor s ext = + For_copy.with_scope + (fun copy_scope -> extension_constructor' copy_scope s ext) + + +(* For every binding k |-> d of m1, add k |-> f d to m2 + and return resulting merged map. *) + +let merge_path_maps f m1 m2 = + Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2 + +let keep_latest_loc l1 l2 = + match l2 with + | None -> l1 + | Some _ -> l2 + +let type_replacement s = function + | Path p -> Path (type_path s p) + | Type_function { params; body } -> + For_copy.with_scope (fun copy_scope -> + let params = List.map (typexp copy_scope s) params in + let body = typexp copy_scope s body in + Type_function { params; body }) + +type scoping = + | Keep + | Make_local + | Rescope of int + +module Lazy_types = struct + + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + + and modtype_declaration = + { + mtdl_type: modtype option; + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature' = + | S_eager of Types.signature + | S_lazy of signature_item list + + and signature = + (scoping * t * signature', signature') Lazy_backtrack.t + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + +end +open Lazy_types + +let rename_bound_idents scoping s sg = + let rename = + let open Ident in + match scoping with + | Keep -> (fun id -> create_scoped ~scope:(scope id) (name id)) + | Make_local -> Ident.rename + | Rescope scope -> (fun id -> create_scoped ~scope (name id)) + in + let rec rename_bound_idents s sg = function + | [] -> sg, s + | SigL_type(id, td, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_type(id', td, rs, vis) :: sg) + rest + | SigL_module(id, pres, md, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_module id (Pident id') s) + (SigL_module (id', pres, md, rs, vis) :: sg) + rest + | SigL_modtype(id, mtd, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_modtype id (Mty_ident(Pident id')) s) + (SigL_modtype(id', mtd, vis) :: sg) + rest + | SigL_class(id, cd, rs, vis) :: rest -> + (* cheat and pretend they are types cf. PR#6650 *) + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_class(id', cd, rs, vis) :: sg) + rest + | SigL_class_type(id, ctd, rs, vis) :: rest -> + (* cheat and pretend they are types cf. PR#6650 *) + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_class_type(id', ctd, rs, vis) :: sg) + rest + | SigL_value(id, vd, vis) :: rest -> + (* scope doesn't matter for value identifiers. *) + let id' = Ident.rename id in + rename_bound_idents s (SigL_value(id', vd, vis) :: sg) rest + | SigL_typext(id, ec, es, vis) :: rest -> + let id' = rename id in + rename_bound_idents s (SigL_typext(id',ec,es,vis) :: sg) rest + in + rename_bound_idents s [] sg + +let rec lazy_module_decl md = + { mdl_type = lazy_modtype md.md_type; + mdl_attributes = md.md_attributes; + mdl_loc = md.md_loc; + mdl_uid = md.md_uid } + +and subst_lazy_module_decl scoping s md = + let mdl_type = subst_lazy_modtype scoping s md.mdl_type in + { mdl_type; + mdl_attributes = attrs s md.mdl_attributes; + mdl_loc = loc s md.mdl_loc; + mdl_uid = md.mdl_uid } + +and force_module_decl md = + let md_type = force_modtype md.mdl_type in + { md_type; + md_attributes = md.mdl_attributes; + md_loc = md.mdl_loc; + md_uid = md.mdl_uid } + +and lazy_modtype = function + | Mty_ident p -> MtyL_ident p + | Mty_signature sg -> + MtyL_signature (Lazy_backtrack.create_forced (S_eager sg)) + | Mty_functor (Unit, mty) -> MtyL_functor (Unit, lazy_modtype mty) + | Mty_functor (Named (id, arg), res) -> + MtyL_functor (Named (id, lazy_modtype arg), lazy_modtype res) + | Mty_alias p -> MtyL_alias p + +and subst_lazy_modtype scoping s = function + | MtyL_ident p -> + begin match Path.Map.find p s.modtypes with + | mty -> lazy_modtype mty + | exception Not_found -> + begin match p with + | Pident _ -> MtyL_ident p + | Pdot(p, n) -> + MtyL_ident(Pdot(module_path s p, n)) + | Papply _ | Pextra_ty _ -> + fatal_error "Subst.modtype" + end + end + | MtyL_signature sg -> + MtyL_signature(subst_lazy_signature scoping s sg) + | MtyL_functor(Unit, res) -> + MtyL_functor(Unit, subst_lazy_modtype scoping s res) + | MtyL_functor(Named (None, arg), res) -> + MtyL_functor(Named (None, (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping s res) + | MtyL_functor(Named (Some id, arg), res) -> + let id' = Ident.rename id in + MtyL_functor(Named (Some id', (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping (add_module id (Pident id') s) res) + | MtyL_alias p -> + MtyL_alias (module_path s p) + +and force_modtype = function + | MtyL_ident p -> Mty_ident p + | MtyL_signature sg -> Mty_signature (force_signature sg) + | MtyL_functor (param, res) -> + let param : Types.functor_parameter = + match param with + | Unit -> Unit + | Named (id, mty) -> Named (id, force_modtype mty) in + Mty_functor (param, force_modtype res) + | MtyL_alias p -> Mty_alias p + +and lazy_modtype_decl mtd = + let mtdl_type = Option.map lazy_modtype mtd.mtd_type in + { mtdl_type; + mtdl_attributes = mtd.mtd_attributes; + mtdl_loc = mtd.mtd_loc; + mtdl_uid = mtd.mtd_uid } + +and subst_lazy_modtype_decl scoping s mtd = + { mtdl_type = Option.map (subst_lazy_modtype scoping s) mtd.mtdl_type; + mtdl_attributes = attrs s mtd.mtdl_attributes; + mtdl_loc = loc s mtd.mtdl_loc; + mtdl_uid = mtd.mtdl_uid } + +and force_modtype_decl mtd = + let mtd_type = Option.map force_modtype mtd.mtdl_type in + { mtd_type; + mtd_attributes = mtd.mtdl_attributes; + mtd_loc = mtd.mtdl_loc; + mtd_uid = mtd.mtdl_uid } + +and subst_lazy_signature scoping s sg = + match Lazy_backtrack.get_contents sg with + | Left (scoping', s', sg) -> + let scoping = + match scoping', scoping with + | sc, Keep -> sc + | _, (Make_local|Rescope _) -> scoping + in + let s = compose s' s in + Lazy_backtrack.create (scoping, s, sg) + | Right sg -> + Lazy_backtrack.create (scoping, s, sg) + +and force_signature sg = + List.map force_signature_item (force_signature_once sg) + +and force_signature_once sg = + lazy_signature' (Lazy_backtrack.force force_signature_once' sg) + +and lazy_signature' = function + | S_lazy sg -> sg + | S_eager sg -> List.map lazy_signature_item sg + +and force_signature_once' (scoping, s, sg) = + let sg = lazy_signature' sg in + (* Components of signature may be mutually recursive (e.g. type declarations + or class and type declarations), so first build global renaming + substitution... *) + let (sg', s') = rename_bound_idents scoping s sg in + (* ... then apply it to each signature component in turn *) + For_copy.with_scope (fun copy_scope -> + S_lazy (List.rev_map (subst_lazy_signature_item' copy_scope scoping s') sg') + ) + +and lazy_signature_item = function + | Sig_value(id, d, vis) -> + SigL_value(id, d, vis) + | Sig_type(id, d, rs, vis) -> + SigL_type(id, d, rs, vis) + | Sig_typext(id, ext, es, vis) -> + SigL_typext(id, ext, es, vis) + | Sig_module(id, res, d, rs, vis) -> + SigL_module(id, res, lazy_module_decl d, rs, vis) + | Sig_modtype(id, d, vis) -> + SigL_modtype(id, lazy_modtype_decl d, vis) + | Sig_class(id, d, rs, vis) -> + SigL_class(id, d, rs, vis) + | Sig_class_type(id, d, rs, vis) -> + SigL_class_type(id, d, rs, vis) + +and subst_lazy_signature_item' copy_scope scoping s comp = + match comp with + SigL_value(id, d, vis) -> + SigL_value(id, value_description' copy_scope s d, vis) + | SigL_type(id, d, rs, vis) -> + SigL_type(id, type_declaration' copy_scope s d, rs, vis) + | SigL_typext(id, ext, es, vis) -> + SigL_typext(id, extension_constructor' copy_scope s ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + SigL_module(id, pres, subst_lazy_module_decl scoping s d, rs, vis) + | SigL_modtype(id, d, vis) -> + SigL_modtype(id, subst_lazy_modtype_decl scoping s d, vis) + | SigL_class(id, d, rs, vis) -> + SigL_class(id, class_declaration' copy_scope s d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> + SigL_class_type(id, cltype_declaration' copy_scope s d, rs, vis) + +and force_signature_item = function + | SigL_value(id, vd, vis) -> Sig_value(id, vd, vis) + | SigL_type(id, d, rs, vis) -> Sig_type(id, d, rs, vis) + | SigL_typext(id, ext, es, vis) -> Sig_typext(id, ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + Sig_module(id, pres, force_module_decl d, rs, vis) + | SigL_modtype(id, d, vis) -> + Sig_modtype (id, force_modtype_decl d, vis) + | SigL_class(id, d, rs, vis) -> Sig_class(id, d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> Sig_class_type(id, d, rs, vis) + +and modtype scoping s t = + t |> lazy_modtype |> subst_lazy_modtype scoping s |> force_modtype + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) + +and compose s1 s2 = + if s1 == identity then s2 else + if s2 == identity then s1 else + { types = merge_path_maps (type_replacement s2) s1.types s2.types; + modules = merge_path_maps (module_path s2) s1.modules s2.modules; + modtypes = merge_path_maps (modtype Keep s2) s1.modtypes s2.modtypes; + for_saving = s1.for_saving || s2.for_saving; + loc = keep_latest_loc s1.loc s2.loc; + } + + +let subst_lazy_signature_item scoping s comp = + For_copy.with_scope + (fun copy_scope -> subst_lazy_signature_item' copy_scope scoping s comp) + +module Lazy = struct + include Lazy_types + + let of_module_decl = lazy_module_decl + let of_modtype = lazy_modtype + let of_modtype_decl = lazy_modtype_decl + let of_signature sg = Lazy_backtrack.create_forced (S_eager sg) + let of_signature_items sg = Lazy_backtrack.create_forced (S_lazy sg) + let of_signature_item = lazy_signature_item + + let module_decl = subst_lazy_module_decl + let modtype = subst_lazy_modtype + let modtype_decl = subst_lazy_modtype_decl + let signature = subst_lazy_signature + let signature_item = subst_lazy_signature_item + + let force_module_decl = force_module_decl + let force_modtype = force_modtype + let force_modtype_decl = force_modtype_decl + let force_signature = force_signature + let force_signature_once = force_signature_once + let force_signature_item = force_signature_item +end + +let signature sc s sg = + Lazy.(sg |> of_signature |> signature sc s |> force_signature) + +let signature_item sc s comp = + Lazy.(comp|> of_signature_item |> signature_item sc s |> force_signature_item) + +let modtype_declaration sc s decl = + Lazy.(decl |> of_modtype_decl |> modtype_decl sc s |> force_modtype_decl) + +let module_declaration scoping s decl = + Lazy.(decl |> of_module_decl |> module_decl scoping s |> force_module_decl) diff --git a/upstream/ocaml_503/typing/subst.mli b/upstream/ocaml_503/typing/subst.mli new file mode 100644 index 000000000..8812d2a51 --- /dev/null +++ b/upstream/ocaml_503/typing/subst.mli @@ -0,0 +1,147 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Substitutions *) + +open Types + +type t + +(* + Substitutions are used to translate a type from one context to + another. This requires substituting paths for identifiers, and + possibly also lowering the level of non-generic variables so that + they are inferior to the maximum level of the new context. + + Substitutions can also be used to create a "clean" copy of a type. + Indeed, non-variable node of a type are duplicated, with their + levels set to generic level. That way, the resulting type is + well-formed (decreasing levels), even if the original one was not. +*) + +val identity: t + +val add_type: Ident.t -> Path.t -> t -> t +val add_type_path: Path.t -> Path.t -> t -> t +val add_type_function: + Path.t -> params:type_expr list -> body:type_expr -> t -> t +val add_module: Ident.t -> Path.t -> t -> t +val add_module_path: Path.t -> Path.t -> t -> t +val add_modtype: Ident.t -> module_type -> t -> t +val add_modtype_path: Path.t -> module_type -> t -> t + +val for_saving: t -> t +val reset_for_saving: unit -> unit +val change_locs: t -> Location.t -> t + +val module_path: t -> Path.t -> Path.t +val type_path: t -> Path.t -> Path.t +val modtype_path: t -> Path.t -> Path.t + +val type_expr: t -> type_expr -> type_expr +val class_type: t -> class_type -> class_type +val value_description: t -> value_description -> value_description +val type_declaration: t -> type_declaration -> type_declaration +val extension_constructor: + t -> extension_constructor -> extension_constructor +val class_declaration: t -> class_declaration -> class_declaration +val cltype_declaration: t -> class_type_declaration -> class_type_declaration + +(* + When applied to a signature item, a substitution not only modifies the types + present in its declaration, but also refreshes the identifier of the item. + Effectively this creates new declarations, and so one should decide what the + scope of this new declaration should be. + + This is decided by the [scoping] argument passed to the following functions. +*) + +type scoping = + | Keep + | Make_local + | Rescope of int + +val modtype: scoping -> t -> module_type -> module_type +val signature: scoping -> t -> signature -> signature +val signature_item: scoping -> t -> signature_item -> signature_item +val modtype_declaration: + scoping -> t -> modtype_declaration -> modtype_declaration +val module_declaration: scoping -> t -> module_declaration -> module_declaration + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) +val compose: t -> t -> t + +module Lazy : sig + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + + and modtype_declaration = + { + mtdl_type: modtype option; (* Note: abstract *) + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + + + val of_module_decl : Types.module_declaration -> module_decl + val of_modtype : Types.module_type -> modtype + val of_modtype_decl : Types.modtype_declaration -> modtype_declaration + val of_signature : Types.signature -> signature + val of_signature_items : signature_item list -> signature + val of_signature_item : Types.signature_item -> signature_item + + val module_decl : scoping -> t -> module_decl -> module_decl + val modtype : scoping -> t -> modtype -> modtype + val modtype_decl : scoping -> t -> modtype_declaration -> modtype_declaration + val signature : scoping -> t -> signature -> signature + val signature_item : scoping -> t -> signature_item -> signature_item + + val force_module_decl : module_decl -> Types.module_declaration + val force_modtype : modtype -> Types.module_type + val force_modtype_decl : modtype_declaration -> Types.modtype_declaration + val force_signature : signature -> Types.signature + val force_signature_once : signature -> signature_item list + val force_signature_item : signature_item -> Types.signature_item +end diff --git a/upstream/ocaml_503/typing/tast_iterator.ml b/upstream/ocaml_503/typing/tast_iterator.ml new file mode 100644 index 000000000..6ec345d5b --- /dev/null +++ b/upstream/ocaml_503/typing/tast_iterator.ml @@ -0,0 +1,695 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Isaac "Izzy" Avram *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +type iterator = + { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; + binding_op: iterator -> binding_op -> unit; + case: 'k . iterator -> 'k case -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: 'k . iterator -> 'k general_pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> (rec_flag * value_binding list) -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; + item_declaration: iterator -> item_declaration -> unit; + } + +let iter_snd f (_, y) = f y +let iter_loc sub {loc; _} = sub.location sub loc + +let location _sub _l = () + +let attribute sub x = + let iterator = { + Ast_iterator.default_iterator + with location = fun _this x -> sub.location sub x + } in + iter_loc sub x.Parsetree.attr_name; + iterator.payload iterator x.Parsetree.attr_payload; + sub.location sub x.Parsetree.attr_loc + +let attributes sub l = List.iter (attribute sub) l + +let structure sub {str_items; str_final_env; _} = + List.iter (sub.structure_item sub) str_items; + sub.env sub str_final_env + +let class_infos sub f x = + sub.location sub x.ci_loc; + sub.attributes sub x.ci_attributes; + iter_loc sub x.ci_id_name; + List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params; + f x.ci_expr + +let module_type_declaration sub x = + sub.item_declaration sub (Module_type x); + sub.location sub x.mtd_loc; + sub.attributes sub x.mtd_attributes; + iter_loc sub x.mtd_name; + Option.iter (sub.module_type sub) x.mtd_type + +let module_declaration sub md = + let {md_loc; md_name; md_type; md_attributes; _} = md in + sub.item_declaration sub (Module md); + sub.location sub md_loc; + sub.attributes sub md_attributes; + iter_loc sub md_name; + sub.module_type sub md_type + +let module_substitution sub ms = + let {ms_loc; ms_name; ms_txt; ms_attributes; _} = ms in + sub.item_declaration sub (Module_substitution ms); + sub.location sub ms_loc; + sub.attributes sub ms_attributes; + iter_loc sub ms_name; + iter_loc sub ms_txt + +let include_infos sub f {incl_loc; incl_mod; incl_attributes; _} = + sub.location sub incl_loc; + sub.attributes sub incl_attributes; + f incl_mod + +let class_type_declaration sub x = + sub.item_declaration sub (Class_type x); + class_infos sub (sub.class_type sub) x + +let class_declaration sub x = + sub.item_declaration sub (Class x); + class_infos sub (sub.class_expr sub) x + +let structure_item sub {str_loc; str_desc; str_env; _} = + sub.location sub str_loc; + sub.env sub str_env; + match str_desc with + | Tstr_eval (exp, attrs) -> sub.expr sub exp; sub.attributes sub attrs + | Tstr_value (rec_flag, list) -> sub.value_bindings sub (rec_flag, list) + | Tstr_primitive v -> sub.value_description sub v + | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list) + | Tstr_typext te -> sub.type_extension sub te + | Tstr_exception ext -> sub.type_exception sub ext + | Tstr_module mb -> sub.module_binding sub mb + | Tstr_recmodule list -> List.iter (sub.module_binding sub) list + | Tstr_modtype x -> sub.module_type_declaration sub x + | Tstr_class list -> + List.iter (fun (cls,_) -> sub.class_declaration sub cls) list + | Tstr_class_type list -> + List.iter (fun (_, s, cltd) -> + iter_loc sub s; sub.class_type_declaration sub cltd) list + | Tstr_include incl -> include_infos sub (sub.module_expr sub) incl + | Tstr_open od -> sub.open_declaration sub od + | Tstr_attribute attr -> sub.attribute sub attr + +let value_description sub x = + sub.item_declaration sub (Value x); + sub.location sub x.val_loc; + sub.attributes sub x.val_attributes; + iter_loc sub x.val_name; + sub.typ sub x.val_desc + +let label_decl sub ({ld_loc; ld_name; ld_type; ld_attributes; _} as ld) = + sub.item_declaration sub (Label ld); + sub.location sub ld_loc; + sub.attributes sub ld_attributes; + iter_loc sub ld_name; + sub.typ sub ld_type + +let constructor_args sub = function + | Cstr_tuple l -> List.iter (sub.typ sub) l + | Cstr_record l -> List.iter (label_decl sub) l + +let constructor_decl sub x = + sub.item_declaration sub (Constructor x); + sub.location sub x.cd_loc; + sub.attributes sub x.cd_attributes; + iter_loc sub x.cd_name; + List.iter (iter_loc sub) x.cd_vars; + constructor_args sub x.cd_args; + Option.iter (sub.typ sub) x.cd_res + +let type_kind sub = function + | Ttype_abstract -> () + | Ttype_variant list -> List.iter (constructor_decl sub) list + | Ttype_record list -> List.iter (label_decl sub) list + | Ttype_open -> () + +let type_declaration sub x = + sub.item_declaration sub (Type x); + sub.location sub x.typ_loc; + sub.attributes sub x.typ_attributes; + iter_loc sub x.typ_name; + List.iter + (fun (c1, c2, loc) -> + sub.typ sub c1; + sub.typ sub c2; + sub.location sub loc) + x.typ_cstrs; + sub.type_kind sub x.typ_kind; + Option.iter (sub.typ sub) x.typ_manifest; + List.iter (fun (c, _) -> sub.typ sub c) x.typ_params + +let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list + +let type_extension sub x = + sub.location sub x.tyext_loc; + sub.attributes sub x.tyext_attributes; + iter_loc sub x.tyext_txt; + List.iter (fun (c, _) -> sub.typ sub c) x.tyext_params; + List.iter (sub.extension_constructor sub) x.tyext_constructors + +let type_exception sub {tyexn_loc; tyexn_constructor; tyexn_attributes; _} = + sub.location sub tyexn_loc; + sub.attributes sub tyexn_attributes; + sub.extension_constructor sub tyexn_constructor + +let extension_constructor sub ec = + let {ext_loc; ext_name; ext_kind; ext_attributes; _} = ec in + sub.item_declaration sub (Extension_constructor ec); + sub.location sub ext_loc; + sub.attributes sub ext_attributes; + iter_loc sub ext_name; + match ext_kind with + | Text_decl (ids, ctl, cto) -> + List.iter (iter_loc sub) ids; + constructor_args sub ctl; + Option.iter (sub.typ sub) cto + | Text_rebind (_, lid) -> iter_loc sub lid + +let pat_extra sub (e, loc, attrs) = + sub.location sub loc; + sub.attributes sub attrs; + match e with + | Tpat_type (_, lid) -> iter_loc sub lid + | Tpat_unpack -> () + | Tpat_open (_, lid, env) -> iter_loc sub lid; sub.env sub env + | Tpat_constraint ct -> sub.typ sub ct + +let pat + : type k . iterator -> k general_pattern -> unit + = fun sub {pat_loc; pat_extra=extra; pat_desc; pat_env; pat_attributes; _} -> + sub.location sub pat_loc; + sub.attributes sub pat_attributes; + sub.env sub pat_env; + List.iter (pat_extra sub) extra; + match pat_desc with + | Tpat_any -> () + | Tpat_var (_, s, _) -> iter_loc sub s + | Tpat_constant _ -> () + | Tpat_tuple l -> List.iter (sub.pat sub) l + | Tpat_construct (lid, _, l, vto) -> + iter_loc sub lid; + List.iter (sub.pat sub) l; + Option.iter (fun (ids, ct) -> + List.iter (iter_loc sub) ids; sub.typ sub ct) vto + | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po + | Tpat_record (l, _) -> + List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l + | Tpat_array l -> List.iter (sub.pat sub) l + | Tpat_alias (p, _, s, _) -> sub.pat sub p; iter_loc sub s + | Tpat_lazy p -> sub.pat sub p + | Tpat_value p -> sub.pat sub (p :> pattern) + | Tpat_exception p -> sub.pat sub p + | Tpat_or (p1, p2, _) -> + sub.pat sub p1; + sub.pat sub p2 + +let extra sub = function + | Texp_constraint cty -> sub.typ sub cty + | Texp_coerce (cty1, cty2) -> + Option.iter (sub.typ sub) cty1; + sub.typ sub cty2 + | Texp_newtype _ -> () + | Texp_poly cto -> Option.iter (sub.typ sub) cto + +let function_param sub fp = + sub.location sub fp.fp_loc; + match fp.fp_kind with + | Tparam_pat pat -> sub.pat sub pat + | Tparam_optional_default (pat, default_arg) -> + sub.pat sub pat; + sub.expr sub default_arg + +let function_body sub body = + match[@warning "+9"] body with + | Tfunction_body body -> + sub.expr sub body + | Tfunction_cases + { cases; loc; exp_extra; attributes; partial = _; param = _ } + -> + List.iter (sub.case sub) cases; + sub.location sub loc; + Option.iter (extra sub) exp_extra; + sub.attributes sub attributes + +let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = + let extra x = extra sub x in + sub.location sub exp_loc; + sub.attributes sub exp_attributes; + List.iter (fun (e, loc, _) -> extra e; sub.location sub loc) exp_extra; + sub.env sub exp_env; + match exp_desc with + | Texp_ident (_, lid, _) -> iter_loc sub lid + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + sub.value_bindings sub (rec_flag, list); + sub.expr sub exp + | Texp_function (params, body) -> + List.iter (function_param sub) params; + function_body sub body + | Texp_apply (exp, list) -> + sub.expr sub exp; + List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list + | Texp_match (exp, cases, effs, _) -> + sub.expr sub exp; + List.iter (sub.case sub) cases; + List.iter (sub.case sub) effs + | Texp_try (exp, cases, effs) -> + sub.expr sub exp; + List.iter (sub.case sub) cases; + List.iter (sub.case sub) effs + | Texp_tuple list -> List.iter (sub.expr sub) list + | Texp_construct (lid, _, args) -> + iter_loc sub lid; + List.iter (sub.expr sub) args + | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo + | Texp_record { fields; extended_expression; _} -> + Array.iter (function + | _, Kept _ -> () + | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) + fields; + Option.iter (sub.expr sub) extended_expression; + | Texp_field (exp, lid, _) -> + iter_loc sub lid; + sub.expr sub exp + | Texp_setfield (exp1, lid, _, exp2) -> + iter_loc sub lid; + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_array list -> List.iter (sub.expr sub) list + | Texp_ifthenelse (exp1, exp2, expo) -> + sub.expr sub exp1; + sub.expr sub exp2; + Option.iter (sub.expr sub) expo + | Texp_sequence (exp1, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_while (exp1, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_for (_, _, exp1, exp2, _, exp3) -> + sub.expr sub exp1; + sub.expr sub exp2; + sub.expr sub exp3 + | Texp_send (exp, _) -> + sub.expr sub exp + | Texp_new (_, lid, _) -> iter_loc sub lid + | Texp_instvar (_, _, s) -> iter_loc sub s + | Texp_setinstvar (_, _, s, exp) -> + iter_loc sub s; + sub.expr sub exp + | Texp_override (_, list) -> + List.iter (fun (_, s, e) -> iter_loc sub s; sub.expr sub e) list + | Texp_letmodule (_, s, _, mexpr, exp) -> + iter_loc sub s; + sub.module_expr sub mexpr; + sub.expr sub exp + | Texp_letexception (cd, exp) -> + sub.extension_constructor sub cd; + sub.expr sub exp + | Texp_assert (exp, _) -> sub.expr sub exp + | Texp_lazy exp -> sub.expr sub exp + | Texp_object (cl, _) -> sub.class_structure sub cl + | Texp_pack mexpr -> sub.module_expr sub mexpr + | Texp_letop {let_ = l; ands; body; _} -> + sub.binding_op sub l; + List.iter (sub.binding_op sub) ands; + sub.case sub body + | Texp_unreachable -> () + | Texp_extension_constructor (lid, _) -> iter_loc sub lid + | Texp_open (od, e) -> + sub.open_declaration sub od; + sub.expr sub e + + +let package_type sub {pack_fields; pack_txt; _} = + List.iter (fun (lid, p) -> iter_loc sub lid; sub.typ sub p) pack_fields; + iter_loc sub pack_txt + +let binding_op sub {bop_loc; bop_op_name; bop_exp; _} = + sub.location sub bop_loc; + iter_loc sub bop_op_name; + sub.expr sub bop_exp + +let signature sub {sig_items; sig_final_env; _} = + sub.env sub sig_final_env; + List.iter (sub.signature_item sub) sig_items + +let signature_item sub {sig_loc; sig_desc; sig_env; _} = + sub.location sub sig_loc; + sub.env sub sig_env; + match sig_desc with + | Tsig_value v -> sub.value_description sub v + | Tsig_type (rf, tdl) -> sub.type_declarations sub (rf, tdl) + | Tsig_typesubst list -> sub.type_declarations sub (Nonrecursive, list) + | Tsig_typext te -> sub.type_extension sub te + | Tsig_exception ext -> sub.type_exception sub ext + | Tsig_module x -> sub.module_declaration sub x + | Tsig_modsubst x -> sub.module_substitution sub x + | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list + | Tsig_modtype x -> sub.module_type_declaration sub x + | Tsig_modtypesubst x -> sub.module_type_declaration sub x + | Tsig_include incl -> include_infos sub (sub.module_type sub) incl + | Tsig_class list -> List.iter (sub.class_description sub) list + | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list + | Tsig_open od -> sub.open_description sub od + | Tsig_attribute _ -> () + +let class_description sub x = + sub.item_declaration sub (Class_type x); + class_infos sub (sub.class_type sub) x + +let functor_parameter sub = function + | Unit -> () + | Named (_, s, mtype) -> iter_loc sub s; sub.module_type sub mtype + +let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = + sub.location sub mty_loc; + sub.attributes sub mty_attributes; + sub.env sub mty_env; + match mty_desc with + | Tmty_ident (_, lid) -> iter_loc sub lid + | Tmty_alias (_, lid) -> iter_loc sub lid + | Tmty_signature sg -> sub.signature sub sg + | Tmty_functor (arg, mtype2) -> + functor_parameter sub arg; + sub.module_type sub mtype2 + | Tmty_with (mtype, list) -> + sub.module_type sub mtype; + List.iter (fun (_, lid, e) -> + iter_loc sub lid; sub.with_constraint sub e) list + | Tmty_typeof mexpr -> sub.module_expr sub mexpr + +let with_constraint sub = function + | Twith_type decl -> sub.type_declaration sub decl + | Twith_typesubst decl -> sub.type_declaration sub decl + | Twith_module (_, lid) -> iter_loc sub lid + | Twith_modsubst (_, lid) -> iter_loc sub lid + | Twith_modtype mty -> sub.module_type sub mty + | Twith_modtypesubst mty -> sub.module_type sub mty + + +let open_description sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + iter_snd (iter_loc sub) open_expr; + sub.env sub open_env + +let open_declaration sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + sub.module_expr sub open_expr; + sub.env sub open_env + +let module_coercion sub = function + | Tcoerce_none -> () + | Tcoerce_functor (c1,c2) -> + sub.module_coercion sub c1; + sub.module_coercion sub c2 + | Tcoerce_alias (env, _, c1) -> + sub.env sub env; + sub.module_coercion sub c1 + | Tcoerce_structure (l1, l2) -> + List.iter (fun (_, c) -> sub.module_coercion sub c) l1; + List.iter (fun (_, _ ,c) -> sub.module_coercion sub c) l2 + | Tcoerce_primitive {pc_loc; pc_env; _} -> + sub.location sub pc_loc; + sub.env sub pc_env + +let module_expr sub {mod_loc; mod_desc; mod_env; mod_attributes; _} = + sub.location sub mod_loc; + sub.attributes sub mod_attributes; + sub.env sub mod_env; + match mod_desc with + | Tmod_ident (_, lid) -> iter_loc sub lid + | Tmod_structure st -> sub.structure sub st + | Tmod_functor (arg, mexpr) -> + functor_parameter sub arg; + sub.module_expr sub mexpr + | Tmod_apply (mexp1, mexp2, c) -> + sub.module_expr sub mexp1; + sub.module_expr sub mexp2; + sub.module_coercion sub c + | Tmod_apply_unit mexp1 -> + sub.module_expr sub mexp1; + | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) -> + sub.module_expr sub mexpr; + sub.module_coercion sub c + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) -> + sub.module_expr sub mexpr; + sub.module_type sub mtype; + sub.module_coercion sub c + | Tmod_unpack (exp, _) -> sub.expr sub exp + +let module_binding sub ({mb_loc; mb_name; mb_expr; mb_attributes; _} as mb) = + sub.item_declaration sub (Module_binding mb); + sub.location sub mb_loc; + sub.attributes sub mb_attributes; + iter_loc sub mb_name; + sub.module_expr sub mb_expr + +let class_expr sub {cl_loc; cl_desc; cl_env; cl_attributes; _} = + sub.location sub cl_loc; + sub.attributes sub cl_attributes; + sub.env sub cl_env; + match cl_desc with + | Tcl_constraint (cl, clty, _, _, _) -> + sub.class_expr sub cl; + Option.iter (sub.class_type sub) clty + | Tcl_structure clstr -> sub.class_structure sub clstr + | Tcl_fun (_, pat, priv, cl, _) -> + sub.pat sub pat; + List.iter (fun (_, e) -> sub.expr sub e) priv; + sub.class_expr sub cl + | Tcl_apply (cl, args) -> + sub.class_expr sub cl; + List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args + | Tcl_let (rec_flag, value_bindings, ivars, cl) -> + sub.value_bindings sub (rec_flag, value_bindings); + List.iter (fun (_, e) -> sub.expr sub e) ivars; + sub.class_expr sub cl + | Tcl_ident (_, lid, tyl) -> + iter_loc sub lid; + List.iter (sub.typ sub) tyl + | Tcl_open (od, e) -> + sub.open_description sub od; + sub.class_expr sub e + +let class_type sub {cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes; _} = + sub.location sub cltyp_loc; + sub.attributes sub cltyp_attributes; + sub.env sub cltyp_env; + match cltyp_desc with + | Tcty_signature csg -> sub.class_signature sub csg + | Tcty_constr (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list + | Tcty_arrow (_, ct, cl) -> + sub.typ sub ct; + sub.class_type sub cl + | Tcty_open (od, e) -> + sub.open_description sub od; + sub.class_type sub e + +let class_signature sub {csig_self; csig_fields; _} = + sub.typ sub csig_self; + List.iter (sub.class_type_field sub) csig_fields + +let class_type_field sub {ctf_loc; ctf_desc; ctf_attributes; _} = + sub.location sub ctf_loc; + sub.attributes sub ctf_attributes; + match ctf_desc with + | Tctf_inherit ct -> sub.class_type sub ct + | Tctf_val (_, _, _, ct) -> sub.typ sub ct + | Tctf_method (_, _, _, ct) -> sub.typ sub ct + | Tctf_constraint (ct1, ct2) -> + sub.typ sub ct1; + sub.typ sub ct2 + | Tctf_attribute attr -> sub.attribute sub attr + +let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = + sub.location sub ctyp_loc; + sub.attributes sub ctyp_attributes; + sub.env sub ctyp_env; + match ctyp_desc with + | Ttyp_any -> () + | Ttyp_var _ -> () + | Ttyp_arrow (_, ct1, ct2) -> + sub.typ sub ct1; + sub.typ sub ct2 + | Ttyp_tuple list -> List.iter (sub.typ sub) list + | Ttyp_constr (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list + | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list + | Ttyp_class (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list + | Ttyp_alias (ct, _) -> sub.typ sub ct + | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list + | Ttyp_poly (_, ct) -> sub.typ sub ct + | Ttyp_package pack -> sub.package_type sub pack + | Ttyp_open (_, mod_ident, t) -> + iter_loc sub mod_ident; + sub.typ sub t + +let class_structure sub {cstr_self; cstr_fields; _} = + sub.pat sub cstr_self; + List.iter (sub.class_field sub) cstr_fields + +let row_field sub {rf_loc; rf_desc; rf_attributes; _} = + sub.location sub rf_loc; + sub.attributes sub rf_attributes; + match rf_desc with + | Ttag (s, _, list) -> iter_loc sub s; List.iter (sub.typ sub) list + | Tinherit ct -> sub.typ sub ct + +let object_field sub {of_loc; of_desc; of_attributes; _} = + sub.location sub of_loc; + sub.attributes sub of_attributes; + match of_desc with + | OTtag (s, ct) -> iter_loc sub s; sub.typ sub ct + | OTinherit ct -> sub.typ sub ct + +let class_field_kind sub = function + | Tcfk_virtual ct -> sub.typ sub ct + | Tcfk_concrete (_, e) -> sub.expr sub e + +let class_field sub {cf_loc; cf_desc; cf_attributes; _} = + sub.location sub cf_loc; + sub.attributes sub cf_attributes; + match cf_desc with + | Tcf_inherit (_, cl, _, _, _) -> sub.class_expr sub cl + | Tcf_constraint (cty1, cty2) -> + sub.typ sub cty1; + sub.typ sub cty2 + | Tcf_val (s, _, _, k, _) -> iter_loc sub s; class_field_kind sub k + | Tcf_method (s, _, k) -> iter_loc sub s;class_field_kind sub k + | Tcf_initializer exp -> sub.expr sub exp + | Tcf_attribute attr -> sub.attribute sub attr + +let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list + +let case sub {c_lhs; c_guard; c_rhs} = + sub.pat sub c_lhs; + Option.iter (sub.expr sub) c_guard; + sub.expr sub c_rhs + +let value_binding sub ({vb_loc; vb_pat; vb_expr; vb_attributes; _} as vb) = + sub.item_declaration sub (Value_binding vb); + sub.location sub vb_loc; + sub.attributes sub vb_attributes; + sub.pat sub vb_pat; + sub.expr sub vb_expr + +let env _sub _ = () + +let item_declaration _sub _ = () + +let default_iterator = + { + attribute; + attributes; + binding_op; + case; + class_declaration; + class_description; + class_expr; + class_field; + class_signature; + class_structure; + class_type; + class_type_declaration; + class_type_field; + env; + expr; + extension_constructor; + location; + module_binding; + module_coercion; + module_declaration; + module_substitution; + module_expr; + module_type; + module_type_declaration; + package_type; + pat; + row_field; + object_field; + open_declaration; + open_description; + signature; + signature_item; + structure; + structure_item; + typ; + type_declaration; + type_declarations; + type_extension; + type_exception; + type_kind; + value_binding; + value_bindings; + value_description; + with_constraint; + item_declaration; + } diff --git a/upstream/ocaml_503/typing/tast_iterator.mli b/upstream/ocaml_503/typing/tast_iterator.mli new file mode 100644 index 000000000..38cd4eac9 --- /dev/null +++ b/upstream/ocaml_503/typing/tast_iterator.mli @@ -0,0 +1,72 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Isaac "Izzy" Avram *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** +Allows the implementation of typed tree inspection using open recursion +*) + +open Asttypes +open Typedtree + +type iterator = + { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; + binding_op: iterator -> binding_op -> unit; + case: 'k . iterator -> 'k case -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: 'k . iterator -> 'k general_pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> (rec_flag * value_binding list) -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; + item_declaration: iterator -> item_declaration -> unit; + } + +val default_iterator: iterator diff --git a/upstream/ocaml_503/typing/tast_mapper.ml b/upstream/ocaml_503/typing/tast_mapper.ml new file mode 100644 index 000000000..05b7a66ce --- /dev/null +++ b/upstream/ocaml_503/typing/tast_mapper.ml @@ -0,0 +1,912 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +(* TODO: add 'methods' for extension, + include_declaration, include_description *) + +type mapper = + { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; + binding_op: mapper -> binding_op -> binding_op; + case: 'k . mapper -> 'k case -> 'k case; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + class_signature: mapper -> class_signature -> class_signature; + class_structure: mapper -> class_structure -> class_structure; + class_type: mapper -> class_type -> class_type; + class_type_declaration: mapper -> class_type_declaration -> + class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: mapper -> extension_constructor -> + extension_constructor; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + module_declaration: mapper -> module_declaration -> module_declaration; + module_substitution: mapper -> module_substitution -> module_substitution; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + package_type: mapper -> package_type -> package_type; + pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern; + row_field: mapper -> row_field -> row_field; + object_field: mapper -> object_field -> object_field; + open_declaration: mapper -> open_declaration -> open_declaration; + open_description: mapper -> open_description -> open_description; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: mapper -> (rec_flag * type_declaration list) + -> (rec_flag * type_declaration list); + type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: mapper -> (rec_flag * value_binding list) -> + (rec_flag * value_binding list); + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; + } + +let id x = x +let tuple2 f1 f2 (x, y) = (f1 x, f2 y) +let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_loc sub {loc; txt} = {loc=sub.location sub loc; txt} + +let location _sub l = l + +let attribute sub x = + let mapper = { + Ast_mapper.default_mapper + with location = fun _this x -> sub.location sub x + } in + Parsetree.{ + attr_name = map_loc sub x.attr_name; + attr_payload = mapper.payload mapper x.attr_payload; + attr_loc = sub.location sub x.attr_loc + } + +let attributes sub l = List.map (attribute sub) l + +let structure sub {str_items; str_type; str_final_env} = + { + str_items = List.map (sub.structure_item sub) str_items; + str_final_env = sub.env sub str_final_env; + str_type; + } + +let class_infos sub f x = + {x with + ci_loc = sub.location sub x.ci_loc; + ci_id_name = map_loc sub x.ci_id_name; + ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; + ci_expr = f x.ci_expr; + ci_attributes = sub.attributes sub x.ci_attributes; + } + +let module_type_declaration sub x = + let mtd_loc = sub.location sub x.mtd_loc in + let mtd_name = map_loc sub x.mtd_name in + let mtd_type = Option.map (sub.module_type sub) x.mtd_type in + let mtd_attributes = sub.attributes sub x.mtd_attributes in + {x with mtd_loc; mtd_name; mtd_type; mtd_attributes} + +let module_declaration sub x = + let md_loc = sub.location sub x.md_loc in + let md_name = map_loc sub x.md_name in + let md_type = sub.module_type sub x.md_type in + let md_attributes = sub.attributes sub x.md_attributes in + {x with md_loc; md_name; md_type; md_attributes} + +let module_substitution sub x = + let ms_loc = sub.location sub x.ms_loc in + let ms_name = map_loc sub x.ms_name in + let ms_txt = map_loc sub x.ms_txt in + let ms_attributes = sub.attributes sub x.ms_attributes in + {x with ms_loc; ms_name; ms_txt; ms_attributes} + +let include_infos sub f x = + let incl_loc = sub.location sub x.incl_loc in + let incl_attributes = sub.attributes sub x.incl_attributes in + {x with incl_loc; incl_attributes; incl_mod = f x.incl_mod} + +let class_type_declaration sub x = + class_infos sub (sub.class_type sub) x + +let class_declaration sub x = + class_infos sub (sub.class_expr sub) x + +let structure_item sub {str_loc; str_desc; str_env} = + let str_loc = sub.location sub str_loc in + let str_env = sub.env sub str_env in + let str_desc = + match str_desc with + | Tstr_eval (exp, attrs) -> + Tstr_eval (sub.expr sub exp, sub.attributes sub attrs) + | Tstr_value (rec_flag, list) -> + let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in + Tstr_value (rec_flag, list) + | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v) + | Tstr_type (rec_flag, list) -> + let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in + Tstr_type (rec_flag, list) + | Tstr_typext te -> Tstr_typext (sub.type_extension sub te) + | Tstr_exception ext -> Tstr_exception (sub.type_exception sub ext) + | Tstr_module mb -> Tstr_module (sub.module_binding sub mb) + | Tstr_recmodule list -> + Tstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x) + | Tstr_class list -> + Tstr_class + (List.map (tuple2 (sub.class_declaration sub) id) list) + | Tstr_class_type list -> + Tstr_class_type + (List.map (tuple3 + id (map_loc sub) (sub.class_type_declaration sub)) list) + | Tstr_include incl -> + Tstr_include (include_infos sub (sub.module_expr sub) incl) + | Tstr_open od -> Tstr_open (sub.open_declaration sub od) + | Tstr_attribute attr -> Tstr_attribute (sub.attribute sub attr) + in + {str_desc; str_env; str_loc} + +let value_description sub x = + let val_loc = sub.location sub x.val_loc in + let val_name = map_loc sub x.val_name in + let val_desc = sub.typ sub x.val_desc in + let val_attributes = sub.attributes sub x.val_attributes in + {x with val_loc; val_name; val_desc; val_attributes} + +let label_decl sub x = + let ld_loc = sub.location sub x.ld_loc in + let ld_name = map_loc sub x.ld_name in + let ld_type = sub.typ sub x.ld_type in + let ld_attributes = sub.attributes sub x.ld_attributes in + {x with ld_loc; ld_name; ld_type; ld_attributes} + +let constructor_args sub = function + | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Cstr_record (List.map (label_decl sub) l) + +let constructor_decl sub cd = + let cd_loc = sub.location sub cd.cd_loc in + let cd_name = map_loc sub cd.cd_name in + let cd_vars = List.map (map_loc sub) cd.cd_vars in + let cd_args = constructor_args sub cd.cd_args in + let cd_res = Option.map (sub.typ sub) cd.cd_res in + let cd_attributes = sub.attributes sub cd.cd_attributes in + {cd with cd_loc; cd_name; cd_vars; cd_args; cd_res; cd_attributes} + +let type_kind sub = function + | Ttype_abstract -> Ttype_abstract + | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list) + | Ttype_record list -> Ttype_record (List.map (label_decl sub) list) + | Ttype_open -> Ttype_open + +let type_declaration sub x = + let typ_loc = sub.location sub x.typ_loc in + let typ_name = map_loc sub x.typ_name in + let typ_cstrs = + List.map + (tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + x.typ_cstrs + in + let typ_kind = sub.type_kind sub x.typ_kind in + let typ_manifest = Option.map (sub.typ sub) x.typ_manifest in + let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in + let typ_attributes = sub.attributes sub x.typ_attributes in + {x with typ_loc; typ_name; typ_cstrs; typ_kind; typ_manifest; typ_params; + typ_attributes} + +let type_declarations sub (rec_flag, list) = + (rec_flag, List.map (sub.type_declaration sub) list) + +let type_extension sub x = + let tyext_loc = sub.location sub x.tyext_loc in + let tyext_txt = map_loc sub x.tyext_txt in + let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in + let tyext_constructors = + List.map (sub.extension_constructor sub) x.tyext_constructors + in + let tyext_attributes = sub.attributes sub x.tyext_attributes in + {x with tyext_loc; tyext_txt; tyext_constructors; tyext_params; + tyext_attributes} + +let type_exception sub x = + let tyexn_loc = sub.location sub x.tyexn_loc in + let tyexn_constructor = + sub.extension_constructor sub x.tyexn_constructor + in + let tyexn_attributes = sub.attributes sub x.tyexn_attributes in + {tyexn_loc; tyexn_constructor; tyexn_attributes} + +let extension_constructor sub x = + let ext_loc = sub.location sub x.ext_loc in + let ext_name = map_loc sub x.ext_name in + let ext_kind = + match x.ext_kind with + Text_decl(ids, ctl, cto) -> + Text_decl( + List.map (map_loc sub) ids, + constructor_args sub ctl, + Option.map (sub.typ sub) cto + ) + | Text_rebind (path, lid) -> + Text_rebind (path, map_loc sub lid) + in + let ext_attributes = sub.attributes sub x.ext_attributes in + {x with ext_loc; ext_name; ext_kind; ext_attributes} + +let pat_extra sub = function + | Tpat_unpack as d -> d + | Tpat_type (path,loc) -> Tpat_type (path, map_loc sub loc) + | Tpat_open (path,loc,env) -> + Tpat_open (path, map_loc sub loc, sub.env sub env) + | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct) + +let pat + : type k . mapper -> k general_pattern -> k general_pattern + = fun sub x -> + let pat_loc = sub.location sub x.pat_loc in + let pat_env = sub.env sub x.pat_env in + let pat_extra = + List.map (tuple3 (pat_extra sub) id (sub.attributes sub)) x.pat_extra in + let pat_desc : k pattern_desc = + match x.pat_desc with + | Tpat_any + | Tpat_constant _ -> x.pat_desc + | Tpat_var (id, s, uid) -> Tpat_var (id, map_loc sub s, uid) + | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) + | Tpat_construct (loc, cd, l, vto) -> + let vto = Option.map (fun (vl,cty) -> + List.map (map_loc sub) vl, sub.typ sub cty) vto in + Tpat_construct (map_loc sub loc, cd, List.map (sub.pat sub) l, vto) + | Tpat_variant (l, po, rd) -> + Tpat_variant (l, Option.map (sub.pat sub) po, rd) + | Tpat_record (l, closed) -> + Tpat_record (List.map (tuple3 (map_loc sub) id (sub.pat sub)) l, closed) + | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) + | Tpat_alias (p, id, s, uid) -> + Tpat_alias (sub.pat sub p, id, map_loc sub s, uid) + | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) + | Tpat_value p -> + (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc + | Tpat_exception p -> + Tpat_exception (sub.pat sub p) + | Tpat_or (p1, p2, rd) -> + Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) + in + let pat_attributes = sub.attributes sub x.pat_attributes in + {x with pat_loc; pat_extra; pat_desc; pat_env; pat_attributes} + +let function_param sub fp = + let fp_kind = + match fp.fp_kind with + | Tparam_pat pat -> Tparam_pat (sub.pat sub pat) + | Tparam_optional_default (pat, expr) -> + let pat = sub.pat sub pat in + let expr = sub.expr sub expr in + Tparam_optional_default (pat, expr) + in + let fp_loc = sub.location sub fp.fp_loc in + { fp_kind; + fp_param = fp.fp_param; + fp_arg_label = fp.fp_arg_label; + fp_partial = fp.fp_partial; + fp_newtypes = fp.fp_newtypes; + fp_loc; + } + +let extra sub = function + | Texp_constraint cty -> + Texp_constraint (sub.typ sub cty) + | Texp_coerce (cty1, cty2) -> + Texp_coerce (Option.map (sub.typ sub) cty1, sub.typ sub cty2) + | Texp_newtype _ as d -> d + | Texp_poly cto -> Texp_poly (Option.map (sub.typ sub) cto) + +let function_body sub body = + match body with + | Tfunction_body body -> + Tfunction_body (sub.expr sub body) + | Tfunction_cases { cases; partial; param; loc; exp_extra; attributes } -> + let loc = sub.location sub loc in + let cases = List.map (sub.case sub) cases in + let exp_extra = Option.map (extra sub) exp_extra in + let attributes = sub.attributes sub attributes in + Tfunction_cases { cases; partial; param; loc; exp_extra; attributes } + +let expr sub x = + let extra x = extra sub x in + let exp_loc = sub.location sub x.exp_loc in + let exp_extra = List.map (tuple3 extra (sub.location sub) id) x.exp_extra in + let exp_env = sub.env sub x.exp_env in + let exp_desc = + match x.exp_desc with + | Texp_ident (path, lid, vd) -> + Texp_ident (path, map_loc sub lid, vd) + | Texp_constant _ as d -> d + | Texp_let (rec_flag, list, exp) -> + let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in + Texp_let (rec_flag, list, sub.expr sub exp) + | Texp_function (params, body) -> + let params = List.map (function_param sub) params in + let body = function_body sub body in + Texp_function (params, body) + | Texp_apply (exp, list) -> + Texp_apply ( + sub.expr sub exp, + List.map (tuple2 id (Option.map (sub.expr sub))) list + ) + | Texp_match (exp, cases, eff_cases, p) -> + Texp_match ( + sub.expr sub exp, + List.map (sub.case sub) cases, + List.map (sub.case sub) eff_cases, + p + ) + | Texp_try (exp, exn_cases, eff_cases) -> + Texp_try ( + sub.expr sub exp, + List.map (sub.case sub) exn_cases, + List.map (sub.case sub) eff_cases + ) + | Texp_tuple list -> + Texp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, cd, args) -> + Texp_construct (map_loc sub lid, cd, List.map (sub.expr sub) args) + | Texp_variant (l, expo) -> + Texp_variant (l, Option.map (sub.expr sub) expo) + | Texp_record { fields; representation; extended_expression } -> + let fields = Array.map (function + | label, Kept (t, mut) -> label, Kept (t, mut) + | label, Overridden (lid, exp) -> + label, Overridden (map_loc sub lid, sub.expr sub exp)) + fields + in + Texp_record { + fields; representation; + extended_expression = Option.map (sub.expr sub) extended_expression; + } + | Texp_field (exp, lid, ld) -> + Texp_field (sub.expr sub exp, map_loc sub lid, ld) + | Texp_setfield (exp1, lid, ld, exp2) -> + Texp_setfield ( + sub.expr sub exp1, + map_loc sub lid, + ld, + sub.expr sub exp2 + ) + | Texp_array list -> + Texp_array (List.map (sub.expr sub) list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse ( + sub.expr sub exp1, + sub.expr sub exp2, + Option.map (sub.expr sub) expo + ) + | Texp_sequence (exp1, exp2) -> + Texp_sequence ( + sub.expr sub exp1, + sub.expr sub exp2 + ) + | Texp_while (exp1, exp2) -> + Texp_while ( + sub.expr sub exp1, + sub.expr sub exp2 + ) + | Texp_for (id, p, exp1, exp2, dir, exp3) -> + Texp_for ( + id, + p, + sub.expr sub exp1, + sub.expr sub exp2, + dir, + sub.expr sub exp3 + ) + | Texp_send (exp, meth) -> + Texp_send + ( + sub.expr sub exp, + meth + ) + | Texp_new (path, lid, cd) -> + Texp_new ( + path, + map_loc sub lid, + cd + ) + | Texp_instvar (path1, path2, id) -> + Texp_instvar ( + path1, + path2, + map_loc sub id + ) + | Texp_setinstvar (path1, path2, id, exp) -> + Texp_setinstvar ( + path1, + path2, + map_loc sub id, + sub.expr sub exp + ) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (tuple3 id (map_loc sub) (sub.expr sub)) list + ) + | Texp_letmodule (id, s, pres, mexpr, exp) -> + Texp_letmodule ( + id, + map_loc sub s, + pres, + sub.module_expr sub mexpr, + sub.expr sub exp + ) + | Texp_letexception (cd, exp) -> + Texp_letexception ( + sub.extension_constructor sub cd, + sub.expr sub exp + ) + | Texp_assert (exp, loc) -> + Texp_assert (sub.expr sub exp, loc) + | Texp_lazy exp -> + Texp_lazy (sub.expr sub exp) + | Texp_object (cl, sl) -> + Texp_object (sub.class_structure sub cl, sl) + | Texp_pack mexpr -> + Texp_pack (sub.module_expr sub mexpr) + | Texp_letop {let_; ands; param; body; partial} -> + Texp_letop{ + let_ = sub.binding_op sub let_; + ands = List.map (sub.binding_op sub) ands; + param; + body = sub.case sub body; + partial; + } + | Texp_unreachable -> + Texp_unreachable + | Texp_extension_constructor (lid, path) -> + Texp_extension_constructor (map_loc sub lid, path) + | Texp_open (od, e) -> + Texp_open (sub.open_declaration sub od, sub.expr sub e) + in + let exp_attributes = sub.attributes sub x.exp_attributes in + {x with exp_loc; exp_extra; exp_desc; exp_env; exp_attributes} + + +let package_type sub x = + let pack_txt = map_loc sub x.pack_txt in + let pack_fields = List.map + (tuple2 (map_loc sub) (sub.typ sub)) x.pack_fields in + {x with pack_txt; pack_fields} + +let binding_op sub x = + let bop_loc = sub.location sub x.bop_loc in + let bop_op_name = map_loc sub x.bop_op_name in + { x with bop_loc; bop_op_name; bop_exp = sub.expr sub x.bop_exp } + +let signature sub x = + let sig_final_env = sub.env sub x.sig_final_env in + let sig_items = List.map (sub.signature_item sub) x.sig_items in + {x with sig_items; sig_final_env} + +let signature_item sub x = + let sig_loc = sub.location sub x.sig_loc in + let sig_env = sub.env sub x.sig_env in + let sig_desc = + match x.sig_desc with + | Tsig_value v -> + Tsig_value (sub.value_description sub v) + | Tsig_type (rec_flag, list) -> + let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in + Tsig_type (rec_flag, list) + | Tsig_typesubst list -> + let (_, list) = sub.type_declarations sub (Nonrecursive, list) in + Tsig_typesubst list + | Tsig_typext te -> + Tsig_typext (sub.type_extension sub te) + | Tsig_exception ext -> + Tsig_exception (sub.type_exception sub ext) + | Tsig_module x -> + Tsig_module (sub.module_declaration sub x) + | Tsig_modsubst x -> + Tsig_modsubst (sub.module_substitution sub x) + | Tsig_recmodule list -> + Tsig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype x -> + Tsig_modtype (sub.module_type_declaration sub x) + | Tsig_modtypesubst x -> + Tsig_modtypesubst (sub.module_type_declaration sub x) + | Tsig_include incl -> + Tsig_include (include_infos sub (sub.module_type sub) incl) + | Tsig_class list -> + Tsig_class (List.map (sub.class_description sub) list) + | Tsig_class_type list -> + Tsig_class_type + (List.map (sub.class_type_declaration sub) list) + | Tsig_open od -> Tsig_open (sub.open_description sub od) + | Tsig_attribute attr -> Tsig_attribute (sub.attribute sub attr) + in + {sig_loc; sig_desc; sig_env} + +let class_description sub x = + class_infos sub (sub.class_type sub) x + +let functor_parameter sub = function + | Unit -> Unit + | Named (id, s, mtype) -> Named (id, map_loc sub s, sub.module_type sub mtype) + +let module_type sub x = + let mty_loc = sub.location sub x.mty_loc in + let mty_env = sub.env sub x.mty_env in + let mty_desc = + match x.mty_desc with + | Tmty_ident (path, lid) -> Tmty_ident (path, map_loc sub lid) + | Tmty_alias (path, lid) -> Tmty_alias (path, map_loc sub lid) + | Tmty_signature sg -> Tmty_signature (sub.signature sub sg) + | Tmty_functor (arg, mtype2) -> + Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2) + | Tmty_with (mtype, list) -> + Tmty_with ( + sub.module_type sub mtype, + List.map (tuple3 id (map_loc sub) (sub.with_constraint sub)) list + ) + | Tmty_typeof mexpr -> + Tmty_typeof (sub.module_expr sub mexpr) + in + let mty_attributes = sub.attributes sub x.mty_attributes in + {x with mty_loc; mty_desc; mty_env; mty_attributes} + +let with_constraint sub = function + | Twith_type decl -> Twith_type (sub.type_declaration sub decl) + | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) + | Twith_modtype mty -> Twith_modtype (sub.module_type sub mty) + | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty) + | Twith_module (path, lid) -> Twith_module (path, map_loc sub lid) + | Twith_modsubst (path, lid) -> Twith_modsubst (path, map_loc sub lid) + +let open_description sub od = + {od with open_loc = sub.location sub od.open_loc; + open_expr = tuple2 id (map_loc sub) od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} + +let open_declaration sub od = + {od with open_loc = sub.location sub od.open_loc; + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} + +let module_coercion sub = function + | Tcoerce_none -> Tcoerce_none + | Tcoerce_functor (c1,c2) -> + Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2) + | Tcoerce_alias (env, p, c1) -> + Tcoerce_alias (sub.env sub env, p, sub.module_coercion sub c1) + | Tcoerce_structure (l1, l2) -> + let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in + let l2' = + List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2 + in + Tcoerce_structure (l1', l2') + | Tcoerce_primitive pc -> + Tcoerce_primitive {pc with pc_loc = sub.location sub pc.pc_loc; + pc_env = sub.env sub pc.pc_env} + +let module_expr sub x = + let mod_loc = sub.location sub x.mod_loc in + let mod_env = sub.env sub x.mod_env in + let mod_desc = + match x.mod_desc with + | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc sub lid) + | Tmod_structure st -> Tmod_structure (sub.structure sub st) + | Tmod_functor (arg, mexpr) -> + Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr) + | Tmod_apply (mexp1, mexp2, c) -> + Tmod_apply ( + sub.module_expr sub mexp1, + sub.module_expr sub mexp2, + sub.module_coercion sub c + ) + | Tmod_apply_unit mexp1 -> + Tmod_apply_unit (sub.module_expr sub mexp1) + | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) -> + Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit, + sub.module_coercion sub c) + | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) -> + Tmod_constraint ( + sub.module_expr sub mexpr, + mt, + Tmodtype_explicit (sub.module_type sub mtype), + sub.module_coercion sub c + ) + | Tmod_unpack (exp, mty) -> + Tmod_unpack + ( + sub.expr sub exp, + mty + ) + in + let mod_attributes = sub.attributes sub x.mod_attributes in + {x with mod_loc; mod_desc; mod_env; mod_attributes} + +let module_binding sub x = + let mb_loc = sub.location sub x.mb_loc in + let mb_name = map_loc sub x.mb_name in + let mb_expr = sub.module_expr sub x.mb_expr in + let mb_attributes = sub.attributes sub x.mb_attributes in + {x with mb_loc; mb_name; mb_expr; mb_attributes} + +let class_expr sub x = + let cl_loc = sub.location sub x.cl_loc in + let cl_env = sub.env sub x.cl_env in + let cl_desc = + match x.cl_desc with + | Tcl_constraint (cl, clty, vals, meths, concrs) -> + Tcl_constraint ( + sub.class_expr sub cl, + Option.map (sub.class_type sub) clty, + vals, + meths, + concrs + ) + | Tcl_structure clstr -> + Tcl_structure (sub.class_structure sub clstr) + | Tcl_fun (label, pat, priv, cl, partial) -> + Tcl_fun ( + label, + sub.pat sub pat, + List.map (tuple2 id (sub.expr sub)) priv, + sub.class_expr sub cl, + partial + ) + | Tcl_apply (cl, args) -> + Tcl_apply ( + sub.class_expr sub cl, + List.map (tuple2 id (Option.map (sub.expr sub))) args + ) + | Tcl_let (rec_flag, value_bindings, ivars, cl) -> + let (rec_flag, value_bindings) = + sub.value_bindings sub (rec_flag, value_bindings) + in + Tcl_let ( + rec_flag, + value_bindings, + List.map (tuple2 id (sub.expr sub)) ivars, + sub.class_expr sub cl + ) + | Tcl_ident (path, lid, tyl) -> + Tcl_ident (path, map_loc sub lid, List.map (sub.typ sub) tyl) + | Tcl_open (od, e) -> + Tcl_open (sub.open_description sub od, sub.class_expr sub e) + in + let cl_attributes = sub.attributes sub x.cl_attributes in + {x with cl_loc; cl_desc; cl_env; cl_attributes} + +let class_type sub x = + let cltyp_loc = sub.location sub x.cltyp_loc in + let cltyp_env = sub.env sub x.cltyp_env in + let cltyp_desc = + match x.cltyp_desc with + | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg) + | Tcty_constr (path, lid, list) -> + Tcty_constr ( + path, + map_loc sub lid, + List.map (sub.typ sub) list + ) + | Tcty_arrow (label, ct, cl) -> + Tcty_arrow + (label, + sub.typ sub ct, + sub.class_type sub cl + ) + | Tcty_open (od, e) -> + Tcty_open (sub.open_description sub od, sub.class_type sub e) + in + let cltyp_attributes = sub.attributes sub x.cltyp_attributes in + {x with cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes} + +let class_signature sub x = + let csig_self = sub.typ sub x.csig_self in + let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in + {x with csig_self; csig_fields} + +let class_type_field sub x = + let ctf_loc = sub.location sub x.ctf_loc in + let ctf_desc = + match x.ctf_desc with + | Tctf_inherit ct -> + Tctf_inherit (sub.class_type sub ct) + | Tctf_val (s, mut, virt, ct) -> + Tctf_val (s, mut, virt, sub.typ sub ct) + | Tctf_method (s, priv, virt, ct) -> + Tctf_method (s, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + | Tctf_attribute attr -> + Tctf_attribute (sub.attribute sub attr) + in + let ctf_attributes = sub.attributes sub x.ctf_attributes in + {ctf_loc; ctf_desc; ctf_attributes} + +let typ sub x = + let ctyp_loc = sub.location sub x.ctyp_loc in + let ctyp_env = sub.env sub x.ctyp_env in + let ctyp_desc = + match x.ctyp_desc with + | Ttyp_any + | Ttyp_var _ as d -> d + | Ttyp_arrow (label, ct1, ct2) -> + Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, map_loc sub lid, List.map (sub.typ sub) list) + | Ttyp_object (list, closed) -> + Ttyp_object ((List.map (sub.object_field sub) list), closed) + | Ttyp_class (path, lid, list) -> + Ttyp_class + (path, + map_loc sub lid, + List.map (sub.typ sub) list + ) + | Ttyp_alias (ct, s) -> + Ttyp_alias (sub.typ sub ct, s) + | Ttyp_variant (list, closed, labels) -> + Ttyp_variant (List.map (sub.row_field sub) list, closed, labels) + | Ttyp_poly (sl, ct) -> + Ttyp_poly (sl, sub.typ sub ct) + | Ttyp_package pack -> + Ttyp_package (sub.package_type sub pack) + | Ttyp_open (path, mod_ident, t) -> + Ttyp_open (path, map_loc sub mod_ident, sub.typ sub t) + in + let ctyp_attributes = sub.attributes sub x.ctyp_attributes in + {x with ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes} + +let class_structure sub x = + let cstr_self = sub.pat sub x.cstr_self in + let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in + {x with cstr_self; cstr_fields} + +let row_field sub x = + let rf_loc = sub.location sub x.rf_loc in + let rf_desc = match x.rf_desc with + | Ttag (label, b, list) -> + Ttag (map_loc sub label, b, List.map (sub.typ sub) list) + | Tinherit ct -> Tinherit (sub.typ sub ct) + in + let rf_attributes = sub.attributes sub x.rf_attributes in + {rf_loc; rf_desc; rf_attributes} + +let object_field sub x = + let of_loc = sub.location sub x.of_loc in + let of_desc = match x.of_desc with + | OTtag (label, ct) -> + OTtag (map_loc sub label, (sub.typ sub ct)) + | OTinherit ct -> OTinherit (sub.typ sub ct) + in + let of_attributes = sub.attributes sub x.of_attributes in + {of_loc; of_desc; of_attributes} + +let class_field_kind sub = function + | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct) + | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e) + +let class_field sub x = + let cf_loc = sub.location sub x.cf_loc in + let cf_desc = + match x.cf_desc with + | Tcf_inherit (ovf, cl, super, vals, meths) -> + Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths) + | Tcf_constraint (cty, cty') -> + Tcf_constraint ( + sub.typ sub cty, + sub.typ sub cty' + ) + | Tcf_val (s, mf, id, k, b) -> + Tcf_val (map_loc sub s, mf, id, class_field_kind sub k, b) + | Tcf_method (s, priv, k) -> + Tcf_method (map_loc sub s, priv, class_field_kind sub k) + | Tcf_initializer exp -> + Tcf_initializer (sub.expr sub exp) + | Tcf_attribute attr -> + Tcf_attribute (sub.attribute sub attr) + in + let cf_attributes = sub.attributes sub x.cf_attributes in + {cf_loc; cf_desc; cf_attributes} + +let value_bindings sub (rec_flag, list) = + (rec_flag, List.map (sub.value_binding sub) list) + +let case + : type k . mapper -> k case -> k case + = fun sub {c_lhs; c_guard; c_rhs; c_cont} -> + { + c_lhs = sub.pat sub c_lhs; + c_guard = Option.map (sub.expr sub) c_guard; + c_rhs = sub.expr sub c_rhs; + c_cont + } + +let value_binding sub x = + let vb_loc = sub.location sub x.vb_loc in + let vb_pat = sub.pat sub x.vb_pat in + let vb_expr = sub.expr sub x.vb_expr in + let vb_attributes = sub.attributes sub x.vb_attributes in + let vb_rec_kind = x.vb_rec_kind in + {vb_loc; vb_pat; vb_expr; vb_attributes; vb_rec_kind} + +let env _sub x = x + +let default = + { + attribute; + attributes; + binding_op; + case; + class_declaration; + class_description; + class_expr; + class_field; + class_signature; + class_structure; + class_type; + class_type_declaration; + class_type_field; + env; + expr; + extension_constructor; + location; + module_binding; + module_coercion; + module_declaration; + module_substitution; + module_expr; + module_type; + module_type_declaration; + package_type; + pat; + row_field; + object_field; + open_declaration; + open_description; + signature; + signature_item; + structure; + structure_item; + typ; + type_declaration; + type_declarations; + type_extension; + type_exception; + type_kind; + value_binding; + value_bindings; + value_description; + with_constraint; + } diff --git a/upstream/ocaml_503/typing/tast_mapper.mli b/upstream/ocaml_503/typing/tast_mapper.mli new file mode 100644 index 000000000..f54cef2b0 --- /dev/null +++ b/upstream/ocaml_503/typing/tast_mapper.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +(** {1 A generic Typedtree mapper} *) + +type mapper = + { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; + binding_op: mapper -> binding_op -> binding_op; + case: 'k . mapper -> 'k case -> 'k case; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + class_signature: mapper -> class_signature -> class_signature; + class_structure: mapper -> class_structure -> class_structure; + class_type: mapper -> class_type -> class_type; + class_type_declaration: mapper -> class_type_declaration -> + class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: mapper -> extension_constructor -> + extension_constructor; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + module_declaration: mapper -> module_declaration -> module_declaration; + module_substitution: mapper -> module_substitution -> module_substitution; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + package_type: mapper -> package_type -> package_type; + pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern; + row_field: mapper -> row_field -> row_field; + object_field: mapper -> object_field -> object_field; + open_declaration: mapper -> open_declaration -> open_declaration; + open_description: mapper -> open_description -> open_description; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: mapper -> (rec_flag * type_declaration list) + -> (rec_flag * type_declaration list); + type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: mapper -> (rec_flag * value_binding list) -> + (rec_flag * value_binding list); + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; + } + + +val default: mapper diff --git a/upstream/ocaml_503/typing/type_immediacy.ml b/upstream/ocaml_503/typing/type_immediacy.ml new file mode 100644 index 000000000..557ed4271 --- /dev/null +++ b/upstream/ocaml_503/typing/type_immediacy.ml @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + | Unknown + | Always + | Always_on_64bits + +module Violation = struct + type t = + | Not_always_immediate + | Not_always_immediate_on_64bits +end + +let coerce t ~as_ = + match t, as_ with + | _, Unknown + | Always, Always + | (Always | Always_on_64bits), Always_on_64bits -> Ok () + | (Unknown | Always_on_64bits), Always -> + Error Violation.Not_always_immediate + | Unknown, Always_on_64bits -> + Error Violation.Not_always_immediate_on_64bits + +let of_attributes attrs = + match + Builtin_attributes.immediate attrs, + Builtin_attributes.immediate64 attrs + with + | true, _ -> Always + | false, true -> Always_on_64bits + | false, false -> Unknown diff --git a/upstream/ocaml_503/typing/type_immediacy.mli b/upstream/ocaml_503/typing/type_immediacy.mli new file mode 100644 index 000000000..3fc2e3b4f --- /dev/null +++ b/upstream/ocaml_503/typing/type_immediacy.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Immediacy status of a type *) + +type t = + | Unknown + (** We don't know anything *) + | Always + (** We know for sure that values of this type are always immediate *) + | Always_on_64bits + (** We know for sure that values of this type are always immediate + on 64 bit platforms. For other platforms, we know nothing. *) + +module Violation : sig + type t = + | Not_always_immediate + | Not_always_immediate_on_64bits +end + +(** [coerce t ~as_] returns [Ok ()] iff [t] can be seen as type + immediacy [as_]. For instance, [Always] can be seen as + [Always_on_64bits] but the opposite is not true. Return [Error _] + if the coercion is not possible. *) +val coerce : t -> as_:t -> (unit, Violation.t) result + +(** Return the immediateness of a type as indicated by the user via + attributes *) +val of_attributes : Parsetree.attributes -> t diff --git a/upstream/ocaml_503/typing/typeclass.ml b/upstream/ocaml_503/typing/typeclass.ml new file mode 100644 index 000000000..043b9e908 --- /dev/null +++ b/upstream/ocaml_503/typing/typeclass.ml @@ -0,0 +1,2197 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Parsetree +open Asttypes +open Path +open Types +open Typecore +open Typetexp + + +type 'a class_info = { + cls_id : Ident.t; + cls_id_loc : string loc; + cls_decl : class_declaration; + cls_ty_id : Ident.t; + cls_ty_decl : class_type_declaration; + cls_obj_id : Ident.t; + cls_obj_abbr : type_declaration; + cls_abbr : type_declaration; + cls_arity : int; + cls_pub_methods : string list; + cls_info : 'a; +} + +type class_type_info = { + clsty_ty_id : Ident.t; + clsty_id_loc : string loc; + clsty_ty_decl : class_type_declaration; + clsty_obj_id : Ident.t; + clsty_obj_abbr : type_declaration; + clsty_abbr : type_declaration; + clsty_info : Typedtree.class_type_declaration; +} + +type 'a full_class = { + id : Ident.t; + id_loc : string loc; + clty: class_declaration; + ty_id: Ident.t; + cltydef: class_type_declaration; + obj_id: Ident.t; + obj_abbr: type_declaration; + arity: int; + pub_meths: string list; + coe: Warnings.loc list; + req: 'a Typedtree.class_infos; +} + +type kind = + | Object + | Class + | Class_type + +type final = + | Final + | Not_final + +let kind_of_final = function + | Final -> Object + | Not_final -> Class + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | Structure_expected of class_type + | Cannot_apply of class_type + | Apply_wrong_label of arg_label + | Pattern_type_clash of type_expr + | Repeated_parameter + | Unbound_class_2 of Longident.t + | Unbound_class_type_2 of Longident.t + | Abbrev_type_clash of type_expr * type_expr * type_expr + | Constructor_type_mismatch of string * Errortrace.unification_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | Class_match_failure of Ctype.class_match_failure list + | Unbound_val of string + | Unbound_type_var of Format_doc.t * Ctype.closed_class_failure + | Non_generalizable_class of + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } + | Cannot_coerce_self of type_expr + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +open Typedtree + +let type_open_descr : + (?used_slot:bool ref -> Env.t -> Parsetree.open_description + -> open_description * Env.t) ref = + ref (fun ?used_slot:_ _ -> assert false) + +let ctyp desc typ env loc = + { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; + ctyp_attributes = [] } + +(* + Path associated to the temporary class type of a class being typed + (its constructor is not available). +*) +let unbound_class = + Path.Pident (Ident.create_local "*undef*") + + + (************************************) + (* Some operations on class types *) + (************************************) + +let extract_constraints cty = + let sign = Btype.signature_of_class_type cty in + (Btype.instance_vars sign, + Btype.methods sign, + Btype.concrete_methods sign) + +(* Record a class type *) +let rc node = + Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); + node + +let update_class_signature loc env ~warn_implicit_public virt kind sign = + let implicit_public, implicit_declared = + Ctype.update_class_signature env sign + in + if implicit_declared <> [] then begin + match virt with + | Virtual -> () (* Should perhaps emit warning 17 here *) + | Concrete -> + raise (Error(loc, env, Undeclared_methods(kind, implicit_declared))) + end; + if warn_implicit_public && implicit_public <> [] then begin + Location.prerr_warning + loc (Warnings.Implicit_public_methods implicit_public) + end + +let complete_class_signature loc env virt kind sign = + update_class_signature loc env ~warn_implicit_public:false virt kind sign; + Ctype.hide_private_methods env sign + +let complete_class_type loc env virt kind typ = + let sign = Btype.signature_of_class_type typ in + complete_class_signature loc env virt kind sign + +let check_virtual loc env virt kind sign = + match virt with + | Virtual -> () + | Concrete -> + match Btype.virtual_methods sign, Btype.virtual_instance_vars sign with + | [], [] -> () + | meths, vars -> + raise(Error(loc, env, Virtual_class(kind, meths, vars))) + +let rec check_virtual_clty loc env virt kind clty = + match clty with + | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) -> + check_virtual_clty loc env virt kind clty + | Cty_signature sign -> + check_virtual loc env virt kind sign + +(* Return the constructor type associated to a class type *) +let rec constructor_type constr cty = + match cty with + Cty_constr (_, _, cty) -> + constructor_type constr cty + | Cty_signature _ -> + constr + | Cty_arrow (l, ty, cty) -> + Ctype.newty (Tarrow (l, ty, constructor_type constr cty, commu_ok)) + + (***********************************) + (* Primitives for typing classes *) + (***********************************) + +let raise_add_method_failure loc env label sign failure = + match (failure : Ctype.add_method_failure) with + | Ctype.Unexpected_method -> + raise(Error(loc, env, Unexpected_field (sign.Types.csig_self, label))) + | Ctype.Type_mismatch trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let raise_add_instance_variable_failure loc env label failure = + match (failure : Ctype.add_instance_variable_failure) with + | Ctype.Mutability_mismatch mut -> + raise (Error(loc, env, Mutability_mismatch(label, mut))) + | Ctype.Type_mismatch trace -> + raise (Error(loc, env, + Field_type_mismatch("instance variable", label, trace))) + +let raise_inherit_class_signature_failure loc env sign = function + | Ctype.Self_type_mismatch trace -> + raise(Error(loc, env, Self_clash trace)) + | Ctype.Method(label, failure) -> + raise_add_method_failure loc env label sign failure + | Ctype.Instance_variable(label, failure) -> + raise_add_instance_variable_failure loc env label failure + +let add_method loc env label priv virt ty sign = + match Ctype.add_method env label priv virt ty sign with + | () -> () + | exception Ctype.Add_method_failed failure -> + raise_add_method_failure loc env label sign failure + +let add_instance_variable ~strict loc env label mut virt ty sign = + match Ctype.add_instance_variable ~strict env label mut virt ty sign with + | () -> () + | exception Ctype.Add_instance_variable_failed failure -> + raise_add_instance_variable_failure loc env label failure + +let inherit_class_signature ~strict loc env sign1 sign2 = + match Ctype.inherit_class_signature ~strict env sign1 sign2 with + | () -> () + | exception Ctype.Inherit_class_signature_failed failure -> + raise_inherit_class_signature_failure loc env sign1 failure + +let inherit_class_type ~strict loc env sign1 cty2 = + let sign2 = + match Btype.scrape_class_type cty2 with + | Cty_signature sign2 -> sign2 + | _ -> + raise(Error(loc, env, Structure_expected cty2)) + in + inherit_class_signature ~strict loc env sign1 sign2 + +let unify_delayed_method_type loc env label ty expected_ty= + match Ctype.unify env ty expected_ty with + | () -> () + | exception Ctype.Unify trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let type_constraint val_env sty sty' loc = + let cty = transl_simple_type val_env ~closed:false sty in + let ty = cty.ctyp_type in + let cty' = transl_simple_type val_env ~closed:false sty' in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify val_env ty ty' with Ctype.Unify err -> + raise(Error(loc, val_env, Unconsistent_constraint err)); + end; + (cty, cty') + +let make_method loc cl_num expr = + let open Ast_helper in + let mkid s = mkloc s loc in + let pat = + Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)) + in + Exp.function_ ~loc:expr.pexp_loc + [ { pparam_desc = Pparam_val (Nolabel, None, pat); + pparam_loc = pat.ppat_loc; + } + ] + None (Pfunction_body expr) + +(*******************************) + +let delayed_meth_specs = ref [] + +let rec class_type_field env sign self_scope ctf = + let loc = ctf.pctf_loc in + let mkctf desc = + { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } + in + let mkctf_with_attrs f = + Builtin_attributes.warning_scope ctf.pctf_attributes + (fun () -> mkctf (f ())) + in + match ctf.pctf_desc with + | Pctf_inherit sparent -> + mkctf_with_attrs + (fun () -> + let parent = class_type env Virtual self_scope sparent in + complete_class_type parent.cltyp_loc + env Virtual Class_type parent.cltyp_type; + inherit_class_type ~strict:false loc env sign parent.cltyp_type; + Tctf_inherit parent) + | Pctf_val ({txt=lab}, mut, virt, sty) -> + mkctf_with_attrs + (fun () -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + add_instance_variable ~strict:false loc env lab mut virt ty sign; + Tctf_val (lab, mut, virt, cty)) + + | Pctf_method ({txt=lab}, priv, virt, sty) -> + mkctf_with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + match sty.ptyp_desc, priv with + | Ptyp_poly ([],sty'), Public -> + let expected_ty = Ctype.newvar () in + add_method loc env lab priv virt expected_ty sign; + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) env loc in + delayed_meth_specs := + Warnings.mk_lazy (fun () -> + let cty = transl_simple_type_univars env sty' in + let ty = cty.ctyp_type in + unify_delayed_method_type loc env lab ty expected_ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty; + ) :: !delayed_meth_specs; + Tctf_method (lab, priv, virt, returned_cty) + | _ -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + add_method loc env lab priv virt ty sign; + Tctf_method (lab, priv, virt, cty)) + + | Pctf_constraint (sty, sty') -> + mkctf_with_attrs + (fun () -> + let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in + Tctf_constraint (cty, cty')) + + | Pctf_attribute x -> + Builtin_attributes.warning_attribute x; + mkctf (Tctf_attribute x) + + | Pctf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_signature virt env pcsig self_scope loc = + let {pcsig_self=sty; pcsig_fields=psign} = pcsig in + let sign = Ctype.new_class_signature () in + (* Introduce a dummy method preventing self type from being closed. *) + Ctype.add_dummy_method env ~scope:self_scope sign; + + let self_cty = transl_simple_type env ~closed:false sty in + let self_type = self_cty.ctyp_type in + begin try + Ctype.unify env self_type sign.csig_self + with Ctype.Unify _ -> + raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) + end; + + (* Class type fields *) + let fields = + Builtin_attributes.warning_scope [] + (fun () -> List.map (class_type_field env sign self_scope) psign) + in + check_virtual loc env virt Class_type sign; + { csig_self = self_cty; + csig_fields = fields; + csig_type = sign; } + +and class_type env virt self_scope scty = + Builtin_attributes.warning_scope scty.pcty_attributes + (fun () -> class_type_aux env virt self_scope scty) + +and class_type_aux env virt self_scope scty = + let cltyp desc typ = + { + cltyp_desc = desc; + cltyp_type = typ; + cltyp_loc = scty.pcty_loc; + cltyp_env = env; + cltyp_attributes = scty.pcty_attributes; + } + in + match scty.pcty_desc with + | Pcty_constr (lid, styl) -> + let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in + if Path.same decl.clty_path unbound_class then + raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); + let (params, clty) = + Ctype.instance_class decl.clty_params decl.clty_type + in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method env ~scope:self_scope + (Btype.signature_of_class_type clty); + if List.length params <> List.length styl then + raise(Error(scty.pcty_loc, env, + Parameter_arity_mismatch (lid.txt, List.length params, + List.length styl))); + let ctys = List.map2 + (fun sty ty -> + let cty' = transl_simple_type env ~closed:false sty in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify env ty' ty with Ctype.Unify err -> + raise(Error(sty.ptyp_loc, env, Parameter_mismatch err)) + end; + cty' + ) styl params + in + let typ = Cty_constr (path, params, clty) in + (* Check for unexpected virtual methods *) + check_virtual_clty scty.pcty_loc env virt Class_type typ; + cltyp (Tcty_constr ( path, lid , ctys)) typ + + | Pcty_signature pcsig -> + let clsig = class_signature virt env pcsig self_scope scty.pcty_loc in + let typ = Cty_signature clsig.csig_type in + cltyp (Tcty_signature clsig) typ + + | Pcty_arrow (l, sty, scty) -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + let ty = + if Btype.is_optional l + then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil)) + else ty in + let clty = class_type env virt self_scope scty in + let typ = Cty_arrow (l, ty, clty.cltyp_type) in + cltyp (Tcty_arrow (l, cty, clty)) typ + + | Pcty_open (od, e) -> + let (od, newenv) = !type_open_descr env od in + let clty = class_type newenv virt self_scope e in + cltyp (Tcty_open (od, clty)) clty.cltyp_type + + | Pcty_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +let class_type env virt self_scope scty = + delayed_meth_specs := []; + let cty = class_type env virt self_scope scty in + List.iter Lazy.force (List.rev !delayed_meth_specs); + delayed_meth_specs := []; + cty + +(*******************************) + +let enter_ancestor_val name val_env = + Env.enter_unbound_value name Val_unbound_ancestor val_env + +let enter_self_val name val_env = + Env.enter_unbound_value name Val_unbound_self val_env + +let enter_instance_var_val name val_env = + Env.enter_unbound_value name Val_unbound_instance_variable val_env + +let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = + let check s = Warnings.Unused_ancestor s in + let kind = Val_anc (sign, meths, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } + in + Env.enter_value ~check name desc met_env + +let add_self_met loc id sign self_var_kind vars cl_num + as_var ty attrs met_env = + let check = + if as_var then (fun s -> Warnings.Unused_var s) + else (fun s -> Warnings.Unused_var_strict s) + in + let kind = Val_self (sign, self_var_kind, vars, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } + in + Env.add_value ~check id desc met_env + +let add_instance_var_met loc label id sign cl_num attrs met_env = + let mut, ty = + match Vars.find label sign.csig_vars with + | (mut, _, ty) -> mut, ty + | exception Not_found -> assert false + in + let kind = Val_ivar (mut, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } + in + Env.add_value id desc met_env + +let add_instance_vars_met loc vars sign cl_num met_env = + List.fold_left + (fun met_env (label, id) -> + add_instance_var_met loc label id sign cl_num [] met_env) + met_env vars + +type intermediate_class_field = + | Inherit of + { override : override_flag; + parent : class_expr; + super : string option; + inherited_vars : (string * Ident.t) list; + super_meths : (string * Ident.t) list; + loc : Location.t; + attributes : attribute list; } + | Virtual_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + cty : core_type; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Concrete_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + override : override_flag; + definition : expression; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Virtual_method of + { label : string loc; + priv : private_flag; + cty : core_type; + loc : Location.t; + attributes : attribute list; } + | Concrete_method of + { label : string loc; + priv : private_flag; + override : override_flag; + sdefinition : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Constraint of + { cty1 : core_type; + cty2 : core_type; + loc : Location.t; + attributes : attribute list; } + | Initializer of + { sexpr : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Attribute of + { attribute : attribute; + loc : Location.t; + attributes : attribute list; } + +type first_pass_accummulater = + { rev_fields : intermediate_class_field list; + val_env : Env.t; + par_env : Env.t; + concrete_meths : MethSet.t; + concrete_vals : VarSet.t; + local_meths : MethSet.t; + local_vals : VarSet.t; + vars : Ident.t Vars.t; } + +let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = + let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; + local_meths; local_vals; vars } = acc + in + let loc = cf.pcf_loc in + let attributes = cf.pcf_attributes in + let with_attrs f = Builtin_attributes.warning_scope attributes f in + match cf.pcf_desc with + | Pcf_inherit (override, sparent, super) -> + with_attrs + (fun () -> + let parent = + class_expr cl_num val_env par_env + Virtual self_scope sparent + in + complete_class_type parent.cl_loc + par_env Virtual Class parent.cl_type; + inherit_class_type ~strict:true loc val_env sign parent.cl_type; + let parent_sign = Btype.signature_of_class_type parent.cl_type in + let new_concrete_meths = Btype.concrete_methods parent_sign in + let new_concrete_vals = Btype.concrete_instance_vars parent_sign in + let over_meths = MethSet.inter new_concrete_meths concrete_meths in + let over_vals = VarSet.inter new_concrete_vals concrete_vals in + begin match override with + | Fresh -> + let cname = + match parent.cl_type with + | Cty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in + if not (MethSet.is_empty over_meths) then + Location.prerr_warning loc + (Warnings.Method_override + (cname :: MethSet.elements over_meths)); + if not (VarSet.is_empty over_vals) then + Location.prerr_warning loc + (Warnings.Instance_variable_override + (cname :: VarSet.elements over_vals)); + | Override -> + if MethSet.is_empty over_meths && VarSet.is_empty over_vals then + raise (Error(loc, val_env, No_overriding ("",""))) + end; + let concrete_vals = VarSet.union new_concrete_vals concrete_vals in + let concrete_meths = + MethSet.union new_concrete_meths concrete_meths + in + let val_env, par_env, inherited_vars, vars = + Vars.fold + (fun label _ (val_env, par_env, inherited_vars, vars) -> + let val_env = enter_instance_var_val label val_env in + let par_env = enter_instance_var_val label par_env in + let id = Ident.create_local label in + let inherited_vars = (label, id) :: inherited_vars in + let vars = Vars.add label id vars in + (val_env, par_env, inherited_vars, vars)) + parent_sign.csig_vars (val_env, par_env, [], vars) + in + (* Methods available through super *) + let super_meths = + MethSet.fold + (fun label acc -> (label, Ident.create_local label) :: acc) + new_concrete_meths [] + in + (* Super *) + let (val_env, par_env, super) = + match super with + | None -> (val_env, par_env, None) + | Some {txt=name} -> + let val_env = enter_ancestor_val name val_env in + let par_env = enter_ancestor_val name par_env in + (val_env, par_env, Some name) + in + let field = + Inherit + { override; parent; super; inherited_vars; + super_meths; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; + concrete_meths; concrete_vals; vars }) + | Pcf_val (label, mut, Cfk_virtual styp) -> + with_attrs + (fun () -> + let cty = + Ctype.with_local_level_generalize_structure_if_principal + (fun () -> Typetexp.transl_simple_type val_env + ~closed:false styp) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Virtual cty.ctyp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Virtual_val + { label; mut; id; cty; already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; vars }) + | Pcf_val (label, mut, Cfk_concrete (override, sdefinition)) -> + with_attrs + (fun () -> + if VarSet.mem label.txt local_vals then + raise(Error(loc, val_env, + Duplicate ("instance variable", label.txt))); + if VarSet.mem label.txt concrete_vals then begin + if override = Fresh then + Location.prerr_warning label.loc + (Warnings.Instance_variable_override[label.txt]) + end else begin + if override = Override then + raise(Error(loc, val_env, + No_overriding ("instance variable", label.txt))) + end; + let definition = + Ctype.with_local_level_generalize_structure_if_principal + (fun () -> type_exp val_env sdefinition) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Concrete definition.exp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Concrete_val + { label; mut; id; override; definition; + already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_vals = VarSet.add label.txt concrete_vals in + let local_vals = VarSet.add label.txt local_vals in + { acc with rev_fields; val_env; par_env; + concrete_vals; local_vals; vars }) + + | Pcf_method (label, priv, Cfk_virtual sty) -> + with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = transl_simple_type val_env ~closed:false sty in + let ty = cty.ctyp_type in + add_method loc val_env label.txt priv Virtual ty sign; + let field = + Virtual_method { label; priv; cty; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> + with_attrs + (fun () -> + if MethSet.mem label.txt local_meths then + raise(Error(loc, val_env, Duplicate ("method", label.txt))); + if MethSet.mem label.txt concrete_meths then begin + if override = Fresh then begin + Location.prerr_warning loc + (Warnings.Method_override [label.txt]) + end + end else begin + if override = Override then begin + raise(Error(loc, val_env, No_overriding("method", label.txt))) + end + end; + let expr = + match expr.pexp_desc with + | Pexp_poly _ -> expr + | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None + in + let sbody, sty = + match expr.pexp_desc with + | Pexp_poly (sbody, sty) -> sbody, sty + | _ -> assert false + in + let ty = + match sty with + | None -> Ctype.newvar () + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty' = + Typetexp.transl_simple_type val_env ~closed:false sty + in + cty'.ctyp_type + in + add_method loc val_env label.txt priv Concrete ty sign; + begin + try + match get_desc ty with + | Tvar _ -> + let ty' = Ctype.newvar () in + Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; + Ctype.unify val_env (type_approx val_env sbody) ty' + | Tpoly (ty1, tl) -> + let _, ty1' = Ctype.instance_poly ~fixed:false tl ty1 in + let ty2 = type_approx val_env sbody in + Ctype.unify val_env ty2 ty1' + | _ -> assert false + with Ctype.Unify err -> + raise(Error(loc, val_env, + Field_type_mismatch ("method", label.txt, err))) + end; + let sdefinition = make_method self_loc cl_num expr in + let warning_state = Warnings.backup () in + let field = + Concrete_method + { label; priv; override; sdefinition; + warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_meths = MethSet.add label.txt concrete_meths in + let local_meths = MethSet.add label.txt local_meths in + { acc with rev_fields; concrete_meths; local_meths }) + + | Pcf_constraint (sty1, sty2) -> + with_attrs + (fun () -> + let (cty1, cty2) = type_constraint val_env sty1 sty2 loc in + let field = + Constraint { cty1; cty2; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_initializer sexpr -> + with_attrs + (fun () -> + let sexpr = make_method self_loc cl_num sexpr in + let warning_state = Warnings.backup () in + let field = + Initializer { sexpr; warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + | Pcf_attribute attribute -> + Builtin_attributes.warning_attribute attribute; + let field = Attribute { attribute; loc; attributes } in + let rev_fields = field :: rev_fields in + { acc with rev_fields } + | Pcf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env cfs = + let rev_fields = [] in + let concrete_meths = MethSet.empty in + let concrete_vals = VarSet.empty in + let local_meths = MethSet.empty in + let local_vals = VarSet.empty in + let vars = Vars.empty in + let init_acc = + { rev_fields; val_env; par_env; + concrete_meths; concrete_vals; + local_meths; local_vals; vars } + in + let acc = + Builtin_attributes.warning_scope [] + (fun () -> + List.fold_left + (class_field_first_pass self_loc cl_num sign self_scope) + init_acc cfs) + in + List.rev acc.rev_fields, acc.vars + +and class_field_second_pass cl_num sign met_env field = + let mkcf desc loc attrs = + { cf_desc = desc; cf_loc = loc; cf_attributes = attrs } + in + match field with + | Inherit { override; parent; super; + inherited_vars; super_meths; loc; attributes } -> + let met_env = + add_instance_vars_met loc inherited_vars sign cl_num met_env + in + let met_env = + match super with + | None -> met_env + | Some name -> + let meths = + List.fold_left + (fun acc (label, id) -> Meths.add label id acc) + Meths.empty super_meths + in + let ty = Btype.self_type parent.cl_type in + let attrs = [] in + let _id, met_env = + enter_ancestor_met ~loc name ~sign ~meths + ~cl_num ~ty ~attrs met_env + in + met_env + in + let desc = + Tcf_inherit(override, parent, super, inherited_vars, super_meths) + in + met_env, mkcf desc loc attributes + | Virtual_val { label; mut; id; cty; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_virtual cty in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Concrete_val { label; mut; id; override; + definition; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_concrete(override, definition) in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Virtual_method { label; priv; cty; loc; attributes } -> + let kind = Tcfk_virtual cty in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes + | Concrete_method { label; priv; override; + sdefinition; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let ty = Btype.method_type label.txt sign in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Btype.newgenty (Tarrow(Nolabel, self_type, ty, commu_ok))) + in + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sdefinition meth_type) in + let kind = Tcfk_concrete (override, texp) in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes) + | Constraint { cty1; cty2; loc; attributes } -> + let desc = Tcf_constraint(cty1, cty2) in + met_env, mkcf desc loc attributes + | Initializer { sexpr; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let unit_type = Ctype.instance Predef.type_unit in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Ctype.newty (Tarrow (Nolabel, self_type, unit_type, commu_ok))) + in + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sexpr meth_type) in + let desc = Tcf_initializer texp in + met_env, mkcf desc loc attributes) + | Attribute { attribute; loc; attributes; } -> + let desc = Tcf_attribute attribute in + met_env, mkcf desc loc attributes + +and class_fields_second_pass cl_num sign met_env fields = + let _, rev_cfs = + List.fold_left + (fun (met_env, cfs) field -> + let met_env, cf = + class_field_second_pass cl_num sign met_env field + in + met_env, cf :: cfs) + (met_env, []) fields + in + List.rev rev_cfs + +(* N.B. the self type of a final object type doesn't contain a dummy method in + the beginning. + We only explicitly add a dummy method to class definitions (and class (type) + declarations)), which are later removed (made absent) by [final_decl]. + + If we ever find a dummy method in a final object self type, it means that + somehow we've unified the self type of the object with the self type of a not + yet finished class. + When this happens, we cannot close the object type and must error. *) +and class_structure cl_num virt self_scope final val_env met_env loc + { pcstr_self = spat; pcstr_fields = str } = + (* Environment for substructures *) + let par_env = met_env in + + (* Location of self. Used for locations of self arguments *) + let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in + + let sign = Ctype.new_class_signature () in + + (* Adding a dummy method to the signature prevents it from being closed / + escaping. That isn't needed for objects though. *) + begin match final with + | Not_final -> Ctype.add_dummy_method val_env ~scope:self_scope sign; + | Final -> () + end; + + (* Self binder *) + let (self_pat, self_pat_vars) = type_self_pattern val_env spat in + let val_env, par_env = + List.fold_right + (fun {pv_id; _} (val_env, par_env) -> + let name = Ident.name pv_id in + let val_env = enter_self_val name val_env in + let par_env = enter_self_val name par_env in + val_env, par_env) + self_pat_vars (val_env, par_env) + in + + (* Check that the binder has a correct type *) + begin try Ctype.unify val_env self_pat.pat_type sign.csig_self with + Ctype.Unify _ -> + raise(Error(spat.ppat_loc, val_env, + Pattern_type_clash self_pat.pat_type)) + end; + + (* Typing of class fields *) + let (fields, vars) = + class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env str + in + let kind = kind_of_final final in + + (* Check for unexpected virtual methods *) + check_virtual loc val_env virt kind sign; + + (* Update the class signature *) + update_class_signature loc val_env + ~warn_implicit_public:false virt kind sign; + + let meths = + Meths.fold + (fun label _ meths -> + Meths.add label (Ident.create_local label) meths) + sign.csig_meths Meths.empty + in + + (* Close the signature if it is final *) + begin match final with + | Not_final -> () + | Final -> + if not (Ctype.close_class_signature val_env sign) then + raise(Error(loc, val_env, Closing_self_type sign)); + end; + (* Typing of method bodies *) + Ctype.generalize_class_signature_spine sign; + let self_var_kind = + match virt with + | Virtual -> Self_virtual(ref meths) + | Concrete -> Self_concrete meths + in + let met_env = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes} met_env -> + add_self_met pv_loc pv_id sign self_var_kind vars + cl_num (pv_kind=As_var) pv_type pv_attributes met_env) + self_pat_vars met_env + in + let fields = + class_fields_second_pass cl_num sign met_env fields + in + + (* Update the class signature and warn about public methods made private *) + update_class_signature loc val_env + ~warn_implicit_public:true virt kind sign; + + let meths = + match self_var_kind with + | Self_virtual meths_ref -> !meths_ref + | Self_concrete meths -> meths + in + { cstr_self = self_pat; + cstr_fields = fields; + cstr_type = sign; + cstr_meths = meths; } + +and class_expr cl_num val_env met_env virt self_scope scl = + Builtin_attributes.warning_scope scl.pcl_attributes + (fun () -> class_expr_aux cl_num val_env met_env virt self_scope scl) + +and class_expr_aux cl_num val_env met_env virt self_scope scl = + match scl.pcl_desc with + | Pcl_constr (lid, styl) -> + let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in + if Path.same decl.cty_path unbound_class then + raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt)); + let tyl = List.map + (fun sty -> transl_simple_type val_env ~closed:false sty) + styl + in + let (params, clty) = + Ctype.instance_class decl.cty_params decl.cty_type + in + let clty' = Btype.abbreviate_class_type path params clty in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type clty'); + if List.length params <> List.length tyl then + raise(Error(scl.pcl_loc, val_env, + Parameter_arity_mismatch (lid.txt, List.length params, + List.length tyl))); + List.iter2 + (fun cty' ty -> + let ty' = cty'.ctyp_type in + try Ctype.unify val_env ty' ty with Ctype.Unify err -> + raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err))) + tyl params; + (* Check for unexpected virtual methods *) + check_virtual_clty scl.pcl_loc val_env virt Class clty'; + let cl = + rc {cl_desc = Tcl_ident (path, lid, tyl); + cl_loc = scl.pcl_loc; + cl_type = clty'; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + in + let (vals, meths, concrs) = extract_constraints clty in + rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs); + cl_loc = scl.pcl_loc; + cl_type = clty'; + cl_env = val_env; + cl_attributes = []; (* attributes are kept on the inner cl node *) + } + | Pcl_structure cl_str -> + let desc = + class_structure cl_num virt self_scope Not_final + val_env met_env scl.pcl_loc cl_str + in + rc {cl_desc = Tcl_structure desc; + cl_loc = scl.pcl_loc; + cl_type = Cty_signature desc.cstr_type; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_fun (l, Some default, spat, sbody) -> + let loc = default.pexp_loc in + let open Ast_helper in + let scases = [ + Exp.case + (Pat.construct ~loc + (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) + (Some ([], Pat.var ~loc (mknoloc "*sth*")))) + (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*"))); + + Exp.case + (Pat.construct ~loc + (mknoloc (Longident.(Ldot (Lident "*predef*", "None")))) + None) + default; + ] + in + let smatch = + Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) + scases + in + let sfun = + Cl.fun_ ~loc:scl.pcl_loc + l None + (Pat.var ~loc (mknoloc "*opt*")) + (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody) + (* Note: we don't put the '#default' attribute, as it + is not detected for class-level let bindings. See #5975.*) + in + class_expr cl_num val_env met_env virt self_scope sfun + | Pcl_fun (l, None, spat, scl') -> + let (pat, pv, val_env', met_env) = + Ctype.with_local_level_generalize_structure_if_principal + (fun () -> + Typecore.type_class_arg_pattern cl_num val_env met_env l spat) + in + let pv = + List.map + begin fun (id, id', _ty) -> + let path = Pident id' in + (* do not mark the value as being used *) + let vd = Env.find_value path val_env' in + (id, + {exp_desc = + Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd); + exp_loc = Location.none; exp_extra = []; + exp_type = Ctype.instance vd.val_type; + exp_attributes = []; (* check *) + exp_env = val_env'}) + end + pv + in + let rec not_nolabel_function = function + | Cty_arrow(Nolabel, _, _) -> false + | Cty_arrow(_, _, cty) -> not_nolabel_function cty + | _ -> true + in + let partial = + let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in + Typecore.check_partial val_env pat.pat_type pat.pat_loc + [{c_lhs = pat; c_cont = None; c_guard = None; c_rhs = dummy}] + in + let cl = + Ctype.with_raised_nongen_level + (fun () -> class_expr cl_num val_env' met_env virt self_scope scl') in + if Btype.is_optional l && not_nolabel_function cl.cl_type then + Location.prerr_warning pat.pat_loc + Warnings.Unerasable_optional_argument; + rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial); + cl_loc = scl.pcl_loc; + cl_type = Cty_arrow + (l, Ctype.instance pat.pat_type, cl.cl_type); + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_apply (scl', sargs) -> + assert (sargs <> []); + let cl = + Ctype.with_local_level_generalize_structure_if_principal + (fun () -> class_expr cl_num val_env met_env virt self_scope scl') + in + let rec nonopt_labels ls ty_fun = + match ty_fun with + | Cty_arrow (l, _, ty_res) -> + if Btype.is_optional l then nonopt_labels ls ty_res + else nonopt_labels (l::ls) ty_res + | _ -> ls + in + let ignore_labels = + !Clflags.classic || + let labels = nonopt_labels [] cl.cl_type in + List.length labels = List.length sargs && + List.for_all (fun (l,_) -> l = Nolabel) sargs && + List.exists (fun l -> l <> Nolabel) labels && + begin + Location.prerr_warning + cl.cl_loc + (Warnings.Labels_omitted + (List.map Asttypes.string_of_label + (List.filter ((<>) Nolabel) labels))); + true + end + in + let rec type_args args omitted ty_fun ty_fun0 sargs = + match ty_fun, ty_fun0 with + | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0) + when sargs <> [] -> + let name = Btype.label_name l + and optional = Btype.is_optional l in + let use_arg sarg l' = + Some ( + if not optional || Btype.is_optional l' then + type_argument val_env sarg ty ty0 + else + let ty' = extract_option_type val_env ty + and ty0' = extract_option_type val_env ty0 in + let arg = type_argument val_env sarg ty' ty0' in + option_some val_env arg + ) + in + let eliminate_optional_arg () = + Some (option_none val_env ty0 Location.none) + in + let remaining_sargs, arg = + if ignore_labels then begin + match sargs with + | [] -> assert false + | (l', sarg) :: remaining_sargs -> + if name = Btype.label_name l' || + (not optional && l' = Nolabel) + then + (remaining_sargs, use_arg sarg l') + else if + optional && + not (List.exists (fun (l, _) -> name = Btype.label_name l) + remaining_sargs) + then + (sargs, eliminate_optional_arg ()) + else + raise(Error(sarg.pexp_loc, val_env, Apply_wrong_label l')) + end else + match Btype.extract_label name sargs with + | Some (l', sarg, _, remaining_sargs) -> + if not optional && Btype.is_optional l' then + Location.prerr_warning sarg.pexp_loc + (Warnings.Nonoptional_label + (Asttypes.string_of_label l)); + remaining_sargs, use_arg sarg l' + | None -> + sargs, + if Btype.is_optional l && List.mem_assoc Nolabel sargs then + eliminate_optional_arg () + else + None + in + let omitted = if arg = None then (l,ty0) :: omitted else omitted in + type_args ((l,arg)::args) omitted ty_fun ty_fun0 remaining_sargs + | _ -> + match sargs with + (l, sarg0)::_ -> + if omitted <> [] then + raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l)) + else + raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type)) + | [] -> + (List.rev args, + List.fold_left + (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun)) + ty_fun0 omitted) + in + let (args, cty) = + let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in + type_args [] [] cl.cl_type ty_fun0 sargs + in + rc {cl_desc = Tcl_apply (cl, args); + cl_loc = scl.pcl_loc; + cl_type = cty; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_let (rec_flag, sdefs, scl') -> + let (defs, val_env) = + Typecore.type_let In_class_def val_env rec_flag sdefs in + let (vals, met_env) = + List.fold_right + (fun (id, _id_loc, _typ, _uid) (vals, met_env) -> + let path = Pident id in + (* do not mark the value as used *) + let vd = Env.find_value path val_env in + let ty = + Ctype.with_local_level_generalize + (fun () -> Ctype.instance vd.val_type) + in + let expr = + {exp_desc = + Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); + exp_loc = Location.none; exp_extra = []; + exp_type = ty; + exp_attributes = []; + exp_env = val_env; + } + in + let desc = + {val_type = expr.exp_type; + val_kind = Val_ivar (Immutable, cl_num); + val_attributes = []; + Types.val_loc = vd.Types.val_loc; + val_uid = vd.val_uid; + } + in + let id' = Ident.create_local (Ident.name id) in + ((id', expr) + :: vals, + Env.add_value id' desc met_env)) + (let_bound_idents_full defs) + ([], met_env) + in + let cl = class_expr cl_num val_env met_env virt self_scope scl' in + let defs = match rec_flag with + | Recursive -> annotate_recursive_bindings val_env defs + | Nonrecursive -> defs + in + rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl); + cl_loc = scl.pcl_loc; + cl_type = cl.cl_type; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_constraint (scl', scty) -> + let cl, clty = + Ctype.with_local_level_for_class begin fun () -> + let cl = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let cl = class_expr cl_num val_env met_env virt self_scope scl' in + complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type; + cl + end + and clty = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let clty = class_type val_env virt self_scope scty in + complete_class_type + clty.cltyp_loc val_env virt Class clty.cltyp_type; + clty + end + in + cl, clty + end + ~post: begin fun ({cl_type=cl}, {cltyp_type=clty}) -> + Ctype.limited_generalize_class_type + (Btype.self_type_row cl) ~inside:cl; + Ctype.limited_generalize_class_type + (Btype.self_type_row clty) ~inside:clty; + end + in + begin match + Includeclass.class_types val_env cl.cl_type clty.cltyp_type + with + [] -> () + | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error)) + end; + let (vals, meths, concrs) = extract_constraints clty.cltyp_type in + let ty = snd (Ctype.instance_class [] clty.cltyp_type) in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type ty); + rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); + cl_loc = scl.pcl_loc; + cl_type = ty; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_open (pod, e) -> + let used_slot = ref false in + let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in + let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in + let cl = class_expr cl_num new_val_env new_met_env virt self_scope e in + rc {cl_desc = Tcl_open (od, cl); + cl_loc = scl.pcl_loc; + cl_type = cl.cl_type; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +(*******************************) + +(* Approximate the type of the constructor to allow recursive use *) +(* of optional parameters *) + +let var_option = Predef.type_option (Btype.newgenvar ()) + +let rec approx_declaration cl = + match cl.pcl_desc with + Pcl_fun (l, _, _, cl) -> + let arg = + if Btype.is_optional l then Ctype.instance var_option + else Ctype.newvar () in + Ctype.newty (Tarrow (l, arg, approx_declaration cl, commu_ok)) + | Pcl_let (_, _, cl) -> + approx_declaration cl + | Pcl_constraint (cl, _) -> + approx_declaration cl + | _ -> Ctype.newvar () + +let rec approx_description ct = + match ct.pcty_desc with + Pcty_arrow (l, _, ct) -> + let arg = + if Btype.is_optional l then Ctype.instance var_option + else Ctype.newvar () in + Ctype.newty (Tarrow (l, arg, approx_description ct, commu_ok)) + | _ -> Ctype.newvar () + +(*******************************) + +let temp_abbrev loc arity uid = + let params = ref [] in + for _i = 1 to arity do + params := Ctype.newvar () :: !params + done; + let ty = Ctype.newobj (Ctype.newvar ()) in + let ty_td = + {type_params = !params; + type_arity = arity; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = Some ty; + type_variance = Variance.unknown_signature ~injective:false ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc; + type_attributes = []; (* or keep attrs from the class decl? *) + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = uid; + } + in + (!params, ty, ty_td) + +let initial_env define_class approx + (res, env) (cl, id, ty_id, obj_id, uid) = + (* Temporary abbreviations *) + let arity = List.length cl.pci_params in + let (obj_params, obj_ty, obj_td) = temp_abbrev cl.pci_loc arity uid in + let env = Env.add_type ~check:true obj_id obj_td env in + let (cl_params, cl_ty, cl_td) = temp_abbrev cl.pci_loc arity uid in + + (* Temporary type for the class constructor *) + let constr_type = + Ctype.with_local_level_generalize_structure_if_principal + (fun () -> approx cl.pci_expr) + in + let dummy_cty = Cty_signature (Ctype.new_class_signature ()) in + let dummy_class = + {Types.cty_params = []; (* Dummy value *) + cty_variance = []; + cty_type = dummy_cty; (* Dummy value *) + cty_path = unbound_class; + cty_new = + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some constr_type + end; + cty_loc = Location.none; + cty_attributes = []; + cty_uid = uid; + } + in + let env = + Env.add_cltype ty_id + {clty_params = []; (* Dummy value *) + clty_variance = []; + clty_type = dummy_cty; (* Dummy value *) + clty_path = unbound_class; + clty_hash_type = cl_td; (* Dummy value *) + clty_loc = Location.none; + clty_attributes = []; + clty_uid = uid; + } + ( + if define_class then + Env.add_class id dummy_class env + else + env + ) + in + ((cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class)::res, + env) + +let class_infos define_class kind + (cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) = + + let ci_params, params, coercion_locs, expr, typ, sign = + Ctype.with_local_level_for_class begin fun () -> + TyVarEnv.reset (); + (* Introduce class parameters *) + let ci_params = + let make_param (sty, v) = + try + (transl_type_param env sty, v) + with Already_bound -> + raise(Error(sty.ptyp_loc, env, Repeated_parameter)) + in + List.map make_param cl.pci_params + in + let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in + + (* Allow self coercions (only for class declarations) *) + let coercion_locs = ref [] in + + (* Type the class expression *) + let (expr, typ) = + try + Typecore.self_coercion := + (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion; + let res = kind env cl.pci_virt cl.pci_expr in + Typecore.self_coercion := List.tl !Typecore.self_coercion; + res + with exn -> + Typecore.self_coercion := []; raise exn + in + let sign = Btype.signature_of_class_type typ in + (ci_params, params, coercion_locs, expr, typ, sign) + end + ~post: begin fun (_, params, _, _, typ, sign) -> + (* Generalize the row variable *) + List.iter + (fun inside -> Ctype.limited_generalize sign.csig_self_row ~inside) + params; + Ctype.limited_generalize_class_type sign.csig_self_row ~inside:typ; + end + in + (* Check the abbreviation for the object type *) + let (obj_params', obj_type) = Ctype.instance_class params typ in + let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in + begin + let row = Btype.self_type_row obj_type in + Ctype.unify env row (Ctype.newty Tnil); + begin try + List.iter2 (Ctype.unify env) obj_params obj_params' + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Bad_parameters (obj_id, obj_params, obj_params'))) + end; + let ty = Btype.self_type obj_type in + begin try + Ctype.unify env ty constr + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) + end + end; + + Ctype.set_object_name obj_id params (Btype.self_type typ); + + (* Check the other temporary abbreviation (#-type) *) + begin + let (cl_params', cl_type) = Ctype.instance_class params typ in + let ty = Btype.self_type cl_type in + begin try + List.iter2 (Ctype.unify env) cl_params cl_params' + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Bad_class_type_parameters (ty_id, cl_params, cl_params'))) + end; + begin try + Ctype.unify env ty cl_ty + with Ctype.Unify _ -> + let ty_expanded = Ctype.object_fields ty in + raise(Error(cl.pci_loc, env, Abbrev_type_clash (ty, ty_expanded, cl_ty))) + end + end; + + (* Type of the class constructor *) + begin try + Ctype.unify env + (constructor_type constr obj_type) + (Ctype.instance constr_type) + with Ctype.Unify err -> + raise(Error(cl.pci_loc, env, + Constructor_type_mismatch (cl.pci_name.txt, err))) + end; + + (* Class and class type temporary definitions *) + let cty_variance = + Variance.unknown_signature ~injective:false ~arity:(List.length params) in + let cltydef = + {clty_params = params; clty_type = Btype.class_body typ; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_td; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + clty_uid = dummy_class.cty_uid; + } + and clty = + {cty_params = params; cty_type = typ; + cty_variance = cty_variance; + cty_path = Path.Pident obj_id; + cty_new = + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some constr_type + end; + cty_loc = cl.pci_loc; + cty_attributes = cl.pci_attributes; + cty_uid = dummy_class.cty_uid; + } + in + dummy_class.cty_type <- typ; + let env = + Env.add_cltype ty_id cltydef ( + if define_class then Env.add_class id clty env else env) + in + + (* Misc. *) + let arity = Btype.class_type_arity typ in + let pub_meths = Btype.public_methods sign in + + (* Final definitions *) + let (params', typ') = Ctype.instance_class params typ in + let clty = + {cty_params = params'; cty_type = typ'; + cty_variance = cty_variance; + cty_path = Path.Pident obj_id; + cty_new = + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some (Ctype.instance constr_type) + end; + cty_loc = cl.pci_loc; + cty_attributes = cl.pci_attributes; + cty_uid = dummy_class.cty_uid; + } + in + let obj_abbr = + let arity = List.length obj_params in + { + type_params = obj_params; + type_arity = arity; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = Some obj_ty; + type_variance = Variance.unknown_signature ~injective:false ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = cl.pci_loc; + type_attributes = []; (* or keep attrs from cl? *) + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = dummy_class.cty_uid; + } + in + let (cl_params, cl_ty) = + Ctype.instance_parameterized_type params (Btype.self_type typ) + in + Ctype.set_object_name obj_id cl_params cl_ty; + let cl_abbr = + { cl_td with + type_params = cl_params; + type_manifest = Some cl_ty + } + in + let cltydef = + {clty_params = params'; clty_type = Btype.class_body typ'; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_abbr; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + clty_uid = dummy_class.cty_uid; + } + in + ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, + arity, pub_meths, List.rev !coercion_locs, expr) :: res, + env) + +let collapse_conj_class_params env (cl, id, clty, _, _, _, _, _, _, _, _, _) = + try Ctype.collapse_conj_params env clty.cty_params + with Ctype.Unify err -> + raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err))) + +let final_decl env define_class + (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, + arity, pub_meths, coe, expr) = + Ctype.nongen_vars_in_class_declaration clty + |> Option.iter (fun vars -> + let nongen_vars = Btype.TypeSet.elements vars in + raise(Error(cl.pci_loc, env + , Non_generalizable_class { id; clty; nongen_vars })); + ); + begin match + Ctype.closed_class clty.cty_params + (Btype.signature_of_class_type clty.cty_type) + with + None -> () + | Some reason -> + let printer = + if define_class + then + Format_doc.doc_printf "%a" (Printtyp.Doc.class_declaration id) clty + else + Format_doc.doc_printf "%a" + (Printtyp.Doc.cltype_declaration id) cltydef + in + raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) + end; + { id; clty; ty_id; cltydef; obj_id; obj_abbr; arity; + pub_meths; coe; + id_loc = cl.pci_name; + req = { ci_loc = cl.pci_loc; + ci_virt = cl.pci_virt; + ci_params = ci_params; + (* TODO : check that we have the correct use of identifiers *) + ci_id_name = cl.pci_name; + ci_id_class = id; + ci_id_class_type = ty_id; + ci_id_object = obj_id; + ci_expr = expr; + ci_decl = clty; + ci_type_decl = cltydef; + ci_attributes = cl.pci_attributes; + } + } +(* (cl.pci_variance, cl.pci_loc)) *) + +let class_infos define_class kind + (cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) = + Builtin_attributes.warning_scope cl.pci_attributes + (fun () -> + class_infos define_class kind + (cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) + ) + +let extract_type_decls { clty; cltydef; obj_id; obj_abbr; req} decls = + (obj_id, obj_abbr, clty, cltydef, req) :: decls + +let merge_type_decls decl (obj_abbr, clty, cltydef) = + {decl with obj_abbr; clty; cltydef} + +let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr; } = + (* Add definitions after cleaning them *) + Env.add_type ~check:true obj_id + (Subst.type_declaration Subst.identity obj_abbr) ( + Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) ( + if define_class then + Env.add_class id (Subst.class_declaration Subst.identity clty) env + else env)) + +(* Check that #c is coercible to c if there is a self-coercion *) +let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr; + arity; pub_meths; coe; req } = + let cl_abbr = cltydef.clty_hash_type in + begin match coe with [] -> () + | loc :: _ -> + let cl_ty, obj_ty = + match cl_abbr.type_manifest, obj_abbr.type_manifest with + Some cl_ab, Some obj_ab -> + let cl_params, cl_ty = + Ctype.instance_parameterized_type cl_abbr.type_params cl_ab + and obj_params, obj_ty = + Ctype.instance_parameterized_type obj_abbr.type_params obj_ab + in + List.iter2 (Ctype.unify env) cl_params obj_params; + cl_ty, obj_ty + | _ -> assert false + in + begin try Ctype.subtype env cl_ty obj_ty () + with Ctype.Subtype err -> + raise(Typecore.Error(loc, env, Typecore.Not_subtype err)) + end; + if not (Ctype.opened_object cl_ty) then + raise(Error(loc, env, Cannot_coerce_self obj_ty)) + end; + {cls_id = id; + cls_id_loc = id_loc; + cls_decl = clty; + cls_ty_id = ty_id; + cls_ty_decl = cltydef; + cls_obj_id = obj_id; + cls_obj_abbr = obj_abbr; + cls_abbr = cl_abbr; + cls_arity = arity; + cls_pub_methods = pub_meths; + cls_info=req} + +(*******************************) + +let type_classes define_class approx kind env cls = + let scope = Ctype.create_scope () in + let cls = + List.map + (function cl -> + (cl, + Ident.create_scoped ~scope cl.pci_name.txt, + Ident.create_scoped ~scope cl.pci_name.txt, + Ident.create_scoped ~scope cl.pci_name.txt, + Uid.mk ~current_unit:(Env.get_current_unit ()) + )) + cls + in + let res, env = + Ctype.with_local_level_generalize_for_class begin fun () -> + let (res, env) = + List.fold_left (initial_env define_class approx) ([], env) cls + in + let (res, env) = + List.fold_right (class_infos define_class kind) res ([], env) + in + List.iter (collapse_conj_class_params env) res; + res, env + end + in + let res = List.rev_map (final_decl env define_class) res in + let decls = List.fold_right extract_type_decls res [] in + let decls = + try Typedecl_variance.update_class_decls env decls + with Typedecl_variance.Error(loc, err) -> + raise (Typedecl.Error(loc, Typedecl.Variance err)) + in + let res = List.map2 merge_type_decls res decls in + let env = List.fold_left (final_env define_class) env res in + let res = List.map (check_coercions env) res in + (res, env) + +let class_num = ref 0 +let class_declaration env virt sexpr = + incr class_num; + let self_scope = Ctype.get_current_level () in + let expr = + class_expr (Int.to_string !class_num) env env virt self_scope sexpr + in + complete_class_type expr.cl_loc env virt Class expr.cl_type; + (expr, expr.cl_type) + +let class_description env virt sexpr = + let self_scope = Ctype.get_current_level () in + let expr = class_type env virt self_scope sexpr in + complete_class_type expr.cltyp_loc env virt Class_type expr.cltyp_type; + (expr, expr.cltyp_type) + +let class_declarations env cls = + let info, env = + type_classes true approx_declaration class_declaration env cls + in + let ids, exprs = + List.split + (List.map + (fun ci -> ci.cls_id, ci.cls_info.ci_expr) + info) + in + check_recursive_class_bindings env ids exprs; + info, env + +let class_descriptions env cls = + type_classes true approx_description class_description env cls + +let class_type_declarations env cls = + let (decls, env) = + type_classes false approx_description class_description env cls + in + (List.map + (fun decl -> + {clsty_ty_id = decl.cls_ty_id; + clsty_id_loc = decl.cls_id_loc; + clsty_ty_decl = decl.cls_ty_decl; + clsty_obj_id = decl.cls_obj_id; + clsty_obj_abbr = decl.cls_obj_abbr; + clsty_abbr = decl.cls_abbr; + clsty_info = decl.cls_info}) + decls, + env) + +let type_object env loc s = + incr class_num; + let desc = + class_structure (Int.to_string !class_num) + Concrete Btype.lowest_level Final env env loc s + in + complete_class_signature loc env Concrete Object desc.cstr_type; + let meths = Btype.public_methods desc.cstr_type in + (desc, meths) + +let () = + Typecore.type_object := type_object + +(*******************************) + +(* Check that there is no references through recursive modules (GPR#6491) *) +let rec check_recmod_class_type env cty = + match cty.pcty_desc with + | Pcty_constr(lid, _) -> + ignore (Env.lookup_cltype ~use:false ~loc:lid.loc lid.txt env) + | Pcty_extension _ -> () + | Pcty_arrow(_, _, cty) -> + check_recmod_class_type env cty + | Pcty_open(od, cty) -> + let _, env = !type_open_descr env od in + check_recmod_class_type env cty + | Pcty_signature csig -> + check_recmod_class_sig env csig + +and check_recmod_class_sig env csig = + List.iter + (fun ctf -> + match ctf.pctf_desc with + | Pctf_inherit cty -> check_recmod_class_type env cty + | Pctf_val _ | Pctf_method _ + | Pctf_constraint _ | Pctf_attribute _ | Pctf_extension _ -> ()) + csig.pcsig_fields + +let check_recmod_decl env sdecl = + check_recmod_class_type env sdecl.pci_expr + +(* Approximate the class declaration as class ['params] id = object end *) +let approx_class sdecl = + let open Ast_helper in + let self' = Typ.any () in + let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in + { sdecl with pci_expr = clty' } + +let approx_class_declarations env sdecls = + let decls, env = class_type_declarations env (List.map approx_class sdecls) in + List.iter (check_recmod_decl env) sdecls; + decls, env + +(*******************************) + +(* Error report *) + +open Format_doc + +let non_virtual_string_of_kind : kind -> string = function + | Object -> "object" + | Class -> "non-virtual class" + | Class_type -> "non-virtual class type" + +module Style=Misc.Style +module Printtyp = Printtyp.Doc + +let out_type ppf t = Style.as_inline_code !Oprint.out_type ppf t +let quoted_type ppf t = Style.as_inline_code Printtyp.type_expr ppf t + +let report_error_doc env ppf = + let pp_args ppf args = + let args = List.map (Out_type.tree_of_typexp Type) args in + Style.as_inline_code !Oprint.out_type_args ppf args + in + function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Unconsistent_constraint err -> + let msg = Format_doc.Doc.msg in + fprintf ppf "@[The class constraints are not consistent.@ "; + Errortrace_report.unification ppf env err + (msg "Type") + (msg "is not compatible with type"); + fprintf ppf "@]" + | Field_type_mismatch (k, m, err) -> + let msg = Format_doc.doc_printf in + Errortrace_report.unification ppf env err + (msg "The %s %a@ has type" k Style.inline_code m) + (msg "but is expected to have type") + | Unexpected_field (ty, lab) -> + fprintf ppf + "@[@[<2>This object is expected to have type :@ %a@]\ + @ This type does not have a method %a." + quoted_type ty + Style.inline_code lab + | Structure_expected clty -> + fprintf ppf + "@[This class expression is not a class structure; it has type@ %a@]" + (Style.as_inline_code Printtyp.class_type) clty + | Cannot_apply _ -> + fprintf ppf + "This class expression is not a class function, it cannot be applied" + | Apply_wrong_label l -> + let mark_label ppf = function + | Nolabel -> fprintf ppf "without label" + | l -> fprintf ppf "with label %a" + Style.inline_code (Btype.prefixed_label_name l) + in + fprintf ppf "This argument cannot be applied %a" mark_label l + | Pattern_type_clash ty -> + (* XXX Trace *) + (* XXX Revoir message d'erreur | Improve error message *) + fprintf ppf "@[%s@ %a@]" + "This pattern cannot match self: it only matches values of type" + quoted_type ty + | Unbound_class_2 cl -> + fprintf ppf "@[The class@ %a@ is not yet completely defined@]" + (Style.as_inline_code Printtyp.longident) cl + | Unbound_class_type_2 cl -> + fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" + (Style.as_inline_code Printtyp.longident) cl + | Abbrev_type_clash (abbrev, actual, expected) -> + (* XXX Afficher une trace ? | Print a trace? *) + Out_type.prepare_for_printing [abbrev; actual; expected]; + fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ + but is used with type@ %a@]" + out_type (Out_type.tree_of_typexp Type abbrev) + out_type (Out_type.tree_of_typexp Type actual) + out_type (Out_type.tree_of_typexp Type expected) + | Constructor_type_mismatch (c, err) -> + let msg = Format_doc.doc_printf in + Errortrace_report.unification ppf env err + (msg "The expression %a has type" + Style.inline_code ("new " ^ c) + ) + (msg "but is used with type") + | Virtual_class (kind, mets, vals) -> + let kind = non_virtual_string_of_kind kind in + let missings = + match mets, vals with + [], _ -> "variables" + | _, [] -> "methods" + | _ -> "methods and variables" + in + fprintf ppf + "@[This %s has virtual %s.@ \ + @[<2>The following %s are virtual : %a@]@]" + kind missings missings + (pp_print_list ~pp_sep:pp_print_space Style.inline_code) (mets @ vals) + | Undeclared_methods(kind, mets) -> + let kind = non_virtual_string_of_kind kind in + fprintf ppf + "@[This %s has undeclared virtual methods.@ \ + @[<2>The following methods were not declared : %a@]@]" + kind (pp_print_list ~pp_sep:pp_print_space Style.inline_code) mets + | Parameter_arity_mismatch(lid, expected, provided) -> + fprintf ppf + "@[The class constructor %a@ expects %i type argument(s),@ \ + but is here applied to %i type argument(s)@]" + (Style.as_inline_code Printtyp.longident) lid expected provided + | Parameter_mismatch err -> + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf env err + (msg "The type parameter") + (msg "does not meet its constraint: it should be") + | Bad_parameters (id, params, cstrs) -> + Out_type.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The abbreviation %a@ is used with parameter(s)@ %a@ \ + which are incompatible with constraint(s)@ %a@]" + (Style.as_inline_code Printtyp.ident) id + pp_args params + pp_args cstrs + | Bad_class_type_parameters (id, params, cstrs) -> + let pp_hash ppf id = fprintf ppf "#%a" Printtyp.ident id in + Out_type.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The class type %a@ is used with parameter(s)@ %a,@ \ + whereas the class type definition@ constrains@ \ + those parameters to be@ %a@]" + (Style.as_inline_code pp_hash) id + pp_args params + pp_args cstrs + | Class_match_failure error -> + Includeclass.report_error_doc Type ppf error + | Unbound_val lab -> + fprintf ppf "Unbound instance variable %a" Style.inline_code lab + | Unbound_type_var (msg, reason) -> + let print_reason ppf { Ctype.free_variable; meth; meth_ty; } = + let (ty0, kind) = free_variable in + let ty1 = + match kind with + | Type_variable -> ty0 + | Row_variable -> Btype.newgenty(Tobject(ty0, ref None)) + in + Out_type.add_type_to_preparation meth_ty; + Out_type.add_type_to_preparation ty1; + fprintf ppf + "The method %a@ has type@;<1 2>%a@ where@ %a@ is unbound" + Style.inline_code meth + out_type (Out_type.tree_of_typexp Type meth_ty) + out_type (Out_type.tree_of_typexp Type ty0) + in + fprintf ppf + "@[@[Some type variables are unbound in this type:@;<1 2>%a@]@ \ + @[%a@]@]" + pp_doc msg print_reason reason + | Non_generalizable_class {id; clty; nongen_vars } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in + Out_type.prepare_for_printing nongen_vars; + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + (Style.as_inline_code @@ Printtyp.class_declaration id) clty + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + (Style.as_inline_code Out_type.prepared_type_scheme) + ) nongen_vars + Misc.print_see_manual manual_ref + + | Cannot_coerce_self ty -> + fprintf ppf + "@[The type of self cannot be coerced to@ \ + the type of the current class:@ %a.@.\ + Some occurrences are contravariant@]" + (Style.as_inline_code Printtyp.type_scheme) ty + | Non_collapsable_conjunction (id, clty, err) -> + let msg = Format_doc.Doc.msg in + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains non-collapsible conjunctive types in constraints.@ %t@]" + (Style.as_inline_code @@ Printtyp.class_declaration id) clty + (fun ppf -> Errortrace_report.unification ppf env err + (msg "Type") + (msg "is not compatible with type") + ) + | Self_clash err -> + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf env err + (msg "This object is expected to have type") + (msg "but actually has type") + | Mutability_mismatch (_lab, mut) -> + let mut1, mut2 = + if mut = Immutable then "mutable", "immutable" + else "immutable", "mutable" in + fprintf ppf + "@[The instance variable is %s;@ it cannot be redefined as %s@]" + mut1 mut2 + | No_overriding (_, "") -> + fprintf ppf + "@[This inheritance does not override any methods@ \ + or instance variables@ but is explicitly marked as@ \ + overriding with %a.@]" + Style.inline_code "!" + | No_overriding (kind, name) -> + fprintf ppf "@[The %s %a@ has no previous definition@]" kind + Style.inline_code name + | Duplicate (kind, name) -> + fprintf ppf "@[The %s %a@ has multiple definitions in this object@]" + kind Style.inline_code name + | Closing_self_type sign -> + fprintf ppf + "@[Cannot close type of object literal:@ %a@,\ + it has been unified with the self type of a class that is not yet@ \ + completely defined.@]" + (Style.as_inline_code Printtyp.type_scheme) sign.csig_self + +let report_error_doc env ppf err = + Printtyp.wrap_printing_env ~error:true + env (fun () -> report_error_doc env ppf err) + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (Location.error_of_printer ~loc (report_error_doc env) err) + | Error_forward err -> + Some err + | _ -> + None + ) + +let report_error = Format_doc.compat1 report_error_doc diff --git a/upstream/ocaml_503/typing/typeclass.mli b/upstream/ocaml_503/typing/typeclass.mli new file mode 100644 index 000000000..89e230d14 --- /dev/null +++ b/upstream/ocaml_503/typing/typeclass.mli @@ -0,0 +1,137 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Types +type 'a class_info = { + cls_id : Ident.t; + cls_id_loc : string loc; + cls_decl : class_declaration; + cls_ty_id : Ident.t; + cls_ty_decl : class_type_declaration; + cls_obj_id : Ident.t; + cls_obj_abbr : type_declaration; + cls_abbr : type_declaration; + cls_arity : int; + cls_pub_methods : string list; + cls_info : 'a; +} + +type class_type_info = { + clsty_ty_id : Ident.t; + clsty_id_loc : string loc; + clsty_ty_decl : class_type_declaration; + clsty_obj_id : Ident.t; + clsty_obj_abbr : type_declaration; + clsty_abbr : type_declaration; + clsty_info : Typedtree.class_type_declaration; +} + +val class_declarations: + Env.t -> Parsetree.class_declaration list -> + Typedtree.class_declaration class_info list * Env.t + +(* +and class_declaration = + (class_expr, Types.class_declaration) class_infos +*) + +val class_descriptions: + Env.t -> Parsetree.class_description list -> + Typedtree.class_description class_info list * Env.t + +(* +and class_description = + (class_type, unit) class_infos +*) + +val class_type_declarations: + Env.t -> Parsetree.class_description list -> class_type_info list * Env.t + +(* +and class_type_declaration = + (class_type, Types.class_type_declaration) class_infos +*) + +val approx_class_declarations: + Env.t -> Parsetree.class_description list -> class_type_info list * Env.t + +(* +val type_classes : + bool -> + ('a -> Types.type_expr) -> + (Env.t -> 'a -> 'b * Types.class_type) -> + Env.t -> + 'a Parsetree.class_infos list -> + ( Ident.t * Types.class_declaration * + Ident.t * Types.class_type_declaration * + Ident.t * Types.type_declaration * + Ident.t * Types.type_declaration * + int * string list * 'b * 'b Typedtree.class_infos) + list * Env.t +*) + +type kind = + | Object + | Class + | Class_type + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | Structure_expected of class_type + | Cannot_apply of class_type + | Apply_wrong_label of arg_label + | Pattern_type_clash of type_expr + | Repeated_parameter + | Unbound_class_2 of Longident.t + | Unbound_class_type_2 of Longident.t + | Abbrev_type_clash of type_expr * type_expr * type_expr + | Constructor_type_mismatch of string * Errortrace.unification_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | Class_match_failure of Ctype.class_match_failure list + | Unbound_val of string + | Unbound_type_var of Format_doc.t * Ctype.closed_class_failure + | Non_generalizable_class of + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } + | Cannot_coerce_self of type_expr + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +val report_error : Env.t -> Format.formatter -> error -> unit +val report_error_doc : Env.t -> error Format_doc.printer + +(* Forward decl filled in by Typemod.type_open_descr *) +val type_open_descr : + (?used_slot:bool ref -> + Env.t -> Parsetree.open_description -> Typedtree.open_description * Env.t) + ref diff --git a/upstream/ocaml_503/typing/typecore.ml b/upstream/ocaml_503/typing/typecore.ml new file mode 100644 index 000000000..27a8f95f7 --- /dev/null +++ b/upstream/ocaml_503/typing/typecore.ml @@ -0,0 +1,7083 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Typechecking for the core language *) + +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + +open Misc +open Asttypes +open Parsetree +open Types +open Typedtree +open Btype +open Ctype + +module Style = Misc.Style + +type type_forcing_context = + | If_conditional + | If_no_else_branch + | While_loop_conditional + | While_loop_body + | For_loop_start_index + | For_loop_stop_index + | For_loop_body + | Assert_condition + | Sequence_left_hand_side + | When_guard + +type type_expected = { + ty: type_expr; + explanation: type_forcing_context option; +} + +module Datatype_kind = struct + type t = Record | Variant + + let type_name = function + | Record -> "record" + | Variant -> "variant" + + let label_name = function + | Record -> "field" + | Variant -> "constructor" +end + +type wrong_name = { + type_path: Path.t; + kind: Datatype_kind.t; + name: string loc; + valid_names: string list; +} + +type wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +type contains_gadt = + | Contains_gadt + | No_gadt + +let wrong_kind_sort_of_constructor (lid : Longident.t) = + match lid with + | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> + Boolean + | Lident "[]" | Lident "::" | Ldot(_, "[]") | Ldot(_, "::") -> List + | Lident "()" | Ldot(_, "()") -> Unit + | _ -> Constructor + +type existential_restriction = + | At_toplevel (** no existential types at the toplevel *) + | In_group (** nor with let ... and ... *) + | In_rec (** or recursive definition *) + | With_attributes (** or let[@any_attribute] = ... *) + | In_class_args (** or in class arguments *) + | In_class_def (** or in [class c = let ... in ...] *) + | In_self_pattern (** or in self pattern *) + +type existential_binding = + | Bind_already_bound + | Bind_not_in_scope + | Bind_non_locally_abstract + +type error = + | Constructor_arity_mismatch of Longident.t * int * int + | Label_mismatch of Longident.t * Errortrace.unification_error + | Pattern_type_clash : + Errortrace.unification_error * Parsetree.pattern_desc option -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option + * Parsetree.expression option + | Function_arity_type_clash of + { syntactic_arity : int; + type_constraint : type_expr; + trace : Errortrace.unification_error; + } + (* [Function_arity_type_clash { syntactic_arity = n; type_constraint; trace }] + is the type error for the specific case where an n-ary function is + constrained at a type with an arity less than n, e.g.: + {[ + type (_, _) eq = Eq : ('a, 'a) eq + let bad : type a. ?opt:(a, int -> int) eq -> unit -> a = + fun ?opt:(Eq = assert false) () x -> x + 1 + ]} + + [type_constraint] is the user-written polymorphic type (in this example + [?opt:(a, int -> int) eq -> unit -> a]) that causes this type clash, and + [trace] is the unification error that signaled the issue. + *) + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } + | Apply_wrong_label of arg_label * type_expr * bool + | Label_multiply_defined of string + | Label_missing of Ident.t list + | Label_not_mutable of Longident.t + | Wrong_name of string * type_expected * wrong_name + | Name_type_mismatch of + Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list + | Invalid_format of string + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_method of string * string list + | Virtual_class of Longident.t + | Private_type of type_expr + | Private_label of Longident.t * type_expr + | Private_constructor of constructor_description * type_expr + | Unbound_instance_variable of string * string list + | Instance_variable_not_mutable of string + | Not_subtype of Errortrace.Subtype.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | Modules_not_allowed + | Cannot_infer_signature + | Not_a_packed_module of type_expr + | Unexpected_existential of existential_restriction * string + | Invalid_interval + | Invalid_for_loop_index + | No_value_clauses + | Exception_pattern_disallowed + | Mixed_value_and_exception_patterns_under_guard + | Effect_pattern_below_toplevel + | Invalid_continuation_pattern + | Inlined_record_escape + | Inlined_record_expected + | Unrefuted_pattern of pattern + | Invalid_extension_constructor_payload + | Not_an_extension_constructor + | Literal_overflow of string + | Unknown_literal of string * char + | Illegal_letrec_pat + | Illegal_letrec_expr + | Illegal_class_expr + | Letop_type_clash of string * Errortrace.unification_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Bind_existential of existential_binding * Ident.t * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + + +let not_principal fmt = + Format_doc.Doc.kmsg (fun x -> Warnings.Not_principal x) fmt + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +(* Forward declaration, to be filled in by Typemod.type_module *) + +let type_module = + ref ((fun _env _md -> assert false) : + Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) + +(* Forward declaration, to be filled in by Typemod.type_open *) + +let type_open : + (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> + Longident.t loc -> Path.t * Env.t) + ref = + ref (fun ?used_slot:_ _ -> assert false) + +let type_open_decl : + (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration + -> open_declaration * Types.signature * Env.t) + ref = + ref (fun ?used_slot:_ _ -> assert false) + +(* Forward declaration, to be filled in by Typemod.type_package *) + +let type_package = + ref (fun _ -> assert false) + +(* Forward declaration, to be filled in by Typeclass.class_structure *) +let type_object = + ref (fun _env _s -> assert false : + Env.t -> Location.t -> Parsetree.class_structure -> + Typedtree.class_structure * string list) + +(* + Saving and outputting type information. + We keep these function names short, because they have to be + called each time we create a record of type [Typedtree.expression] + or [Typedtree.pattern] that will end up in the typed AST. +*) +let re node = + Cmt_format.add_saved_type (Cmt_format.Partial_expression node); + node + +let rp node = + Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Value, node)); + node + +let rcp node = + Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Computation, node)); + node + + +(* Context for inline record arguments; see [type_ident] *) + +type recarg = + | Allowed + | Required + | Rejected + +let mk_expected ?explanation ty = { ty; explanation; } + +let case lhs rhs = + {c_lhs = lhs; c_cont = None; c_guard = None; c_rhs = rhs} + +(* Typing of constants *) + +let type_constant = function + Const_int _ -> instance Predef.type_int + | Const_char _ -> instance Predef.type_char + | Const_string _ -> instance Predef.type_string + | Const_float _ -> instance Predef.type_float + | Const_int32 _ -> instance Predef.type_int32 + | Const_int64 _ -> instance Predef.type_int64 + | Const_nativeint _ -> instance Predef.type_nativeint + +let constant_desc + : Parsetree.constant_desc -> (Asttypes.constant, error) result = + function + | Pconst_integer (i,None) -> + begin + try Ok (Const_int (Misc.Int_literal_converter.int i)) + with Failure _ -> Error (Literal_overflow "int") + end + | Pconst_integer (i,Some 'l') -> + begin + try Ok (Const_int32 (Misc.Int_literal_converter.int32 i)) + with Failure _ -> Error (Literal_overflow "int32") + end + | Pconst_integer (i,Some 'L') -> + begin + try Ok (Const_int64 (Misc.Int_literal_converter.int64 i)) + with Failure _ -> Error (Literal_overflow "int64") + end + | Pconst_integer (i,Some 'n') -> + begin + try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i)) + with Failure _ -> Error (Literal_overflow "nativeint") + end + | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c)) + | Pconst_char c -> Ok (Const_char c) + | Pconst_string (s,loc,d) -> Ok (Const_string (s,loc,d)) + | Pconst_float (f,None)-> Ok (Const_float f) + | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c)) + +let constant const = constant_desc const.pconst_desc + +let constant_or_raise env loc cst = + match constant cst with + | Ok c -> c + | Error err -> raise (Error (loc, env, err)) + +(* Specific version of type_option, using newty rather than newgenty *) + +let type_option ty = + newty (Tconstr(Predef.path_option,[ty], ref Mnil)) + +let mkexp exp_desc exp_type exp_loc exp_env = + { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] } + +let option_none env ty loc = + let lid = Longident.Lident "None" in + let cnone = Env.find_ident_constructor Predef.ident_none env in + mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env + +let option_some env texp = + let lid = Longident.Lident "Some" in + let csome = Env.find_ident_constructor Predef.ident_some env in + mkexp ( Texp_construct(mknoloc lid , csome, [texp]) ) + (type_option texp.exp_type) texp.exp_loc texp.exp_env + +let extract_option_type env ty = + match get_desc (expand_head env ty) with + Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty + | _ -> assert false + +let protect_expansion env ty = + if Env.has_local_constraints env then generic_instance ty else ty + +type record_extraction_result = + | Record_type of Path.t * Path.t * Types.label_declaration list + | Not_a_record_type + | Maybe_a_record_type + +let extract_concrete_typedecl_protected env ty = + extract_concrete_typedecl env (protect_expansion env ty) + +let extract_concrete_record env ty = + match extract_concrete_typedecl_protected env ty with + | Typedecl(p0, p, {type_kind=Type_record (fields, _)}) -> + Record_type (p0, p, fields) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type + | May_have_typedecl -> Maybe_a_record_type + +type variant_extraction_result = + | Variant_type of Path.t * Path.t * Types.constructor_declaration list + | Not_a_variant_type + | Maybe_a_variant_type + +let extract_concrete_variant env ty = + match extract_concrete_typedecl_protected env ty with + | Typedecl(p0, p, {type_kind=Type_variant (cstrs, _)}) -> + Variant_type (p0, p, cstrs) + | Typedecl(p0, p, {type_kind=Type_open}) -> + Variant_type (p0, p, []) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_variant_type + | May_have_typedecl -> Maybe_a_variant_type + +let extract_label_names env ty = + match extract_concrete_record env ty with + | Record_type (_, _,fields) -> List.map (fun l -> l.Types.ld_id) fields + | Not_a_record_type | Maybe_a_record_type -> assert false + +let is_principal ty = + not !Clflags.principal || get_level ty = generic_level + +(* Typing of patterns *) + +(* Simplified patterns for effect continuations *) +let type_continuation_pat env expected_ty sp = + let loc = sp.ppat_loc in + match sp.ppat_desc with + | Ppat_any -> None + | Ppat_var name -> + let id = Ident.create_local name.txt in + let desc = + { val_type = expected_ty; val_kind = Val_reg; + Types.val_loc = loc; val_attributes = []; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } + in + Some (id, desc) + | Ppat_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | _ -> raise (Error (loc, env, Invalid_continuation_pattern)) + +(* unification inside type_exp and type_expect *) +let unify_exp_types loc env ty expected_ty = + (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type + Printtyp.raw_type_expr expected_ty; *) + try + unify env ty expected_ty + with + Unify err -> + raise(Error(loc, env, Expr_type_clash(err, None, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) + +(* helper notation for Pattern_env.t *) +let (!!) (penv : Pattern_env.t) = penv.env + +(* Unification inside type_pat *) +let unify_pat_types loc env ty ty' = + try unify env ty ty' with + | Unify err -> + raise(Error(loc, env, Pattern_type_clash(err, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) + +(* GADT unification inside solve_Ppat_construct and check_counter_example_pat *) +let nothing_equated = TypePairs.create 0 +let unify_pat_types_return_equated_pairs ~refine loc penv ty ty' = + try + if refine then unify_gadt penv ty ty' + else (unify !!penv ty ty'; nothing_equated) + with + | Unify err -> + raise(Error(loc, !!penv, Pattern_type_clash(err, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, !!penv, Typetexp.Variant_tags (l1, l2))) + +let unify_pat_types_refine ~refine loc penv ty ty' = + ignore (unify_pat_types_return_equated_pairs ~refine loc penv ty ty') + +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_pat ?sdesc_for_hint env pat expected_ty = + try unify_pat_types pat.pat_loc env pat.pat_type expected_ty + with Error (loc, env, Pattern_type_clash(err, None)) -> + raise(Error(loc, env, Pattern_type_clash(err, sdesc_for_hint))) + +(* unification of a type with a Tconstr with freshly created arguments *) +let unify_head_only ~refine loc penv ty constr = + let path = cstr_type_path constr in + let decl = Env.find_type path !!penv in + let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in + unify_pat_types_refine ~refine loc penv ty' ty + +(* Creating new conjunctive types is not allowed when typing patterns *) +(* make all Reither present in open variants *) +let finalize_variant pat tag opat r = + let row = + match get_desc (expand_head pat.pat_env pat.pat_type) with + Tvariant row -> r := row; row + | _ -> assert false + in + let f = get_row_field tag row in + begin match row_field_repr f with + | Rabsent -> () (* assert false *) + | Reither (true, [], _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present None) + | Reither (false, ty::tl, _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present (Some ty)); + begin match opat with None -> assert false + | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) + end + | Reither (c, _l, true) when not (has_fixed_explanation row) -> + link_row_field_ext ~inside:f (rf_either [] ~no_arg:c ~matched:false) + | _ -> () + end + (* Force check of well-formedness WHY? *) + (* unify_pat pat.pat_env pat + (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; + row_bound=(); row_fixed=false; row_name=None})); *) + +let has_variants p = + exists_general_pattern + { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with + | (Tpat_variant _) -> true + | _ -> false } p + +let finalize_variants p = + iter_general_pattern + { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with + | Tpat_variant(tag, opat, r) -> + finalize_variant p tag opat r + | _ -> () } p + +(* [type_pat_state] and related types for pattern environment; + these should not be confused with Pattern_env.t, which is a part of the + interface to unification functions in [Ctype] *) +type pattern_variable_kind = + | Std_var + | As_var + | Continuation_var + +type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_kind: pattern_variable_kind; + pv_attributes: attributes; + pv_uid : Uid.t; + } + +type module_variable = + { + mv_id: Ident.t; + mv_name: string Location.loc; + mv_loc: Location.t; + mv_uid: Uid.t + } + +(* Whether or not patterns of the form (module M) are accepted. (If they are, + the idents will be created at the provided scope.) When module patterns are + allowed, the caller should take care to check that the introduced module + bindings' types don't escape their scope; see the callsites in [type_let] + and [type_cases] for examples. + [Modules_ignored] indicates that the typing of patterns should not accumulate + a list of module patterns to unpack. It's no different than using + [Modules_allowed] and then ignoring the accumulated [module_variables] list, + but signals more clearly that the module patterns aren't used in an + interesting way. +*) +type module_patterns_restriction = + | Modules_allowed of { scope: int } + | Modules_rejected + | Modules_ignored + +(* A parallel type to [module_patterns_restriction], though also + tracking the module variables encountered. +*) +type module_variables = + | Modvars_allowed of + { scope: int; + module_variables: module_variable list; + } + | Modvars_rejected + | Modvars_ignored + +type type_pat_state = + { mutable tps_pattern_variables: pattern_variable list; + mutable tps_pattern_force: (unit -> unit) list; + mutable tps_module_variables: module_variables; + (* Mutation will not change the constructor of [tps_module_variables], just + the contained [module_variables] list. [module_variables] could be made + mutable instead, but we felt this made the code more awkward. + *) + } + +let continuation_variable = function + | None -> [] + | Some (id, (desc:Types.value_description)) -> + [{pv_id = id; + pv_type = desc.val_type; + pv_loc = desc.val_loc; + pv_kind = Continuation_var; + pv_attributes = desc.val_attributes; + pv_uid= desc.val_uid}] + +let create_type_pat_state ?cont allow_modules = + let tps_module_variables = + match allow_modules with + | Modules_allowed { scope } -> + Modvars_allowed { scope; module_variables = [] } + | Modules_ignored -> Modvars_ignored + | Modules_rejected -> Modvars_rejected + in + { tps_pattern_variables = continuation_variable cont; + tps_module_variables; + tps_pattern_force = []; + } + +(* Copy mutable fields. Used in typechecking or-patterns. *) +let copy_type_pat_state + { tps_pattern_variables; + tps_module_variables; + tps_pattern_force; + } + = + { tps_pattern_variables; + tps_module_variables; + tps_pattern_force; + } + +let blit_type_pat_state ~src ~dst = + dst.tps_pattern_variables <- src.tps_pattern_variables; + dst.tps_module_variables <- src.tps_module_variables; + dst.tps_pattern_force <- src.tps_pattern_force; +;; + +let maybe_add_pattern_variables_ghost loc_let env pv = + List.fold_right + (fun {pv_id; _} env -> + let name = Ident.name pv_id in + if Env.bound_value name env then env + else begin + Env.enter_unbound_value name + (Val_unbound_ghost_recursive loc_let) env + end + ) pv env + +let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name ty + attrs = + if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt) + tps.tps_pattern_variables + then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt)); + let id = + if is_module then begin + (* Unpack patterns result in both a module declaration and a value + variable of the same name being entered into the environment. (The + module is via [tps_module_variables], and the variable is via + [tps_pattern_variables].) *) + match tps.tps_module_variables with + | Modvars_ignored -> Ident.create_local name.txt + | Modvars_rejected -> + raise (Error (loc, Env.empty, Modules_not_allowed)); + | Modvars_allowed { scope; module_variables } -> + let id = Ident.create_scoped name.txt ~scope in + let module_variables = + { mv_id = id; + mv_name = name; + mv_loc = loc; + mv_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } :: module_variables + in + tps.tps_module_variables <- + Modvars_allowed { scope; module_variables; }; + id + end else + Ident.create_local name.txt + in + let pv_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + tps.tps_pattern_variables <- + {pv_id = id; + pv_type = ty; + pv_loc = loc; + pv_kind = if is_as_variable then As_var else Std_var; + pv_attributes = attrs; + pv_uid} :: tps.tps_pattern_variables; + id, pv_uid + +let sort_pattern_variables vs = + List.sort + (fun {pv_id = x; _} {pv_id = y; _} -> + Stdlib.compare (Ident.name x) (Ident.name y)) + vs + +let enter_orpat_variables loc env p1_vs p2_vs = + (* unify_vars operate on sorted lists *) + + let p1_vs = sort_pattern_variables p1_vs + and p2_vs = sort_pattern_variables p2_vs in + + let rec unify_vars p1_vs p2_vs = + let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in + match p1_vs, p2_vs with + | {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2 + when Ident.equal x1 x2 -> + if x1==x2 then + unify_vars rem1 rem2 + else begin + begin try + unify_var env (newvar ()) t1; + unify env t1 t2 + with + | Unify err -> + raise(Error(loc, env, Or_pattern_type_clash(x1, err))) + end; + (x2,x1)::unify_vars rem1 rem2 + end + | [],[] -> [] + | {pv_id; _}::_, [] | [],{pv_id; _}::_ -> + raise (Error (loc, env, Orpat_vars (pv_id, []))) + | {pv_id = x; _}::_, {pv_id = y; _}::_ -> + let err = + if Ident.name x < Ident.name y + then Orpat_vars (x, vars p2_vs) + else Orpat_vars (y, vars p1_vs) in + raise (Error (loc, env, err)) in + unify_vars p1_vs p2_vs + +let rec build_as_type (env : Env.t) p = + build_as_type_extra env p p.pat_extra + +and build_as_type_extra env p = function + | [] -> build_as_type_aux env p + | ((Tpat_type _ | Tpat_open _ | Tpat_unpack), _, _) :: rest -> + build_as_type_extra env p rest + | (Tpat_constraint {ctyp_type = ty; _}, _, _) :: rest -> + (* If the type constraint is ground, then this is the best type + we can return, so just return an instance (cf. #12313) *) + if free_variables ty = [] then instance ty else + (* Otherwise we combine the inferred type for the pattern with + then non-ground constraint in a non-ambivalent way *) + let as_ty = build_as_type_extra env p rest in + (* [generic_instance] can only be used if the variables of the original + type ([cty.ctyp_type] here) are not at [generic_level], which they are + here. + If we used [generic_instance] we would lose the sharing between + [instance ty] and [ty]. *) + let ty = + with_local_level_generalize_structure (fun () -> instance ty) + in + (* This call to unify may only fail due to missing GADT equations *) + unify_pat_types p.pat_loc env (instance as_ty) (instance ty); + ty + +and build_as_type_aux (env : Env.t) p = + match p.pat_desc with + Tpat_alias(p1,_, _, _) -> build_as_type env p1 + | Tpat_tuple pl -> + let tyl = List.map (build_as_type env) pl in + newty (Ttuple tyl) + | Tpat_construct(_, cstr, pl, vto) -> + let keep = + cstr.cstr_private = Private || cstr.cstr_existentials <> [] || + vto <> None (* be lazy and keep the type for node constraints *) in + if keep then p.pat_type else + let tyl = List.map (build_as_type env) pl in + let ty_args, ty_res, _ = + instance_constructor Keep_existentials_flexible cstr + in + List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty}) + (List.combine pl tyl) ty_args; + ty_res + | Tpat_variant(l, p', _) -> + let ty = Option.map (build_as_type env) p' in + let fields = [l, rf_present ty] in + newty (Tvariant (create_row ~fields ~more:(newvar()) + ~name:None ~fixed:None ~closed:false)) + | Tpat_record (lpl,_) -> + let lbl = snd3 (List.hd lpl) in + if lbl.lbl_private = Private then p.pat_type else + let ty = newvar () in + let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in + let do_label lbl = + let _, ty_arg, ty_res = instance_label ~fixed:false lbl in + unify_pat env {p with pat_type = ty} ty_res; + let refinable = + lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && + match get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in + if refinable then begin + let arg = List.assoc lbl.lbl_pos ppl in + unify_pat env {arg with pat_type = build_as_type env arg} ty_arg + end else begin + let _, ty_arg', ty_res' = instance_label ~fixed:false lbl in + unify_pat_types p.pat_loc env ty_arg ty_arg'; + unify_pat env p ty_res' + end in + Array.iter do_label lbl.lbl_all; + ty + | Tpat_or(p1, p2, row) -> + begin match row with + None -> + let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in + unify_pat env {p2 with pat_type = ty2} ty1; + ty1 + | Some row -> + let Row {fields; fixed; name} = row_repr row in + newty (Tvariant (create_row ~fields ~fixed ~name + ~closed:false ~more:(newvar()))) + end + | Tpat_any | Tpat_var _ | Tpat_constant _ + | Tpat_array _ | Tpat_lazy _ -> p.pat_type + +(* Constraint solving during typing of patterns *) + +let solve_Ppat_poly_constraint tps env loc sty expected_ty = + let cty, ty, force = Typetexp.transl_simple_type_delayed env sty in + unify_pat_types loc env ty (instance expected_ty); + tps.tps_pattern_force <- force :: tps.tps_pattern_force; + match get_desc ty with + | Tpoly (body, tyl) -> + let _, ty' = + with_level ~level:generic_level + (fun () -> instance_poly ~keep_names:true ~fixed:false tyl body) + in + (cty, ty, ty') + | _ -> assert false + +let solve_Ppat_alias env pat = + with_local_level_generalize (fun () -> build_as_type env pat) + +let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty = + let vars = List.map (fun _ -> newgenvar ()) args in + let ty = newgenty (Ttuple vars) in + let expected_ty = generic_instance expected_ty in + unify_pat_types_refine ~refine loc env ty expected_ty; + vars + +let solve_constructor_annotation + tps (penv : Pattern_env.t) name_list sty ty_args ty_ex unify_res = + let expansion_scope = penv.equations_scope in + (* Introduce fresh type names that expand to type variables. + They should eventually be bound to ground types. *) + let ids_decls = + List.map + (fun name -> + let tv = newvar () in + let decl = + new_local_type ~loc:name.loc Definition + ~manifest_and_scope:(tv, Ident.lowest_scope) in + let (id, new_env) = + Env.enter_type ~scope:expansion_scope name.txt decl !!penv in + Pattern_env.set_env penv new_env; + ({name with txt = id}, (decl, tv))) + name_list + in + (* Translate the type annotation using these type names. *) + let cty, ty, force = + with_local_level_generalize_structure + (fun () -> Typetexp.transl_simple_type_delayed !!penv sty) + in + tps.tps_pattern_force <- force :: tps.tps_pattern_force; + (* Only unify the return type after generating the ids *) + unify_res (); + let ty_args = + let ty1 = instance ty and ty2 = instance ty in + match ty_args with + [] -> assert false + | [ty_arg] -> + unify_pat_types cty.ctyp_loc !!penv ty1 ty_arg; + [ty2] + | _ -> + unify_pat_types cty.ctyp_loc !!penv ty1 (newty (Ttuple ty_args)); + match get_desc (expand_head !!penv ty2) with + Ttuple tyl -> tyl + | _ -> assert false + in + if ids_decls <> [] then begin + let ids_decls = List.map (fun (x,dm) -> (x.txt,dm)) ids_decls in + let ids = List.map fst ids_decls in + let rem = + (* First process the existentials introduced by this constructor. + Just need to make their definitions abstract. *) + List.fold_left + (fun rem tv -> + match get_desc tv with + Tconstr(Path.Pident id, [], _) when List.mem_assoc id rem -> + let decl, tv' = List.assoc id ids_decls in + let env = + Env.add_type ~check:false id + {decl with type_manifest = None} !!penv + in + Pattern_env.set_env penv env; + (* We have changed the definition, so clean up *) + Btype.cleanup_abbrev (); + (* Since id is now abstract, this does not create a cycle *) + unify_pat_types cty.ctyp_loc env tv tv'; + List.remove_assoc id rem + | _ -> + raise (Error (cty.ctyp_loc, !!penv, + Unbound_existential (ids, ty)))) + ids_decls ty_ex + in + (* The other type names should be bound to newly introduced existentials. *) + let bound_ids = ref ids in + List.iter + (fun (id, (decl, tv')) -> + let tv' = expand_head !!penv tv' in + begin match get_desc tv' with + | Tconstr (Path.Pident id', [], _) -> + if List.exists (Ident.same id') !bound_ids then + raise (Error (cty.ctyp_loc, !!penv, + Bind_existential (Bind_already_bound, id, tv'))); + (* Both id and id' are Scoped identifiers, so their stamps grow *) + if Ident.scope id' <> penv.equations_scope + || Ident.compare_stamp id id' > 0 then + raise (Error (cty.ctyp_loc, !!penv, + Bind_existential (Bind_not_in_scope, id, tv'))); + bound_ids := id' :: !bound_ids + | _ -> + raise (Error (cty.ctyp_loc, !!penv, + Bind_existential + (Bind_non_locally_abstract, id, tv'))); + end; + let env = + Env.add_type ~check:false id + {decl with type_manifest = Some (duplicate_type tv')} !!penv + in + Pattern_env.set_env penv env) + rem; + if rem <> [] then Btype.cleanup_abbrev (); + end; + ty_args, Some (List.map fst ids_decls, cty) + +let solve_Ppat_construct ~refine tps penv loc constr no_existentials + existential_styp expected_ty = + (* if constructor is gadt, we must verify that the expected type has the + correct head *) + if constr.cstr_generalized then + unify_head_only ~refine loc penv (instance expected_ty) constr; + + (* PR#7214: do not use gadt unification for toplevel lets *) + let unify_res ty_res expected_ty = + let refine = + refine || constr.cstr_generalized && no_existentials = None in + unify_pat_types_return_equated_pairs ~refine loc penv ty_res expected_ty + in + + let ty_args, equated_types, existential_ctyp = + with_local_level_generalize_structure begin fun () -> + let expected_ty = instance expected_ty in + let ty_args, ty_res, equated_types, existential_ctyp = + match existential_styp with + None -> + let ty_args, ty_res, _ = + instance_constructor (Make_existentials_abstract penv) constr + in + ty_args, ty_res, unify_res ty_res expected_ty, None + | Some (name_list, sty) -> + let existential_treatment = + if name_list = [] then + Make_existentials_abstract penv + else + (* we will unify them (in solve_constructor_annotation) with the + local types provided by the user *) + Keep_existentials_flexible + in + let ty_args, ty_res, ty_ex = + instance_constructor existential_treatment constr + in + let equated_types = lazy (unify_res ty_res expected_ty) in + let ty_args, existential_ctyp = + solve_constructor_annotation tps penv name_list sty ty_args ty_ex + (fun () -> ignore (Lazy.force equated_types)) + in + ty_args, ty_res, Lazy.force equated_types, existential_ctyp + in + if constr.cstr_existentials <> [] then + lower_variables_only !!penv penv.Pattern_env.equations_scope ty_res; + (ty_args, equated_types, existential_ctyp) + end + in + if !Clflags.principal && not refine then begin + (* Do not warn for counter-examples *) + let exception Warn_only_once in + try + TypePairs.iter + (fun (t1, t2) -> + if not (fully_generic t1 && fully_generic t2) then + let msg = + Format_doc.doc_printf + "typing this pattern requires considering@ %a@ and@ %a@ as \ + equal.@,\ + But the knowledge of these types" + Printtyp.Doc.type_expr t1 + Printtyp.Doc.type_expr t2 + in + Location.prerr_warning loc (Warnings.Not_principal msg); + raise Warn_only_once) + equated_types + with Warn_only_once -> () + end; + (ty_args, existential_ctyp) + +let solve_Ppat_record_field ~refine loc penv label label_lid record_ty = + with_local_level_generalize_structure begin fun () -> + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in + begin try + unify_pat_types_refine ~refine loc penv ty_res (instance record_ty) + with Error(_loc, _env, Pattern_type_clash(err, _)) -> + raise(Error(label_lid.loc, !!penv, + Label_mismatch(label_lid.txt, err))) + end; + ty_arg + end + +let solve_Ppat_array ~refine loc env expected_ty = + let ty_elt = newgenvar() in + let expected_ty = generic_instance expected_ty in + unify_pat_types_refine ~refine + loc env (Predef.type_array ty_elt) expected_ty; + ty_elt + +let solve_Ppat_lazy ~refine loc env expected_ty = + let nv = newgenvar () in + unify_pat_types_refine ~refine loc env (Predef.type_lazy_t nv) + (generic_instance expected_ty); + nv + +let solve_Ppat_constraint tps loc env sty expected_ty = + let cty, ty, force = + with_local_level_generalize_structure + (fun () -> Typetexp.transl_simple_type_delayed env sty) + in + tps.tps_pattern_force <- force :: tps.tps_pattern_force; + let ty, expected_ty' = instance ty, ty in + unify_pat_types loc env ty (instance expected_ty); + (cty, ty, expected_ty') + +let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = + let arg_type = if no_arg then [] else [newgenvar()] in + let fields = [tag, rf_either ~no_arg arg_type ~matched:true] in + let make_row more = + create_row ~fields ~closed:false ~more ~fixed:None ~name:None + in + let row = make_row (newgenvar ()) in + let expected_ty = generic_instance expected_ty in + (* PR#7404: allow some_private_tag blindly, as it would not unify with + the abstract row variable *) + if tag <> Parmatch.some_private_tag then + unify_pat_types_refine ~refine loc env (newgenty(Tvariant row)) expected_ty; + (arg_type, make_row (newvar ()), instance expected_ty) + +(* Building the or-pattern corresponding to a polymorphic variant type *) +let build_or_pat env loc lid = + let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in + let tyl = List.map (fun _ -> newvar()) decl.type_params in + let row0 = + let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in + match get_desc ty with + Tvariant row when static_row row -> row + | _ -> raise(Error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) + in + let pats, fields = + List.fold_left + (fun (pats,fields) (l,f) -> + match row_field_repr f with + Rpresent None -> + let f = rf_either [] ~no_arg:true ~matched:true in + (l,None) :: pats, + (l, f) :: fields + | Rpresent (Some ty) -> + let f = rf_either [ty] ~no_arg:false ~matched:true in + (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; + pat_type=ty; pat_extra=[]; pat_attributes=[]}) + :: pats, + (l, f) :: fields + | _ -> pats, fields) + ([],[]) (row_fields row0) in + let fields = List.rev fields in + let name = Some (path, tyl) in + let make_row more = + create_row ~fields ~more ~closed:false ~fixed:None ~name in + let ty = newty (Tvariant (make_row (newvar()))) in + let gloc = {loc with Location.loc_ghost=true} in + let row' = ref (make_row (newvar())) in + let pats = + List.map + (fun (l,p) -> + {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; + pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]}) + pats + in + match pats with + [] -> + (* empty polymorphic variants: not possible with the concrete language + but valid at the ast level *) + raise(Error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) + | pat :: pats -> + let r = + List.fold_left + (fun pat pat0 -> + {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; + pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]}) + pat pats in + (path, rp { r with pat_loc = loc }) + +(* Type paths *) + +let rec expand_path env p = + let decl = + try Some (Env.find_type p env) with Not_found -> None + in + match decl with + Some {type_manifest = Some ty} -> + begin match get_desc ty with + Tconstr(p,_,_) -> expand_path env p + | _ -> assert false + end + | _ -> + let p' = Env.normalize_type_path None env p in + if Path.same p p' then p else expand_path env p' + +let compare_type_path env tpath1 tpath2 = + Path.same (expand_path env tpath1) (expand_path env tpath2) + +(* Records *) +exception Wrong_name_disambiguation of Env.t * wrong_name + +let get_constr_type_path ty = + match get_desc ty with + | Tconstr(p, _, _) -> p + | _ -> assert false + +module NameChoice(Name : sig + type t + type usage + val kind: Datatype_kind.t + val get_name: t -> string + val get_type: t -> type_expr + val lookup_all_from_type: + Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list + + (** Some names (for example the fields of inline records) are not + in the typing environment -- they behave as structural labels + rather than nominal labels.*) + val in_env: t -> bool +end) = struct + open Name + + let get_type_path d = get_constr_type_path (get_type d) + + let lookup_from_type env type_path usage lid = + let descrs = lookup_all_from_type lid.loc usage type_path env in + match lid.txt with + | Longident.Lident name -> begin + match + List.find (fun (nd, _) -> get_name nd = name) descrs + with + | descr, use -> + use (); + descr + | exception Not_found -> + let valid_names = List.map (fun (nd, _) -> get_name nd) descrs in + raise (Wrong_name_disambiguation (env, { + type_path; + name = { lid with txt = name }; + kind; + valid_names; + })) + end + | _ -> raise Not_found + + let rec unique eq acc = function + [] -> List.rev acc + | x :: rem -> + if List.exists (eq x) acc then unique eq acc rem + else unique eq (x :: acc) rem + + let ambiguous_types env lbl others = + let tpath = get_type_path lbl in + let others = + List.map (fun (lbl, _) -> get_type_path lbl) others in + let tpaths = unique (compare_type_path env) [tpath] others in + match tpaths with + [_] -> [] + | _ -> let open Printtyp in + wrap_printing_env ~error:true env (fun () -> + Out_type.reset(); strings_of_paths Type tpaths) + + let disambiguate_by_type env tpath lbls = + match lbls with + | (Error _ : _ result) -> raise Not_found + | Ok lbls -> + let check_type (lbl, _) = + let lbl_tpath = get_type_path lbl in + compare_type_path env tpath lbl_tpath + in + List.find check_type lbls + + (* warn if there are several distinct candidates in scope *) + let warn_if_ambiguous warn lid env lbl rest = + if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin + Out_type.Ident_conflicts.reset (); + let paths = ambiguous_types env lbl rest in + let expansion = match Out_type.Ident_conflicts.err_msg () with + | None -> "" + | Some msg -> Format_doc.(asprintf "%a" pp_doc) msg + in + if paths <> [] then + warn lid.loc + (Warnings.Ambiguous_name ([Longident.last lid.txt], + paths, false, expansion)) + end + + (* a non-principal type was used for disambiguation *) + let warn_non_principal warn lid = + let name = Datatype_kind.label_name kind in + warn lid.loc + (not_principal "this type-based %s disambiguation" name) + + (* we selected a name out of the lexical scope *) + let warn_out_of_scope warn lid env tpath = + if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin + let path_s = + Printtyp.wrap_printing_env ~error:true env + (fun () -> Format_doc.asprintf "%a" Printtyp.Doc.type_path tpath) + in + warn lid.loc + (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) + end + + (* warn if the selected name is not the last introduced in scope + -- in these cases the resolution is different from pre-disambiguation OCaml + (this warning is not enabled by default, it is specifically for people + wishing to write backward-compatible code). + *) + let warn_if_disambiguated_name warn lid lbl scope = + match scope with + | Ok ((lab1,_) :: _) when lab1 == lbl -> () + | _ -> + warn lid.loc + (Warnings.Disambiguated_name (get_name lbl)) + + let force_error : ('a, _) result -> 'a = function + | Ok lbls -> lbls + | Error (loc', env', err) -> + Env.lookup_error loc' env' err + + type candidate = t * (unit -> unit) + type nonempty_candidate_filter = + candidate list -> (candidate list, candidate list) result + (** This type is used for candidate filtering functions. + Filtering typically proceeds in several passes, filtering + candidates through increasingly precise conditions. + + We assume that the input list is non-empty, and the output is one of + - [Ok result] for a non-empty list [result] of valid candidates + - [Error candidates] with there are no valid candidates, + and [candidates] is a non-empty subset of the input, typically + the result of the last non-empty filtering step. + *) + + (** [disambiguate] selects a concrete description for [lid] using + some contextual information: + - An optional [expected_type]. + - A list of candidates labels in the current lexical scope, + [candidates_in_scope], that is actually at the type + [(label_descr list, lookup_error) result] so that the + lookup error is only raised when necessary. + - A filtering criterion on candidates in scope [filter_candidates], + representing extra contextual information that can help + candidate selection (see [disambiguate_label_by_ids]). + *) + let disambiguate + ?(warn=Location.prerr_warning) + ?(filter : nonempty_candidate_filter = Result.ok) + usage lid env + expected_type + candidates_in_scope = + let lbl = match expected_type with + | None -> + (* no expected type => no disambiguation *) + begin match filter (force_error candidates_in_scope) with + | Ok [] | Error [] -> assert false + | Error((lbl, _use) :: _rest) -> lbl (* will fail later *) + | Ok((lbl, use) :: rest) -> + use (); + warn_if_ambiguous warn lid env lbl rest; + lbl + end + | Some(tpath0, tpath, principal) -> + (* If [expected_type] is available, the candidate selected + will correspond to the type-based resolution. + There are two reasons to still check the lexical scope: + - for warning purposes + - for extension types, the type environment does not contain + a list of constructors, so using only type-based selection + would fail. + *) + (* note that [disambiguate_by_type] does not + force [candidates_in_scope]: we just skip this case if there + are no candidates in scope *) + begin match disambiguate_by_type env tpath candidates_in_scope with + | lbl, use -> + use (); + if not principal then begin + (* Check if non-principal type is affecting result *) + match (candidates_in_scope : _ result) with + | Error _ -> warn_non_principal warn lid + | Ok lbls -> + match filter lbls with + | Error _ -> warn_non_principal warn lid + | Ok [] -> assert false + | Ok ((lbl', _use') :: rest) -> + let lbl_tpath = get_type_path lbl' in + (* no principality warning if the non-principal + type-based selection corresponds to the last + definition in scope *) + if not (compare_type_path env tpath lbl_tpath) + then warn_non_principal warn lid + else warn_if_ambiguous warn lid env lbl rest; + end; + lbl + | exception Not_found -> + (* look outside the lexical scope *) + match lookup_from_type env tpath usage lid with + | lbl -> + (* warn only on nominal labels; + structural labels cannot be qualified anyway *) + if in_env lbl then warn_out_of_scope warn lid env tpath; + if not principal then warn_non_principal warn lid; + lbl + | exception Not_found -> + match filter (force_error candidates_in_scope) with + | Ok lbls | Error lbls -> + let tp = (tpath0, expand_path env tpath) in + let tpl = + List.map + (fun (lbl, _) -> + let tp0 = get_type_path lbl in + let tp = expand_path env tp0 in + (tp0, tp)) + lbls + in + raise (Error (lid.loc, env, + Name_type_mismatch (kind, lid.txt, tp, tpl))); + end + in + (* warn only on nominal labels *) + if in_env lbl then + warn_if_disambiguated_name warn lid lbl candidates_in_scope; + lbl +end + +let wrap_disambiguate msg ty f x = + try f x with + | Wrong_name_disambiguation (env, wrong_name) -> + raise (Error (wrong_name.name.loc, env, Wrong_name (msg, ty, wrong_name))) + +module Label = NameChoice (struct + type t = label_description + type usage = Env.label_usage + let kind = Datatype_kind.Record + let get_name lbl = lbl.lbl_name + let get_type lbl = lbl.lbl_res + let lookup_all_from_type loc usage path env = + Env.lookup_all_labels_from_type ~loc usage path env + let in_env lbl = + match lbl.lbl_repres with + | Record_regular | Record_float | Record_unboxed false -> true + | Record_unboxed true | Record_inlined _ | Record_extension _ -> false +end) + +(* In record-construction expressions and patterns, we have many labels + at once; find a candidate type in the intersection of the candidates + of each label. In the [closed] expression case, this candidate must + contain exactly all the labels. + + If our successive refinements result in an empty list, + return [Error] with the last non-empty list of candidates + for use in error messages. +*) +let disambiguate_label_by_ids closed ids labels : (_, _) result = + let check_ids (lbl, _) = + let lbls = Hashtbl.create 8 in + Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; + List.for_all (Hashtbl.mem lbls) ids + and check_closed (lbl, _) = + (not closed || List.length ids = Array.length lbl.lbl_all) + in + match List.filter check_ids labels with + | [] -> Error labels + | labels -> + match List.filter check_closed labels with + | [] -> Error labels + | labels -> + Ok labels + +(* Only issue warnings once per record constructor/pattern *) +let disambiguate_lid_a_list loc closed env usage expected_type lid_a_list = + let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in + let w_pr = ref false and w_amb = ref [] + and w_scope = ref [] and w_scope_ty = ref "" in + let warn loc msg = + let open Warnings in + match msg with + | Not_principal _ -> w_pr := true + | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb + | Name_out_of_scope(ty, [s], _) -> + w_scope := s :: !w_scope; w_scope_ty := ty + | _ -> Location.prerr_warning loc msg + in + let process_label lid = + let scope = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in + let filter : Label.nonempty_candidate_filter = + disambiguate_label_by_ids closed ids in + Label.disambiguate ~warn ~filter usage lid env expected_type scope in + let lbl_a_list = + (* If one label is qualified [{ foo = ...; M.bar = ... }], + we will disambiguate all labels using one of the qualifying modules, + as if the user had written [{ M.foo = ...; M.bar = ... }]. + + #11630: It is important to process first the + user-qualified labels, instead of processing all labels in + order, so that error messages coming from the lookup of + M (maybe no such module/path exists) are shown to the user + in context of a qualified field [M.bar] they wrote + themselves, instead of the "ghost" qualification [M.foo] + that does not come from the source program. *) + let lbl_list = + List.map (fun (lid, _) -> + match lid.txt with + | Longident.Ldot _ -> Some (process_label lid) + | _ -> None + ) lid_a_list + in + (* Find a module prefix (if any) to qualify unqualified labels *) + let qual = + List.find_map (function + | {txt = Longident.Ldot (modname, _); _}, _ -> Some modname + | _ -> None + ) lid_a_list + in + (* Prefix unqualified labels with [qual] and resolve them. + + Prefixing unqualified labels does not change the final + disambiguation result, it restricts the set of candidates + without removing any valid choice. + It matters if users activated warnings for ambiguous or + out-of-scope resolutions -- they get less warnings by + qualifying at least one of the fields. *) + List.map2 (fun lid_a lbl -> + match lbl, lid_a with + | Some lbl, (lid, a) -> lid, lbl, a + | None, (lid, a) -> + let qual_lid = + match qual, lid.txt with + | Some modname, Longident.Lident s -> + {lid with txt = Longident.Ldot (modname, s)} + | _ -> lid + in + lid, process_label qual_lid, a + ) lid_a_list lbl_list + in + if !w_pr then + Location.prerr_warning loc + (not_principal "this type-based record disambiguation") + else begin + match List.rev !w_amb with + (_,types,ex)::_ as amb -> + let paths = + List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in + let path = List.hd paths in + let fst3 (x,_,_) = x in + if List.for_all (compare_type_path env path) (List.tl paths) then + Location.prerr_warning loc + (Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex)) + else + List.iter + (fun (s,l,ex) -> Location.prerr_warning loc + (Warnings.Ambiguous_name ([s],l,false, ex))) + amb + | _ -> () + end; + if !w_scope <> [] then + Location.prerr_warning loc + (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true)); + lbl_a_list + +let map_fold_cont f xs k = + List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys))) + xs (fun ys -> k (List.rev ys)) [] + +let type_label_a_list loc closed env usage type_lbl_a expected_type lid_a_list = + let lbl_a_list = + disambiguate_lid_a_list loc closed env usage expected_type lid_a_list + in + (* Invariant: records are sorted in the typed tree *) + let lbl_a_list = + List.sort + (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) + lbl_a_list + in + List.map type_lbl_a lbl_a_list + +(* Checks over the labels mentioned in a record pattern: + no duplicate definitions (error); properly closed (warning) *) + +let check_recordpat_labels loc lbl_pat_list closed = + match lbl_pat_list with + | [] -> () (* should not happen *) + | (_, label1, _) :: _ -> + let all = label1.lbl_all in + let defined = Array.make (Array.length all) false in + let check_defined (_, label, _) = + if defined.(label.lbl_pos) + then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name)) + else defined.(label.lbl_pos) <- true in + List.iter check_defined lbl_pat_list; + if closed = Closed + && Warnings.is_active (Warnings.Missing_record_field_pattern "") + then begin + let undefined = ref [] in + for i = 0 to Array.length all - 1 do + if not defined.(i) then undefined := all.(i).lbl_name :: !undefined + done; + if !undefined <> [] then begin + let u = String.concat ", " (List.rev !undefined) in + Location.prerr_warning loc (Warnings.Missing_record_field_pattern u) + end + end + +(* Constructors *) + +module Constructor = NameChoice (struct + type t = constructor_description + type usage = Env.constructor_usage + let kind = Datatype_kind.Variant + let get_name cstr = cstr.cstr_name + let get_type cstr = cstr.cstr_res + let lookup_all_from_type loc usage path env = + match Env.lookup_all_constructors_from_type ~loc usage path env with + | _ :: _ as x -> x + | [] -> + match (Env.find_type path env).type_kind with + | Type_open -> + (* Extension constructors cannot be found by looking at the type + declaration. + We scan the whole environment to get an accurate spellchecking + hint in the subsequent error message *) + let filter lbl = + compare_type_path env + path (get_constr_type_path @@ get_type lbl) in + let add_valid x acc = if filter x then (x,ignore)::acc else acc in + Env.fold_constructors add_valid None env [] + | _ -> [] + let in_env _ = true +end) + +(* Typing of patterns *) + +(* "untyped" cases are prior to checking the pattern. *) +type untyped_case = Parsetree.pattern Parmatch.parmatch_case + +(* "half typed" cases are produced in [map_half_typed_cases] when we've just + typechecked the pattern but haven't type-checked the body yet. At this point + we might have added some type equalities to the environment, but haven't yet + added identifiers bound by the pattern. *) +type ('case_pattern, 'case_data) half_typed_case = + { typed_pat: 'case_pattern; + pat_type_for_unif: type_expr; + untyped_case : untyped_case; + case_data : 'case_data; + branch_env: Env.t; + pat_vars: pattern_variable list; + module_vars: module_variables; + contains_gadt: bool; } + +(* Used to split patterns into value cases and exception cases. *) +let split_half_typed_cases env zipped_cases = + let add_case lst htc data = function + | None -> lst + | Some split_pat -> + ({ htc.untyped_case with pattern = split_pat }, data) :: lst + in + List.fold_right (fun (htc, data) (vals, exns) -> + let pat = htc.typed_pat in + match split_pattern pat with + | Some _, Some _ when htc.untyped_case.has_guard -> + raise (Error (pat.pat_loc, env, + Mixed_value_and_exception_patterns_under_guard)) + | vp, ep -> add_case vals htc data vp, add_case exns htc data ep + ) zipped_cases ([], []) + +let rec has_literal_pattern p = match p.ppat_desc with + | Ppat_constant _ + | Ppat_interval _ -> + true + | Ppat_any + | Ppat_variant (_, None) + | Ppat_construct (_, None) + | Ppat_type _ + | Ppat_var _ + | Ppat_unpack _ + | Ppat_extension _ -> + false + | Ppat_exception p + | Ppat_variant (_, Some p) + | Ppat_construct (_, Some (_, p)) + | Ppat_constraint (p, _) + | Ppat_alias (p, _) + | Ppat_lazy p + | Ppat_open (_, p) -> + has_literal_pattern p + | Ppat_tuple ps + | Ppat_array ps -> + List.exists has_literal_pattern ps + | Ppat_record (ps, _) -> + List.exists (fun (_,p) -> has_literal_pattern p) ps + | Ppat_effect (p, q) + | Ppat_or (p, q) -> + has_literal_pattern p || has_literal_pattern q + +let check_scope_escape loc env level ty = + try Ctype.check_scope_escape env level ty + with Escape esc -> + (* We don't expand the type here because if we do, we might expand to the + type that escaped, leading to confusing error messages. *) + let trace = Errortrace.[Escape (map_escape trivial_expansion esc)] in + raise (Error(loc, + env, + Pattern_type_clash(Errortrace.unification_error ~trace, None))) + + +(** The typedtree has two distinct syntactic categories for patterns, + "value" patterns, matching on values, and "computation" patterns + that match on the effect of a computation -- typically, exception + patterns (exception p). + + On the other hand, the parsetree has an unstructured representation + where all categories of patterns are mixed together. The + decomposition according to the value/computation structure has to + happen during type-checking. + + We don't want to duplicate the type-checking logic in two different + functions, depending on the kind of pattern to be produced. In + particular, there are both value and computation or-patterns, and + the type-checking logic for or-patterns is horribly complex; having + it in two different places would be twice as horirble. + + The solution is to pass a GADT tag to [type_pat] to indicate whether + a value or computation pattern is expected. This way, there is a single + place where [Ppat_or] nodes are type-checked, the checking logic is shared, + and only at the end do we inspect the tag to decide to produce a value + or computation pattern. +*) +let pure + : type k . k pattern_category -> value general_pattern -> k general_pattern + = fun category pat -> + match category with + | Value -> pat + | Computation -> as_computation_pattern pat + +let only_impure + : type k . k pattern_category -> + computation general_pattern -> k general_pattern + = fun category pat -> + match category with + | Value -> + (* LATER: this exception could be renamed/generalized *) + raise (Error (pat.pat_loc, pat.pat_env, + Exception_pattern_disallowed)) + | Computation -> pat + +let as_comp_pattern + : type k . k pattern_category -> + k general_pattern -> computation general_pattern + = fun category pat -> + match category with + | Value -> as_computation_pattern pat + | Computation -> pat + +(** [type_pat] propagates the expected type, and + unification may update the typing environment. *) +let rec type_pat + : type k . type_pat_state -> k pattern_category -> + no_existentials: existential_restriction option -> + penv: Pattern_env.t -> Parsetree.pattern -> type_expr -> + k general_pattern + = fun tps category ~no_existentials ~penv sp expected_ty -> + Builtin_attributes.warning_scope sp.ppat_attributes + (fun () -> + type_pat_aux tps category ~no_existentials ~penv sp expected_ty + ) + +and type_pat_aux + : type k . type_pat_state -> k pattern_category -> no_existentials:_ -> + penv:Pattern_env.t -> _ -> _ -> k general_pattern + = fun tps category ~no_existentials ~penv sp expected_ty -> + let type_pat tps category ?(penv=penv) = + type_pat tps category ~no_existentials ~penv + in + let loc = sp.ppat_loc in + let solve_expected (x : pattern) : pattern = + unify_pat ~sdesc_for_hint:sp.ppat_desc !!penv x (instance expected_ty); + x + in + let crp (x : k general_pattern) : k general_pattern = + match category with + | Value -> rp x + | Computation -> rcp x + in + (* record {general,value,computation} pattern *) + let rp = crp + and rvp x = crp (pure category x) + and rcp x = crp (only_impure category x) in + match sp.ppat_desc with + Ppat_any -> + rvp { + pat_desc = Tpat_any; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_var name -> + let ty = instance expected_ty in + let id, uid = enter_variable tps loc name ty sp.ppat_attributes in + rvp { + pat_desc = Tpat_var (id, name, uid); + pat_loc = loc; pat_extra=[]; + pat_type = ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_unpack name -> + let t = instance expected_ty in + begin match name.txt with + | None -> + rvp { + pat_desc = Tpat_any; + pat_loc = sp.ppat_loc; + pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes]; + pat_type = t; + pat_attributes = []; + pat_env = !!penv } + | Some s -> + let v = { name with txt = s } in + (* We're able to pass ~is_module:true here without an error because + [Ppat_unpack] is a case identified by [may_contain_modules]. See + the comment on [may_contain_modules]. *) + let id, uid = + enter_variable tps loc v t ~is_module:true sp.ppat_attributes + in + rvp { + pat_desc = Tpat_var (id, v, uid); + pat_loc = sp.ppat_loc; + pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; + pat_type = t; + pat_attributes = []; + pat_env = !!penv } + end + | Ppat_constraint( + {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs}, + ({ptyp_desc=Ptyp_poly _} as sty)) -> + (* explicitly polymorphic type *) + let cty, ty, ty' = + solve_Ppat_poly_constraint tps !!penv lloc sty expected_ty in + let id, uid = enter_variable tps lloc name ty' attrs in + rvp { pat_desc = Tpat_var (id, name, uid); + pat_loc = lloc; + pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; + pat_type = ty; + pat_attributes = []; + pat_env = !!penv } + | Ppat_alias(sq, name) -> + let q = type_pat tps Value sq expected_ty in + let ty_var = solve_Ppat_alias !!penv q in + let id, uid = + enter_variable + ~is_as_variable:true tps name.loc name ty_var sp.ppat_attributes + in + rvp { pat_desc = Tpat_alias(q, id, name, uid); + pat_loc = loc; pat_extra=[]; + pat_type = q.pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_constant cst -> + let cst = constant_or_raise !!penv loc cst in + rvp @@ solve_expected { + pat_desc = Tpat_constant cst; + pat_loc = loc; pat_extra=[]; + pat_type = type_constant cst; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_interval (c1, c2) -> + let open Ast_helper in + let get_bound = function + | {pconst_desc = Pconst_char c; _} -> c + | {pconst_loc = loc; _} -> + raise (Error (loc, !!penv, Invalid_interval)) + in + let c1 = get_bound c1 in + let c2 = get_bound c2 in + let gloc = {loc with Location.loc_ghost=true} in + let rec loop c1 c2 = + if c1 = c2 then Pat.constant ~loc:gloc (Const.char ~loc:gloc c1) + else + Pat.or_ ~loc:gloc + (Pat.constant ~loc:gloc (Const.char ~loc:gloc c1)) + (loop (Char.chr(Char.code c1 + 1)) c2) + in + let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in + let p = {p with ppat_loc=loc} in + type_pat tps category p expected_ty + (* TODO: record 'extra' to remember about interval *) + | Ppat_tuple spl -> + assert (List.length spl >= 2); + let expected_tys = + solve_Ppat_tuple ~refine:false loc penv spl expected_ty in + let pl = List.map2 (type_pat tps Value) spl expected_tys in + rvp { + pat_desc = Tpat_tuple pl; + pat_loc = loc; pat_extra=[]; + pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl)); + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_construct(lid, sarg) -> + let expected_type = + match extract_concrete_variant !!penv expected_ty with + | Variant_type(p0, p, _) -> + Some (p0, p, is_principal expected_ty) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let error = Wrong_expected_kind(srt, Pattern, expected_ty) in + raise (Error (loc, !!penv, error)) + in + let constr = + let candidates = + Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !!penv in + wrap_disambiguate "This variant pattern is expected to have" + (mk_expected expected_ty) + (Constructor.disambiguate Env.Pattern lid !!penv expected_type) + candidates + in + begin match no_existentials, constr.cstr_existentials with + | None, _ | _, [] -> () + | Some r, (_ :: _) -> + let name = constr.cstr_name in + raise (Error (loc, !!penv, Unexpected_existential (r, name))) + end; + let sarg', existential_styp = + match sarg with + None -> None, None + | Some (vl, {ppat_desc = Ppat_constraint (sp, sty)}) + when vl <> [] || constr.cstr_arity > 1 -> + Some sp, Some (vl, sty) + | Some ([], sp) -> + Some sp, None + | Some (_, sp) -> + raise (Error (sp.ppat_loc, !!penv, Missing_type_constraint)) + in + let sargs = + match sarg' with + None -> [] + | Some {ppat_desc = Ppat_tuple spl} when + constr.cstr_arity > 1 || + Builtin_attributes.explicit_arity sp.ppat_attributes + -> spl + | Some({ppat_desc = Ppat_any} as sp) when + constr.cstr_arity = 0 && existential_styp = None + -> + Location.prerr_warning sp.ppat_loc + Warnings.Wildcard_arg_to_constant_constr; + [] + | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 -> + replicate_list sp constr.cstr_arity + | Some sp -> [sp] in + if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then + begin match List.filter has_literal_pattern sargs with + | sp :: _ -> + Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern + | _ -> () + end; + if List.length sargs <> constr.cstr_arity then + raise(Error(loc, !!penv, Constructor_arity_mismatch(lid.txt, + constr.cstr_arity, List.length sargs))); + + let (ty_args, existential_ctyp) = + solve_Ppat_construct ~refine:false tps penv loc constr no_existentials + existential_styp expected_ty + in + + let rec check_non_escaping p = + match p.ppat_desc with + | Ppat_or (p1, p2) -> + check_non_escaping p1; + check_non_escaping p2 + | Ppat_alias (p, _) -> + check_non_escaping p + | Ppat_constraint _ -> + raise (Error (p.ppat_loc, !!penv, Inlined_record_escape)) + | _ -> + () + in + if constr.cstr_inlined <> None then begin + List.iter check_non_escaping sargs; + Option.iter (fun (_, sarg) -> check_non_escaping sarg) sarg + end; + + let args = List.map2 (type_pat tps Value) sargs ty_args in + rvp { pat_desc=Tpat_construct(lid, constr, args, existential_ctyp); + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_variant(tag, sarg) -> + assert (tag <> Parmatch.some_private_tag); + let constant = (sarg = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine:false loc penv tag constant expected_ty in + let arg = + (* PR#6235: propagate type information *) + match sarg, arg_type with + Some sp, [ty] -> Some (type_pat tps Value sp ty) + | _ -> None + in + rvp { + pat_desc = Tpat_variant(tag, arg, ref row); + pat_loc = loc; pat_extra = []; + pat_type = pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_record(lid_sp_list, closed) -> + assert (lid_sp_list <> []); + let expected_type, record_ty = + match extract_concrete_record !!penv expected_ty with + | Record_type(p0, p, _) -> + let ty = generic_instance expected_ty in + Some (p0, p, is_principal expected_ty), ty + | Maybe_a_record_type -> None, newvar () + | Not_a_record_type -> + let error = Wrong_expected_kind(Record, Pattern, expected_ty) in + raise (Error (loc, !!penv, error)) + in + let type_label_pat (label_lid, label, sarg) = + let ty_arg = + solve_Ppat_record_field ~refine:false loc penv label label_lid + record_ty in + (label_lid, label, type_pat tps Value sarg ty_arg) + in + let make_record_pat lbl_pat_list = + check_recordpat_labels loc lbl_pat_list closed; + { + pat_desc = Tpat_record (lbl_pat_list, closed); + pat_loc = loc; pat_extra=[]; + pat_type = instance record_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv; + } + in + let lbl_a_list = + wrap_disambiguate "This record pattern is expected to have" + (mk_expected expected_ty) + (type_label_a_list loc false !!penv Env.Projection + type_label_pat expected_type) + lid_sp_list + in + rvp @@ solve_expected (make_record_pat lbl_a_list) + | Ppat_array spl -> + let ty_elt = solve_Ppat_array ~refine:false loc penv expected_ty in + let pl = List.map (fun p -> type_pat tps Value p ty_elt) spl in + rvp { + pat_desc = Tpat_array pl; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_or(sp1, sp2) -> + (* Reset pattern forces for just [tps2] because later we append [tps1] and + [tps2]'s pattern forces, and we don't want to duplicate [tps]'s pattern + forces. *) + let tps1 = copy_type_pat_state tps in + let tps2 = {(copy_type_pat_state tps) with tps_pattern_force = []} in + (* Introduce a new level to avoid keeping nodes at intermediate levels *) + let pat_desc = with_local_level_generalize begin fun () -> + (* Introduce a new scope using with_local_level without generalizations *) + let env1, p1, env2, p2 = + with_local_level begin fun () -> + let type_pat_rec tps penv sp = + type_pat tps category sp expected_ty ~penv + in + let penv1 = + Pattern_env.copy ~equations_scope:(get_current_level ()) penv in + let penv2 = Pattern_env.copy penv1 in + let p1 = type_pat_rec tps1 penv1 sp1 in + let p2 = type_pat_rec tps2 penv2 sp2 in + (penv1.env, p1, penv2.env, p2) + end + in + let p1_variables = tps1.tps_pattern_variables in + let p2_variables = tps2.tps_pattern_variables in + (* Make sure no variable with an ambiguous type gets added to the + environment. *) + let outer_lev = get_current_level () in + List.iter (fun { pv_type; pv_loc; _ } -> + check_scope_escape pv_loc env1 outer_lev pv_type + ) p1_variables; + List.iter (fun { pv_type; pv_loc; _ } -> + check_scope_escape pv_loc env2 outer_lev pv_type + ) p2_variables; + let alpha_env = + enter_orpat_variables loc !!penv p1_variables p2_variables in + (* Propagate the outcome of checking the or-pattern back to + the type_pat_state that the caller passed in. + *) + blit_type_pat_state + ~src: + { tps_pattern_variables = tps1.tps_pattern_variables; + (* We want to propagate all pattern forces, regardless of + which branch they were found in. + *) + tps_pattern_force = + tps2.tps_pattern_force @ tps1.tps_pattern_force; + tps_module_variables = tps1.tps_module_variables; + } + ~dst:tps; + let p2 = alpha_pat alpha_env p2 in + Tpat_or (p1, p2, None) + end + in + rp { pat_desc = pat_desc; + pat_loc = loc; pat_extra = []; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_lazy sp1 -> + let nv = solve_Ppat_lazy ~refine:false loc penv expected_ty in + let p1 = type_pat tps Value sp1 nv in + rvp { + pat_desc = Tpat_lazy p1; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_constraint(sp, sty) -> + (* Pretend separate = true *) + let cty, ty, expected_ty' = + solve_Ppat_constraint tps loc !!penv sty expected_ty in + let p = type_pat tps category sp expected_ty' in + let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in + begin match category, (p : k general_pattern) with + | Value, {pat_desc = Tpat_var (id,s,uid); _} -> + { p with + pat_type = ty; + pat_desc = + Tpat_alias + ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s, uid); + pat_extra = [extra]; + } + | _, p -> + { p with pat_type = ty; pat_extra = extra::p.pat_extra } + end + | Ppat_type lid -> + let (path, p) = build_or_pat !!penv loc lid in + pure category @@ solve_expected + { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) + :: p.pat_extra } + | Ppat_open (lid,p) -> + let path, new_env = + !type_open Asttypes.Fresh !!penv sp.ppat_loc lid in + Pattern_env.set_env penv new_env; + let p = type_pat tps category ~penv p expected_ty in + let new_env = !!penv in + begin match Env.remove_last_open path new_env with + | None -> assert false + | Some closed_env -> Pattern_env.set_env penv closed_env + end; + { p with pat_extra = (Tpat_open (path,lid,new_env), + loc, sp.ppat_attributes) :: p.pat_extra } + | Ppat_exception p -> + let p_exn = type_pat tps Value p Predef.type_exn in + rcp { + pat_desc = Tpat_exception p_exn; + pat_loc = sp.ppat_loc; + pat_extra = []; + pat_type = expected_ty; + pat_env = !!penv; + pat_attributes = sp.ppat_attributes; + } + | Ppat_effect _ -> + raise (Error (loc, !!penv, Effect_pattern_below_toplevel)) + | Ppat_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +let iter_pattern_variables_type f : pattern_variable list -> unit = + List.iter (fun {pv_type; _} -> f pv_type) + +let add_pattern_variables ?check ?check_as env pv = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes; pv_uid} env -> + let check = if pv_kind=As_var then check_as else check in + Env.add_value ?check pv_id + {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; + val_attributes = pv_attributes; + val_uid = pv_uid; + } env + ) + pv env + +let add_module_variables env module_variables = + let module_variables_as_list = + match module_variables with + | Modvars_allowed mvs -> mvs.module_variables + | Modvars_ignored | Modvars_rejected -> [] + in + List.fold_left (fun env { mv_id; mv_loc; mv_name; mv_uid } -> + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* This code is parallel to the typing of Pexp_letmodule. However we + omit the call to [Mtype.lower_nongen] as it's not necessary here. + For Pexp_letmodule, the call to [type_module] is done in a raised + level and so needs to be modified to have the correct, outer level. + Here, on the other hand, we're calling [type_module] outside the + raised level, so there's no extra step to take. + *) + let modl, md_shape = + !type_module env + Ast_helper.( + Mod.unpack ~loc:mv_loc + (Exp.ident ~loc:mv_name.loc + (mkloc (Longident.Lident mv_name.txt) + mv_name.loc))) + in + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let md = + { md_type = modl.mod_type; md_attributes = []; + md_loc = mv_name.loc; + md_uid = mv_uid; } + in + Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env + end + ) env module_variables_as_list + +let type_pat tps category ?no_existentials penv = + type_pat tps category ~no_existentials ~penv + +let type_pattern category ~lev env spat expected_ty ?cont allow_modules = + let tps = create_type_pat_state ?cont allow_modules in + let new_penv = Pattern_env.make env + ~equations_scope:lev ~allow_recursive_equations:false in + let pat = type_pat tps category new_penv spat expected_ty in + let { tps_pattern_variables = pvs; + tps_module_variables = mvs; + tps_pattern_force = pattern_forces; + } = tps in + (pat, !!new_penv, pattern_forces, pvs, mvs) + +let type_pattern_list + category no_existentials env spatl expected_tys allow_modules + = + let tps = create_type_pat_state allow_modules in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make env + ~equations_scope ~allow_recursive_equations:false in + let type_pat (attrs, pat) ty = + Builtin_attributes.warning_scope ~ppwarning:false attrs + (fun () -> + type_pat tps category ~no_existentials new_penv pat ty + ) + in + let patl = List.map2 type_pat spatl expected_tys in + let { tps_pattern_variables = pvs; + tps_module_variables = mvs; + tps_pattern_force = pattern_forces; + } = tps in + (patl, !!new_penv, pattern_forces, pvs, mvs) + +let type_class_arg_pattern cl_num val_env met_env l spat = + let tps = create_type_pat_state Modules_rejected in + let nv = newvar () in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make val_env + ~equations_scope ~allow_recursive_equations:false in + let pat = + type_pat tps Value ~no_existentials:In_class_args new_penv spat nv in + if has_variants pat then begin + Parmatch.pressure_variants val_env [pat]; + finalize_variants pat; + end; + List.iter (fun f -> f()) tps.tps_pattern_force; + if is_optional l then unify_pat val_env pat (type_option (newvar ())); + let (pv, val_env, met_env) = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes} + (pv, val_env, met_env) -> + let check s = + if pv_kind = As_var then Warnings.Unused_var s + else Warnings.Unused_var_strict s in + let id' = Ident.rename pv_id in + let val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let val_env = + Env.add_value pv_id + { val_type = pv_type + ; val_kind = Val_reg + ; val_attributes = pv_attributes + ; val_loc = pv_loc + ; val_uid + } + val_env + in + let met_env = + Env.add_value id' ~check + { val_type = pv_type + ; val_kind = Val_ivar (Immutable, cl_num) + ; val_attributes = pv_attributes + ; val_loc = pv_loc + ; val_uid + } + met_env + in + ((id', pv_id, pv_type)::pv, val_env, met_env)) + tps.tps_pattern_variables ([], val_env, met_env) + in + (pat, pv, val_env, met_env) + +let type_self_pattern env spat = + let open Ast_helper in + let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in + let tps = create_type_pat_state Modules_rejected in + let nv = newvar() in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make env + ~equations_scope ~allow_recursive_equations:false in + let pat = + type_pat tps Value ~no_existentials:In_self_pattern new_penv spat nv in + List.iter (fun f -> f()) tps.tps_pattern_force; + pat, tps.tps_pattern_variables + + +(** In [check_counter_example_pat], we will check a counter-example candidate + produced by Parmatch. This is a pattern that represents a set of values by + using or-patterns (p_1 | ... | p_n) to enumerate all alternatives in the + counter-example search. These or-patterns occur at every choice point, + possibly deep inside the pattern. + + Parmatch does not use type information, so this pattern may + exhibit two issues: + - some parts of the pattern may be ill-typed due to GADTs, and + - some wildcard patterns may not match any values: their type is + empty. + + The aim of [check_counter_example_pat] is to refine this untyped pattern + into a well-typed pattern, and ensure that it matches at least one + concrete value. + - It filters ill-typed branches of or-patterns. + (see {!splitting_mode} below) + - It tries to check that wildcard patterns are non-empty. + (see {!explosion_fuel}) + *) + +type counter_example_checking_info = { + explosion_fuel: int; + splitting_mode: splitting_mode; + } +(** + [explosion_fuel] controls the checking of wildcard patterns. We + eliminate potentially-empty wildcard patterns by exploding them + into concrete sub-patterns, for example (K1 _ | K2 _) or + { l1: _; l2: _ }. [explosion_fuel] is the depth limit on wildcard + explosion. Such depth limit is required to avoid non-termination + and compilation-time blowups. + + [splitting_mode] controls the handling of or-patterns. In + [Counter_example] mode, we only need to select one branch that + leads to a well-typed pattern. Checking all branches is expensive, + we use different search strategies (see {!splitting_mode}) to + reduce the number of explored alternatives. + *) + +(** Due to GADT constraints, an or-pattern produced within + a counter-example may have ill-typed branches. Consider for example + + {[ + type _ tag = Int : int tag | Bool : bool tag + ]} + + then [Parmatch] will propose the or-pattern [Int | Bool] whenever + a pattern of type [tag] is required to form a counter-example. For + example, a function expects a (int tag option) and only [None] is + handled by the user-written pattern. [Some (Int | Bool)] is not + well-typed in this context, only the sub-pattern [Some Int] is. + In this example, the expected type coming from the context + suffices to know which or-pattern branch must be chosen. + + In the general case, choosing a branch can have non-local effects + on the typability of the term. For example, consider a tuple type + ['a tag * ...'a...], where the first component is a GADT. All + constructor choices for this GADT lead to a well-typed branch in + isolation (['a] is unconstrained), but choosing one of them adds + a constraint on ['a] that may make the other tuple elements + ill-typed. + + In general, after choosing each possible branch of the or-pattern, + [check_counter_example_pat] has to check the rest of the pattern to + tell if this choice leads to a well-typed term. This may lead to an + explosion of typing/search work -- the rest of the term may in turn + contain alternatives. + + We use careful strategies to try to limit counterexample-checking + time; [splitting_mode] represents those strategies. +*) +and splitting_mode = + | Backtrack_or + (** Always backtrack in or-patterns. + + [Backtrack_or] selects a single alternative from an or-pattern + by using backtracking, trying to choose each branch in turn, and + to complete it into a valid sub-pattern. We call this + "splitting" the or-pattern. + + We use this mode when looking for unused patterns or sub-patterns, + in particular to check a refutation clause (p -> .). + *) + | Refine_or of { inside_nonsplit_or: bool; } + (** Only backtrack when needed. + + [Refine_or] tries another approach for refining or-pattern. + + Instead of always splitting each or-pattern, It first attempts to + find branches that do not introduce new constraints (because they + do not contain GADT constructors). Those branches are such that, + if they fail, all other branches will fail. + + If we find one such branch, we attempt to complete the subpattern + (checking what's outside the or-pattern), ignoring other + branches -- we never consider another branch choice again. If all + branches are constrained, it falls back to splitting the + or-pattern. + + We use this mode when checking exhaustivity of pattern matching. + *) + +(** This exception is only used internally within [check_counter_example_pat], + to jump back to the parent or-pattern in the [Refine_or] strategy. + + Such a parent exists precisely when [inside_nonsplit_or = true]; + it's an invariant that we always setup an exception handler for + [Need_backtrack] when we set this flag. *) +exception Need_backtrack + +(** This exception is only used internally within [check_counter_example_pat]. + We use it to discard counter-example candidates that do not match any + value. *) +exception Empty_branch + +type abort_reason = Adds_constraints | Empty + +(** Remember current typing state for backtracking. + No variable information, as we only backtrack on + patterns without variables (cf. assert statements). + In the GADT mode, [env] may be extended by unification, + and therefore it needs to be saved along with a [snapshot]. *) +type unification_state = + { snapshot: snapshot; + env: Env.t; } +let save_state penv = + { snapshot = Btype.snapshot (); + env = !!penv; } +let set_state s penv = + Btype.backtrack s.snapshot; + Pattern_env.set_env penv s.env + +(** Find the first alternative in the tree of or-patterns for which + [f] does not raise an error. If all fail, the last error is + propagated *) +let rec find_valid_alternative f pat = + match pat.pat_desc with + | Tpat_or(p1,p2,_) -> + (try find_valid_alternative f p1 with + | Empty_branch | Error _ -> find_valid_alternative f p2 + ) + | _ -> f pat + +let no_explosion info = { info with explosion_fuel = 0 } + +let enter_nonsplit_or info = + let splitting_mode = match info.splitting_mode with + | Backtrack_or -> + (* in Backtrack_or mode, or-patterns are always split *) + assert false + | Refine_or _ -> + Refine_or {inside_nonsplit_or = true} + in { info with splitting_mode } + +let rec check_counter_example_pat + ~info ~(penv : Pattern_env.t) type_pat_state tp expected_ty k = + let check_rec ?(info=info) ?(penv=penv) = + check_counter_example_pat ~info ~penv type_pat_state in + let loc = tp.pat_loc in + let refine = true in + let solve_expected (x : pattern) : pattern = + unify_pat_types_refine ~refine x.pat_loc penv x.pat_type + (instance expected_ty); + x + in + (* "make pattern" and "make pattern then continue" *) + let mp ?(pat_type = expected_ty) desc = + { pat_desc = desc; pat_loc = loc; pat_extra=[]; + pat_type = instance pat_type; pat_attributes = []; pat_env = !!penv } in + let mkp k ?pat_type desc = k (mp ?pat_type desc) in + let must_backtrack_on_gadt = + match info.splitting_mode with + | Backtrack_or -> false + | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or + in + match tp.pat_desc with + Tpat_any | Tpat_var _ -> + let k' () = mkp k tp.pat_desc in + if info.explosion_fuel <= 0 then k' () else + let decrease n = {info with explosion_fuel = info.explosion_fuel - n} in + begin match Parmatch.pats_of_type !!penv expected_ty with + | [] -> raise Empty_branch + | [{pat_desc = Tpat_any}] -> k' () + | [tp] -> check_rec ~info:(decrease 1) tp expected_ty k + | tp :: tpl -> + if must_backtrack_on_gadt then raise Need_backtrack; + let tp = + List.fold_left + (fun tp tp' -> {tp with pat_desc = Tpat_or (tp, tp', None)}) + tp tpl + in + check_rec ~info:(decrease 5) tp expected_ty k + end + | Tpat_alias (p, _, _, _) -> check_rec ~info p expected_ty k + | Tpat_constant cst -> + let cst = constant_or_raise !!penv loc (Untypeast.constant cst) in + k @@ solve_expected (mp (Tpat_constant cst) ~pat_type:(type_constant cst)) + | Tpat_tuple tpl -> + assert (List.length tpl >= 2); + let expected_tys = solve_Ppat_tuple ~refine loc penv tpl expected_ty in + let tpl_ann = List.combine tpl expected_tys in + map_fold_cont (fun (p,t) -> check_rec p t) tpl_ann (fun pl -> + mkp k (Tpat_tuple pl) + ~pat_type:(newty (Ttuple(List.map (fun p -> p.pat_type) pl)))) + | Tpat_construct(cstr_lid, constr, targs, _) -> + if constr.cstr_generalized && must_backtrack_on_gadt then + raise Need_backtrack; + let (ty_args, existential_ctyp) = + solve_Ppat_construct + ~refine type_pat_state penv loc constr None None expected_ty + in + map_fold_cont + (fun (p,t) -> check_rec p t) + (List.combine targs ty_args) + (fun args -> + mkp k (Tpat_construct(cstr_lid, constr, args, existential_ctyp))) + | Tpat_variant(tag, targ, _) -> + let constant = (targ = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine loc penv tag constant expected_ty in + let k arg = + mkp k ~pat_type (Tpat_variant(tag, arg, ref row)) + in begin + (* PR#6235: propagate type information *) + match targ, arg_type with + Some p, [ty] -> check_rec p ty (fun p -> k (Some p)) + | _ -> k None + end + | Tpat_record(fields, closed) -> + let record_ty = generic_instance expected_ty in + let type_label_pat (label_lid, label, targ) k = + let ty_arg = + solve_Ppat_record_field ~refine loc penv label label_lid record_ty in + check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) + in + map_fold_cont type_label_pat fields + (fun fields -> mkp k (Tpat_record (fields, closed))) + | Tpat_array tpl -> + let ty_elt = solve_Ppat_array ~refine loc penv expected_ty in + map_fold_cont (fun p -> check_rec p ty_elt) tpl + (fun pl -> mkp k (Tpat_array pl)) + | Tpat_or(tp1, tp2, _) -> + (* We are in counter-example mode, but try to avoid backtracking *) + let must_split = + match info.splitting_mode with + | Backtrack_or -> true + | Refine_or _ -> false in + let state = save_state penv in + let split_or tp = + let type_alternative pat = + set_state state penv; check_rec pat expected_ty k in + find_valid_alternative type_alternative tp + in + if must_split then split_or tp else + let check_rec_result penv tp : (_, abort_reason) result = + let info = enter_nonsplit_or info in + match check_rec ~info tp expected_ty ~penv (fun x -> x) with + | res -> Ok res + | exception Need_backtrack -> Error Adds_constraints + | exception Empty_branch -> Error Empty + in + let p1 = check_rec_result (Pattern_env.copy penv) tp1 in + let p2 = check_rec_result (Pattern_env.copy penv) tp2 in + begin match p1, p2 with + | Error Empty, Error Empty -> + raise Empty_branch + | Error Adds_constraints, Error _ + | Error _, Error Adds_constraints -> + let inside_nonsplit_or = + match info.splitting_mode with + | Backtrack_or -> false + | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or in + if inside_nonsplit_or + then raise Need_backtrack + else split_or tp + | Ok p, Error _ + | Error _, Ok p -> + k p + | Ok p1, Ok p2 -> + mkp k (Tpat_or (p1, p2, None)) + end + | Tpat_lazy tp1 -> + let nv = solve_Ppat_lazy ~refine loc penv expected_ty in + (* do not explode under lazy: PR#7421 *) + check_rec ~info:(no_explosion info) tp1 nv + (fun p1 -> mkp k (Tpat_lazy p1)) + +let check_counter_example_pat ~counter_example_args penv tp expected_ty = + (* [check_counter_example_pat] doesn't use [type_pat_state] in an interesting + way -- one of the functions it calls writes an entry into + [tps_pattern_forces] -- so we can just ignore module patterns. *) + let type_pat_state = create_type_pat_state Modules_ignored in + check_counter_example_pat + ~info:counter_example_args ~penv type_pat_state tp expected_ty (fun x -> x) + +(* this function is passed to Partial.parmatch + to type check gadt nonexhaustiveness *) +let partial_pred ~lev ~splitting_mode ?(explode=0) env expected_ty p = + let penv = Pattern_env.make env + ~equations_scope:lev ~allow_recursive_equations:true in + let state = save_state penv in + let counter_example_args = + { + splitting_mode; + explosion_fuel = explode; + } in + try + let typed_p = + check_counter_example_pat ~counter_example_args penv p expected_ty + in + set_state state penv; + (* types are invalidated but we don't need them here *) + Some typed_p + with Error _ | Empty_branch -> + set_state state penv; + None + +let check_partial + ?(lev=get_current_level ()) env expected_ty loc cases + = + let explode = match cases with [_] -> 5 | _ -> 0 in + let splitting_mode = Refine_or {inside_nonsplit_or = false} in + Parmatch.check_partial + (partial_pred ~lev ~splitting_mode ~explode env expected_ty) + loc cases + +let check_unused + ?(lev=get_current_level ()) env expected_ty cases + = + Parmatch.check_unused + (fun refute pat -> + match + partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5 + env expected_ty pat + with + Some pat' when refute -> + raise (Error (pat.pat_loc, env, Unrefuted_pattern pat')) + | r -> r) + cases + +(** Some delayed checks, to be executed after typing the whole + compilation unit or toplevel phrase *) +let delayed_checks = ref [] +let reset_delayed_checks () = delayed_checks := [] +let add_delayed_check f = + delayed_checks := (f, Warnings.backup ()) :: !delayed_checks + +let force_delayed_checks () = + (* checks may change type levels *) + let snap = Btype.snapshot () in + let w_old = Warnings.backup () in + List.iter + (fun (f, w) -> Warnings.restore w; f ()) + (List.rev !delayed_checks); + Warnings.restore w_old; + reset_delayed_checks (); + Btype.backtrack snap + +let rec final_subexpression exp = + match exp.exp_desc with + Texp_let (_, _, e) + | Texp_sequence (_, e) + | Texp_try (e, _, _) + | Texp_ifthenelse (_, e, _) + | Texp_match (_, {c_rhs=e} :: _, _, _) + | Texp_letmodule (_, _, _, _, e) + | Texp_letexception (_, e) + | Texp_open (_, e) + -> final_subexpression e + | _ -> exp + +(* Generalization criterion for expressions *) + +let rec is_nonexpansive exp = + match exp.exp_desc with + | Texp_ident _ + | Texp_constant _ + | Texp_unreachable + | Texp_function _ + | Texp_array [] -> true + | Texp_let(_rec_flag, pat_exp_list, body) -> + List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && + is_nonexpansive body + | Texp_apply(e, (_,None)::el) -> + is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) + | Texp_match(e, cases, _, _) -> + (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't + care if there are exception patterns. But the previous version enforced + that there be none, so... *) + let contains_exception_pat pat = + exists_general_pattern { f = fun (type k) (p : k general_pattern) -> + match p.pat_desc with + | Tpat_exception _ -> true + | _ -> false } pat + in + is_nonexpansive e && + List.for_all + (fun {c_lhs; c_guard; c_rhs} -> + is_nonexpansive_opt c_guard && is_nonexpansive c_rhs + && not (contains_exception_pat c_lhs) + ) cases + | Texp_tuple el -> + List.for_all is_nonexpansive el + | Texp_construct( _, _, el) -> + List.for_all is_nonexpansive el + | Texp_variant(_, arg) -> is_nonexpansive_opt arg + | Texp_record { fields; extended_expression } -> + Array.for_all + (fun (lbl, definition) -> + match definition with + | Overridden (_, exp) -> + lbl.lbl_mut = Immutable && is_nonexpansive exp + | Kept _ -> true) + fields + && is_nonexpansive_opt extended_expression + | Texp_field(exp, _, _) -> is_nonexpansive exp + | Texp_ifthenelse(_cond, ifso, ifnot) -> + is_nonexpansive ifso && is_nonexpansive_opt ifnot + | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) + | Texp_new (_, _, cl_decl) -> Btype.class_type_arity cl_decl.cty_type > 0 + (* Note: nonexpansive only means no _observable_ side effects *) + | Texp_lazy e -> is_nonexpansive e + | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) -> + let count = ref 0 in + List.for_all + (fun field -> match field.cf_desc with + Tcf_method _ -> true + | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) -> + incr count; is_nonexpansive e + | Tcf_val (_, _, _, Tcfk_virtual _, _) -> + incr count; true + | Tcf_initializer e -> is_nonexpansive e + | Tcf_constraint _ -> true + | Tcf_inherit _ -> false + | Tcf_attribute _ -> true) + fields && + Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) + vars true && + !count = 0 + | Texp_letmodule (_, _, _, mexp, e) + | Texp_open ({ open_expr = mexp; _}, e) -> + is_nonexpansive_mod mexp && is_nonexpansive e + | Texp_pack mexp -> + is_nonexpansive_mod mexp + (* Computations which raise exceptions are nonexpansive, since (raise e) is + equivalent to (raise e; diverge), and a nonexpansive "diverge" can be + produced using lazy values or the relaxed value restriction. + See GPR#1142 *) + | Texp_assert (exp, _) -> + is_nonexpansive exp + | Texp_apply ( + { exp_desc = Texp_ident (_, _, {val_kind = + Val_prim {Primitive.prim_name = + ("%raise" | "%reraise" | "%raise_notrace")}}) }, + [Nolabel, Some e]) -> + is_nonexpansive e + | Texp_array (_ :: _) + | Texp_apply _ + | Texp_try _ + | Texp_setfield _ + | Texp_while _ + | Texp_for _ + | Texp_send _ + | Texp_instvar _ + | Texp_setinstvar _ + | Texp_override _ + | Texp_letexception _ + | Texp_letop _ + | Texp_extension_constructor _ -> + false + +and is_nonexpansive_mod mexp = + match mexp.mod_desc with + | Tmod_ident _ + | Tmod_functor _ -> true + | Tmod_unpack (e, _) -> is_nonexpansive e + | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m + | Tmod_structure str -> + List.for_all + (fun item -> match item.str_desc with + | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ + | Tstr_modtype _ | Tstr_class_type _ -> true + | Tstr_value (_, pat_exp_list) -> + List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list + | Tstr_module {mb_expr=m;_} + | Tstr_open {open_expr=m;_} + | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m + | Tstr_recmodule id_mod_list -> + List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m) + id_mod_list + | Tstr_exception {tyexn_constructor = {ext_kind = Text_decl _}} -> + false (* true would be unsound *) + | Tstr_exception {tyexn_constructor = {ext_kind = Text_rebind _}} -> + true + | Tstr_typext te -> + List.for_all + (function {ext_kind = Text_decl _} -> false + | {ext_kind = Text_rebind _} -> true) + te.tyext_constructors + | Tstr_class _ -> false (* could be more precise *) + | Tstr_attribute _ -> true + ) + str.str_items + | Tmod_apply _ | Tmod_apply_unit _ -> false + +and is_nonexpansive_opt = function + | None -> true + | Some e -> is_nonexpansive e + +let maybe_expansive e = not (is_nonexpansive e) + +let annotate_recursive_bindings env valbinds = + let ids = let_bound_idents valbinds in + List.map + (fun {vb_pat; vb_expr; vb_rec_kind = _; vb_attributes; vb_loc} -> + match (Value_rec_check.is_valid_recursive_expression ids vb_expr) with + | None -> + raise(Error(vb_expr.exp_loc, env, Illegal_letrec_expr)) + | Some vb_rec_kind -> + { vb_pat; vb_expr; vb_rec_kind; vb_attributes; vb_loc}) + valbinds + +let check_recursive_class_bindings env ids exprs = + List.iter + (fun expr -> + if not (Value_rec_check.is_valid_class_expr ids expr) then + raise(Error(expr.cl_loc, env, Illegal_class_expr))) + exprs + +let is_prim ~name funct = + match funct.exp_desc with + | Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name; _}}) -> + prim_name = name + | _ -> false +(* Approximate the type of an expression, for better recursion *) + +let rec approx_type env sty = + match sty.ptyp_desc with + Ptyp_arrow (p, _, sty) -> + let ty1 = if is_optional p then type_option (newvar ()) else newvar () in + newty (Tarrow (p, ty1, approx_type env sty, commu_ok)) + | Ptyp_tuple args -> + newty (Ttuple (List.map (approx_type env) args)) + | Ptyp_constr (lid, ctl) -> + let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in + if List.length ctl <> decl.type_arity then newvar () + else begin + let tyl = List.map (approx_type env) ctl in + newconstr path tyl + end + | Ptyp_poly (_, sty) -> + approx_type env sty + | _ -> newvar () + +let type_pattern_approx env spat = + match spat.ppat_desc with + | Ppat_constraint (_, sty) -> approx_type env sty + | _ -> newvar () + +let type_approx_fun env label default spat ret_ty = + let ty = type_pattern_approx env spat in + let ty = + match label, default with + | (Nolabel | Labelled _), _ -> ty + | Optional _, None -> + unify_pat_types spat.ppat_loc env ty (type_option (newvar ())); + ty + | Optional _, Some _ -> + type_option ty + in + newty (Tarrow (label, ty, ret_ty, commu_ok)) + +let type_approx_constraint env ty constraint_ ~loc = + match constraint_ with + | Pconstraint constrain -> + let ty_constrain = approx_type env constrain in + begin try unify env ty ty_constrain with Unify err -> + raise (Error (loc, env, Expr_type_clash (err, None, None))) + end; + ty_constrain + | Pcoerce (constrain, coerce) -> + let approx_ty_opt = function + | None -> newvar () + | Some sty -> approx_type env sty + in + let ty_constrain = approx_ty_opt constrain + and ty_coerce = approx_type env coerce in + begin try unify env ty ty_constrain with Unify err -> + raise (Error (loc, env, Expr_type_clash (err, None, None))) + end; + ty_coerce + +let type_approx_constraint_opt env ty constraint_ ~loc = + match constraint_ with + | None -> ty + | Some constraint_ -> type_approx_constraint env ty constraint_ ~loc + +let rec type_approx env sexp = + let loc = sexp.pexp_loc in + match sexp.pexp_desc with + Pexp_let (_, _, e) -> type_approx env e + | Pexp_function (params, c, body) -> + type_approx_function env params c body ~loc + | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e + | Pexp_try (e, _) -> type_approx env e + | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) + | Pexp_ifthenelse (_,e,_) -> type_approx env e + | Pexp_sequence (_,e) -> type_approx env e + | Pexp_constraint (e, sty) -> + let ty = type_approx env e in + type_approx_constraint env ty (Pconstraint sty) ~loc + | Pexp_coerce (e, sty1, sty2) -> + let ty = type_approx env e in + type_approx_constraint env ty (Pcoerce (sty1, sty2)) ~loc + | _ -> newvar () + +and type_approx_function env params c body ~loc = + (* We can approximate types up to the first newtype parameter, whereupon + we give up. + *) + match params with + | { pparam_desc = Pparam_val (label, default, pat) } :: params -> + type_approx_fun env label default pat + (type_approx_function env params c body ~loc) + | { pparam_desc = Pparam_newtype _ } :: _ -> + newvar () + | [] -> + let body_ty = + match body with + | Pfunction_body body -> + type_approx env body + | Pfunction_cases ({pc_rhs = e} :: _, _, _) -> + newty (Tarrow (Nolabel, newvar (), type_approx env e, commu_ok)) + | Pfunction_cases ([], _, _) -> + newvar () + in + type_approx_constraint_opt env body_ty c ~loc + +(* List labels in a function type, and whether return type is a variable *) +let rec list_labels_aux env visited ls ty_fun = + let ty = expand_head env ty_fun in + if TypeSet.mem ty visited then + List.rev ls, false + else match get_desc ty with + Tarrow (l, _, ty_res, _) -> + list_labels_aux env (TypeSet.add ty visited) (l::ls) ty_res + | _ -> + List.rev ls, is_Tvar ty + +let list_labels env ty = + let snap = Btype.snapshot () in + let result = + wrap_trace_gadt_instances env (list_labels_aux env TypeSet.empty []) ty + in + Btype.backtrack snap; + result + +(* Check that all univars are safe in a type. Both exp.exp_type and + ty_expected should already be generalized. *) +let check_univars env kind exp ty_expected vars = + let pty = instance ty_expected in + let exp_ty, vars = + with_local_level_generalize begin fun () -> + match get_desc pty with + Tpoly (body, tl) -> + (* Enforce scoping for type_let: + since body is not generic, instance_poly only makes + copies of nodes that have a Tunivar as descendant *) + let _, ty' = instance_poly ~fixed:true tl body in + let vars, exp_ty = instance_parameterized_type vars exp.exp_type in + unify_exp_types exp.exp_loc env exp_ty ty'; + (exp_ty, vars) + | _ -> assert false + end + in + let ty, complete = polyfy env exp_ty vars in + if not complete then + let ty_expected = instance ty_expected in + raise (Error(exp.exp_loc, + env, + Less_general(kind, + Errortrace.unification_error + ~trace:[Ctype.expanded_diff env + ~got:ty ~expected:ty_expected]))) + +(* [check_statement] implements the [non-unit-statement] check. + + This check is called in contexts where the value of the expression is known + to be discarded (eg. the lhs of a sequence). We check that [exp] has type + unit, or has an explicit type annotation; otherwise we raise the + [non-unit-statement] warning. *) + +let check_statement exp = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | Tvar _ -> () + | _ -> + let rec loop {exp_loc; exp_desc; exp_extra; _} = + match exp_desc with + | Texp_let (_, _, e) + | Texp_sequence (_, e) + | Texp_letexception (_, e) + | Texp_letmodule (_, _, _, _, e) -> + loop e + | _ -> + let loc = + match List.find_opt (function + | (Texp_constraint _, _, _) -> true + | _ -> false) exp_extra + with + | Some (_, loc, _) -> loc + | None -> exp_loc + in + Location.prerr_warning loc Warnings.Non_unit_statement + in + loop exp + + +(* [check_partial_application] implements the [ignored-partial-application] + warning (and if [statement] is [true], also [non-unit-statement]). + + If [exp] has a function type, we check that it is not syntactically the + result of a function application, as this is often a bug in certain contexts + (eg the rhs of a let-binding or in the argument of [ignore]). For example, + [ignore (List.map print_int)] written by mistake instead of [ignore (List.map + print_int li)]. + + The check can be disabled by explicitly annotating the expression with a type + constraint, eg [(e : _ -> _)]. + + If [statement] is [true] and the [ignored-partial-application] is {em not} + triggered, then the [non-unit-statement] check is performed (see + [check_statement]). + + If the type of [exp] is not known at the time this function is called, the + check is retried again after typechecking. *) + +let check_partial_application ~statement exp = + let check_statement () = if statement then check_statement exp in + let doit () = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tarrow _ -> + let rec check {exp_desc; exp_loc; exp_extra; _} = + if List.exists (function + | (Texp_constraint _, _, _) -> true + | _ -> false) exp_extra then check_statement () + else begin + match exp_desc with + | Texp_ident _ | Texp_constant _ | Texp_tuple _ + | Texp_construct _ | Texp_variant _ | Texp_record _ + | Texp_field _ | Texp_setfield _ | Texp_array _ + | Texp_while _ | Texp_for _ | Texp_instvar _ + | Texp_setinstvar _ | Texp_override _ | Texp_assert _ + | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable + | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None) + | Texp_function _ -> + check_statement () + | Texp_match (_, cases, eff_cases, _) -> + List.iter (fun {c_rhs; _} -> check c_rhs) cases; + List.iter (fun {c_rhs; _} -> check c_rhs) eff_cases + | Texp_try (e, cases, eff_cases) -> + check e; + List.iter (fun {c_rhs; _} -> check c_rhs) cases; + List.iter (fun {c_rhs; _} -> check c_rhs) eff_cases + | Texp_ifthenelse (_, e1, Some e2) -> + check e1; check e2 + | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e) + | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) -> + check e + | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ -> + Location.prerr_warning exp_loc + Warnings.Ignored_partial_application + end + in + check exp + | _ -> + check_statement () + in + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tvar _ -> + (* The type of [exp] is not known. Delay the check until after + typechecking in order to give a chance for the type to become known + through unification. *) + add_delayed_check doit + | _ -> + doit () + +let pattern_needs_partial_application_check p = + let rec check : type a. a general_pattern -> bool = fun p -> + not (List.exists (function (Tpat_constraint _, _, _) -> true | _ -> false) + p.pat_extra) && + match p.pat_desc with + | Tpat_any -> true + | Tpat_exception _ -> true + | Tpat_or (p1, p2, _) -> check p1 && check p2 + | Tpat_value p -> check (p :> value general_pattern) + | _ -> false + in + check p + +(* Check that a type is generalizable at some level *) +let generalizable level ty = + with_type_mark begin fun mark -> + let rec check ty = + if try_mark_node mark ty then + if get_level ty <= level then raise Exit else iter_type_expr check ty + in + try check ty; true with Exit -> false + end + +(* Hack to allow coercion of self. Will clean-up later. *) +let self_coercion = ref ([] : (Path.t * Location.t list ref) list) + +(* Helpers for type_cases *) + +let contains_variant_either ty = + with_type_mark begin fun mark -> + let rec loop ty = + if try_mark_node mark ty then + begin match get_desc ty with + Tvariant row -> + if not (is_fixed row) then + List.iter + (fun (_,f) -> + match row_field_repr f with Reither _ -> raise Exit | _ -> ()) + (row_fields row); + iter_row loop row + | _ -> + iter_type_expr loop ty + end + in + try loop ty; false with Exit -> true + end + +let shallow_iter_ppat f p = + match p.ppat_desc with + | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ + | Ppat_construct (_, None) + | Ppat_extension _ + | Ppat_type _ | Ppat_unpack _ -> () + | Ppat_array pats -> List.iter f pats + | Ppat_or (p1,p2) + | Ppat_effect(p1, p2) -> f p1; f p2 + | Ppat_variant (_, arg) -> Option.iter f arg + | Ppat_tuple lst -> List.iter f lst + | Ppat_construct (_, Some (_, p)) + | Ppat_exception p | Ppat_alias (p,_) + | Ppat_open (_,p) + | Ppat_constraint (p,_) | Ppat_lazy p -> f p + | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args + +let exists_ppat f p = + let exception Found in + let rec loop p = + if f p then raise Found else (); + shallow_iter_ppat loop p in + match loop p with + | exception Found -> true + | () -> false + +let contains_polymorphic_variant p = + exists_ppat + (function + | {ppat_desc = (Ppat_variant _ | Ppat_type _)} -> true + | _ -> false) + p + +let contains_gadt p = + exists_general_pattern { f = fun (type k) (p : k general_pattern) -> + match p.pat_desc with + | Tpat_construct (_, cd, _, _) when cd.cstr_generalized -> true + | _ -> false } p + +(* There are various things that we need to do in presence of GADT constructors + that aren't required if there are none. + However, because of disambiguation, we can't know for sure whether the + patterns contain some GADT constructors. So we conservatively assume that + any constructor might be a GADT constructor. *) +let may_contain_gadts p = + exists_ppat + (function + | {ppat_desc = Ppat_construct _} -> true + | _ -> false) + p + +(* There are various things that we need to do in presence of module patterns + that aren't required if there are none. Most notably, we need to ensure the + modules are entered at the appropriate scope. The caller should use + [may_contain_modules] as an indication to set up the proper scope handling + code (via [allow_modules]) to permit module patterns. + The class of patterns identified here should stay in sync with the patterns + whose typing involves [enter_variable ~is_module:true], as these calls + will error if the scope handling isn't set up. +*) +let may_contain_modules p = + exists_ppat + (function + | {ppat_desc = Ppat_unpack _} -> true + | _ -> false) + p + +let check_absent_variant env = + iter_general_pattern { f = fun (type k) (pat : k general_pattern) -> + match pat.pat_desc with + | Tpat_variant (s, arg, row) -> + let row = !row in + if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent) + (row_fields row) + || not (is_fixed row) && not (static_row row) (* same as Ctype.poly *) + then () else + let ty_arg = + match arg with None -> [] | Some p -> [duplicate_type p.pat_type] in + let fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in + let row' = + create_row ~fields + ~more:(newvar ()) ~closed:false ~fixed:None ~name:None in + (* Should fail *) + unify_pat env {pat with pat_type = newty (Tvariant row')} + (duplicate_type pat.pat_type) + | _ -> () } + +(* Getting proper location of already typed expressions. + + Used to avoid confusing locations on type error messages in presence of + type constraints. + For example: + + (* Before patch *) + # let x : string = (5 : int);; + ^ + (* After patch *) + # let x : string = (5 : int);; + ^^^^^^^^^ +*) +let proper_exp_loc exp = + let rec aux = function + | [] -> exp.exp_loc + | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc + | _ :: rest -> aux rest + in + aux exp.exp_extra + +(* To find reasonable names for let-bound and lambda-bound idents *) + +let rec name_pattern default = function + [] -> Ident.create_local default + | p :: rem -> + match p.pat_desc with + Tpat_var (id, _, _) -> id + | Tpat_alias(_, id, _, _) -> id + | _ -> name_pattern default rem + +let name_cases default lst = + name_pattern default (List.map (fun c -> c.c_lhs) lst) + +(* Typing of expressions *) + +(** [sexp_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_exp ~sexp env exp expected_ty = + let loc = proper_exp_loc exp in + try + unify_exp_types loc env exp.exp_type expected_ty + with Error(loc, env, Expr_type_clash(err, tfc, None)) -> + raise (Error(loc, env, Expr_type_clash(err, tfc, Some sexp))) + +(* If [is_inferred e] is true, [e] will be typechecked without using + the "expected type" provided by the context. *) + +let rec is_inferred sexp = + match sexp.pexp_desc with + | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _ + | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true + | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e + | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 + | _ -> false + +(* check if the type of %apply or %revapply matches the type expected by + the specialized typing rule for those primitives. +*) +type apply_prim = + | Apply + | Revapply +let check_apply_prim_type prim typ = + match get_desc typ with + | Tarrow (Nolabel,a,b,_) -> + begin match get_desc b with + | Tarrow(Nolabel,c,d,_) -> + let f, x, res = + match prim with + | Apply -> a, c, d + | Revapply -> c, a, d + in + begin match get_desc f with + | Tarrow(Nolabel,fl,fr,_) -> + is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res + && Types.eq_type fl x && Types.eq_type fr res + | _ -> false + end + | _ -> false + end + | _ -> false + +(* Merge explanation to type clash error *) + +let with_explanation explanation f = + match explanation with + | None -> f () + | Some explanation -> + try f () + with Error (loc', env', Expr_type_clash(err', None, exp')) + when not loc'.Location.loc_ghost -> + let err = Expr_type_clash(err', Some explanation, exp') in + raise (Error (loc', env', err)) + +(* Generalize expressions *) +let may_lower_contravariant env exp = + if maybe_expansive exp then lower_contravariant env exp.exp_type + +(* value binding elaboration *) + +let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; _ } = + let open Ast_helper in + match ct with + | None -> expr + | Some (Pvc_constraint { locally_abstract_univars=[]; typ }) -> + begin match typ.ptyp_desc with + | Ptyp_poly _ -> expr + | _ -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.constraint_ ~loc expr typ + end + | Some (Pvc_coercion { ground; coercion}) -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.coerce ~loc expr ground coercion + | Some (Pvc_constraint { locally_abstract_univars=vars;typ}) -> + let loc_start = pat.ppat_loc.Location.loc_start in + let loc = { expr.pexp_loc with loc_start; loc_ghost=true } in + let expr = Exp.constraint_ ~loc expr typ in + List.fold_right (Exp.newtype ~loc) vars expr + +let vb_pat_constraint ({pvb_pat=pat; pvb_expr = exp; _ } as vb) = + vb.pvb_attributes, + let open Ast_helper in + match vb.pvb_constraint, pat.ppat_desc, exp.pexp_desc with + | Some (Pvc_constraint {locally_abstract_univars=[]; typ} + | Pvc_coercion { coercion=typ; _ }), + _, _ -> + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat typ + | Some (Pvc_constraint {locally_abstract_univars=vars; typ }), _, _ -> + let varified = Typ.varify_constructors vars typ in + let t = Typ.poly ~loc:typ.ptyp_loc vars varified in + let loc_end = typ.ptyp_loc.Location.loc_end in + let loc = { pat.ppat_loc with loc_end; loc_ghost=true } in + Pat.constraint_ ~loc pat t + | None, (Ppat_any | Ppat_constraint _), _ -> pat + | None, _, Pexp_coerce (_, _, sty) + | None, _, Pexp_constraint (_, sty) when !Clflags.principal -> + (* propagate type annotation to pattern, + to allow it to be generalized in -principal mode *) + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat sty + | _ -> pat + +(** The body of a constraint or coercion. The "body" may be either an expression + or a list of function cases. This type is polymorphic in the data returned + out of typing so that typing an expression body can return an expression + and typing a function cases body can return the cases. +*) +type 'ret constraint_arg = + { type_without_constraint: Env.t -> 'ret * type_expr; + (** [type_without_constraint] types a body (e :> t) where there is no + constraint. + *) + type_with_constraint: Env.t -> type_expr -> 'ret; + (** [type_with_constraint] types a body (e : t) or (e : t :> t') in + the presence of a constraint. + *) + is_self: 'ret -> bool; + (** Whether the thing being constrained is a [Val_self] ident. *) + } + +let rec type_exp ?recarg env sexp = + (* We now delegate everything to type_expect *) + type_expect ?recarg env sexp (mk_expected (newvar ())) + +(* Typing of an expression with an expected type. + This provide better error messages, and allows controlled + propagation of return type information. + In the principal case, structural nodes of [type_expected_explained] may be + at [generic_level] (but its variables no higher than [!current_level]). + *) + +and type_expect ?recarg env sexp ty_expected_explained = + let previous_saved_types = Cmt_format.get_saved_types () in + let exp = + Builtin_attributes.warning_scope sexp.pexp_attributes + (fun () -> + type_expect_ ?recarg env sexp ty_expected_explained + ) + in + Cmt_format.set_saved_types + (Cmt_format.Partial_expression exp :: previous_saved_types); + exp + +and type_expect_ + ?(recarg=Rejected) + env sexp ty_expected_explained = + let { ty = ty_expected; explanation } = ty_expected_explained in + let loc = sexp.pexp_loc in + (* Record the expression type before unifying it with the expected type *) + let with_explanation = with_explanation explanation in + (* Unify the result with [ty_expected], enforcing the current level *) + let rue exp = + with_explanation (fun () -> + unify_exp ~sexp env (re exp) (instance ty_expected)); + exp + in + match sexp.pexp_desc with + | Pexp_ident lid -> + let path, desc = type_ident env ~recarg lid in + let exp_desc = + match desc.val_kind with + | Val_ivar (_, cl_num) -> + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Texp_instvar(self_path, path, + match lid.txt with + Longident.Lident txt -> { txt; loc = lid.loc } + | _ -> assert false) + | Val_self (_, _, _, cl_num) -> + let (path, _) = + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env + in + Texp_ident(path, lid, desc) + | _ -> + Texp_ident(path, lid, desc) + in + rue { + exp_desc; exp_loc = loc; exp_extra = []; + exp_type = instance desc.val_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_constant({pconst_desc = Pconst_string (str, _, _); _} as cst) -> ( + let cst = constant_or_raise env loc cst in + (* Terrible hack for format strings *) + let ty_exp = expand_head env (protect_expansion env ty_expected) in + let fmt6_path = + Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), + "format6")) + in + let is_format = match get_desc ty_exp with + | Tconstr(path, _, _) when Path.same path fmt6_path -> + if !Clflags.principal && get_level ty_exp <> generic_level then + Location.prerr_warning loc + (not_principal "this coercion to format6"); + true + | _ -> false + in + if is_format then + let format_parsetree = + { (type_format loc str env) with pexp_loc = sexp.pexp_loc } in + type_expect env format_parsetree ty_expected_explained + else + rue { + exp_desc = Texp_constant cst; + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_string; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + ) + | Pexp_constant cst -> + let cst = constant_or_raise env loc cst in + rue { + exp_desc = Texp_constant cst; + exp_loc = loc; exp_extra = []; + exp_type = type_constant cst; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_let(Nonrecursive, + [{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody) + when may_contain_gadts spat -> + (* TODO: allow non-empty attributes? *) + let sval = vb_exp_constraint vb in + type_expect env + {sexp with + pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} + ty_expected_explained + | Pexp_let(rec_flag, spat_sexp_list, sbody) -> + let existential_context = + if rec_flag = Recursive then In_rec + else if List.compare_length_with spat_sexp_list 1 > 0 then In_group + else With_attributes in + let may_contain_modules = + List.exists (fun pvb -> may_contain_modules pvb.pvb_pat) spat_sexp_list + in + let outer_level = get_current_level () in + let (pat_exp_list, body, _new_env) = + (* If the patterns contain module unpacks, there is a possibility that + the types of the let body or bound expressions mention types + introduced by those unpacks. The below code checks for scope escape + via both of these pathways (body, bound expressions). + *) + with_local_level_generalize_if may_contain_modules begin fun () -> + let allow_modules = + if may_contain_modules + then + let scope = create_scope () in + Modules_allowed { scope } + else Modules_rejected + in + let (pat_exp_list, new_env) = + type_let existential_context env rec_flag spat_sexp_list + allow_modules + in + let body = type_expect new_env sbody ty_expected_explained in + let pat_exp_list = match rec_flag with + | Recursive -> annotate_recursive_bindings env pat_exp_list + | Nonrecursive -> pat_exp_list + in + (* The "bound expressions" component of the scope escape check. + + This kind of scope escape is relevant only for recursive + module definitions. + *) + if rec_flag = Recursive && may_contain_modules then begin + List.iter + (fun vb -> + (* [type_let] already generalized bound expressions' types + in-place. We first take an instance before checking scope + escape at the outer level to avoid losing generality of + types added to [new_env]. + *) + let bound_exp = vb.vb_expr in + let bound_exp_type = Ctype.instance bound_exp.exp_type in + let loc = proper_exp_loc bound_exp in + let outer_var = newvar2 outer_level in + (* Checking unification within an environment extended with the + module bindings allows us to correctly accept more programs. + This environment allows unification to identify more cases + where a type introduced by the module is equal to a type + introduced at an outer scope. *) + unify_exp_types loc new_env bound_exp_type outer_var) + pat_exp_list + end; + (pat_exp_list, body, new_env) + end + ~before_generalize:(fun (_pat_exp_list, body, new_env) -> + (* The "body" component of the scope escape check. *) + unify_exp ~sexp new_env body (newvar ())) + in + re { + exp_desc = Texp_let(rec_flag, pat_exp_list, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_function (params, body_constraint, body) -> + let in_function = ty_expected_explained, loc in + let exp_type, params, body, newtypes, contains_gadt = + type_function env params body_constraint body ty_expected ~in_function + ~first:true + in + (* Require that the n-ary function is known to have at least n arrows + in the type. This prevents GADT equations introduced by the parameters + from hiding arrows from the resulting type. + + Performance hack: Only do this check when any of [params] contains a + GADT, as this is the only opportunity for arrows to be hidden from the + resulting type. + *) + begin match contains_gadt with + | No_gadt -> () + | Contains_gadt -> + let ty_function = + List.fold_right + (fun param rest_ty -> + newty + (Tarrow (param.fp_arg_label, newvar (), rest_ty, commu_ok))) + params + (match body with + | Tfunction_body _ -> newvar () + | Tfunction_cases _ -> + newty (Tarrow (Nolabel, newvar (), newvar (), commu_ok))) + in + try unify env ty_function exp_type + with Unify trace -> + let syntactic_arity = + List.length params + + (match body with + | Tfunction_body _ -> 0 + | Tfunction_cases _ -> 1) + in + let err = + Function_arity_type_clash + { syntactic_arity; + type_constraint = exp_type; + trace; + } + in + raise (Error (loc, env, err)) + end; + re + { exp_desc = Texp_function (params, body); + exp_loc = loc; + exp_extra = + List.map (fun { txt; loc } -> Texp_newtype txt, loc, []) newtypes; + exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_apply(sfunct, sargs) -> + assert (sargs <> []); + let outer_level = get_current_level () in + let rec lower_args seen ty_fun = + let ty = expand_head env ty_fun in + if TypeSet.mem ty seen then () else + match get_desc ty with + Tarrow (_l, ty_arg, ty_fun, _com) -> + (try Ctype.unify_var env (newvar2 outer_level) ty_arg + with Unify _ -> assert false); + lower_args (TypeSet.add ty seen) ty_fun + | _ -> () + in + (* one more level for warning on non-returning functions *) + with_local_level_generalize begin fun () -> + let type_sfunct sfunct = + let funct = + with_local_level_generalize_structure_if_principal + (fun () -> type_exp env sfunct) + in + let ty = instance funct.exp_type in + wrap_trace_gadt_instances env (lower_args TypeSet.empty) ty; + funct + in + let funct, sargs = + let funct = type_sfunct sfunct in + match funct.exp_desc, sargs with + | Texp_ident (_, _, + {val_kind = Val_prim {prim_name="%revapply"}; val_type}), + [Nolabel, sarg; Nolabel, actual_sfunct] + when is_inferred actual_sfunct + && check_apply_prim_type Revapply val_type -> + type_sfunct actual_sfunct, [Nolabel, sarg] + | Texp_ident (_, _, + {val_kind = Val_prim {prim_name="%apply"}; val_type}), + [Nolabel, actual_sfunct; Nolabel, sarg] + when check_apply_prim_type Apply val_type -> + type_sfunct actual_sfunct, [Nolabel, sarg] + | _ -> + funct, sargs + in + let (args, ty_res) = type_application env funct sargs in + rue { + exp_desc = Texp_apply(funct, args); + exp_loc = loc; exp_extra = []; + exp_type = ty_res; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end + | Pexp_match(sarg, caselist) -> + let arg = + with_local_level_generalize (fun () -> type_exp env sarg) + ~before_generalize:(may_lower_contravariant env) + in + let rec split_cases valc effc conts = function + | [] -> List.rev valc, List.rev effc, List.rev conts + | {pc_lhs = {ppat_desc=Ppat_effect(p1, p2)}} as c :: rest -> + split_cases valc + (({c with pc_lhs = p1}) :: effc) (p2 :: conts) rest + | c :: rest -> + split_cases (c :: valc) effc conts rest + in + let val_caselist, eff_caselist, eff_conts = + split_cases [] [] [] caselist + in + if val_caselist = [] && eff_caselist <> [] then + raise (Error (loc, env, No_value_clauses)); + let val_cases, partial = + type_cases Computation env arg.exp_type ty_expected_explained + ~check_if_total:true loc val_caselist + in + let eff_cases = + match eff_caselist with + | [] -> [] + | eff_caselist -> + type_effect_cases Value env ty_expected_explained loc eff_caselist + eff_conts + in + if + List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs) + val_cases + then check_partial_application ~statement:false arg; + re { + exp_desc = Texp_match(arg, val_cases, eff_cases, partial); + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_try(sbody, caselist) -> + let body = type_expect env sbody ty_expected_explained in + let rec split_cases exnc effc conts = function + | [] -> List.rev exnc, List.rev effc, List.rev conts + | {pc_lhs = {ppat_desc=Ppat_effect(p1, p2)}} as c :: rest -> + split_cases exnc + (({c with pc_lhs = p1}) :: effc) (p2 :: conts) rest + | c :: rest -> + split_cases (c :: exnc) effc conts rest + in + let exn_caselist, eff_caselist, eff_conts = + split_cases [] [] [] caselist + in + let exn_cases, _ = + type_cases Value env Predef.type_exn ty_expected_explained + ~check_if_total:false loc exn_caselist + in + let eff_cases = + match eff_caselist with + | [] -> [] + | eff_caselist -> + type_effect_cases Value env ty_expected_explained loc eff_caselist + eff_conts + in + re { + exp_desc = Texp_try(body, exn_cases, eff_cases); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_tuple sexpl -> + assert (List.length sexpl >= 2); + let subtypes = List.map (fun _ -> newgenvar ()) sexpl in + let to_unify = newgenty (Ttuple subtypes) in + with_explanation (fun () -> + unify_exp_types loc env to_unify (generic_instance ty_expected)); + let expl = + List.map2 (fun body ty -> type_expect env body (mk_expected ty)) + sexpl subtypes + in + re { + exp_desc = Texp_tuple expl; + exp_loc = loc; exp_extra = []; + (* Keep sharing *) + exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_construct(lid, sarg) -> + type_construct env ~sexp lid sarg ty_expected_explained + | Pexp_variant(l, sarg) -> + (* Keep sharing *) + let ty_expected1 = protect_expansion env ty_expected in + let ty_expected0 = instance ty_expected in + begin try match + sarg, get_desc (expand_head env ty_expected1), + get_desc (expand_head env ty_expected0) + with + | Some sarg, Tvariant row, Tvariant row0 -> + begin match + row_field_repr (get_row_field l row), + row_field_repr (get_row_field l row0) + with + Rpresent (Some ty), Rpresent (Some ty0) -> + let arg = type_argument env sarg ty ty0 in + re { exp_desc = Texp_variant(l, Some arg); + exp_loc = loc; exp_extra = []; + exp_type = ty_expected0; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> raise Exit + end + | _ -> raise Exit + with Exit -> + let arg = Option.map (type_exp env) sarg in + let arg_type = Option.map (fun arg -> arg.exp_type) arg in + let row = + create_row + ~fields: [l, rf_present arg_type] + ~more: (newvar ()) + ~closed: false + ~fixed: None + ~name: None + in + rue { + exp_desc = Texp_variant(l, arg); + exp_loc = loc; exp_extra = []; + exp_type = newty (Tvariant row); + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end + | Pexp_record(lid_sexp_list, opt_sexp) -> + assert (lid_sexp_list <> []); + let opt_exp = + match opt_sexp with + None -> None + | Some sexp -> + let exp = + with_local_level_generalize_structure_if_principal + (fun () -> type_exp ~recarg env sexp) + in + Some exp + in + let ty_record, expected_type = + let expected_opath = + match extract_concrete_record env ty_expected with + | Record_type (p0, p, _) -> Some (p0, p, is_principal ty_expected) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = + Wrong_expected_kind(Record, Expression explanation, ty_expected) + in + raise (Error (loc, env, error)) + in + let opt_exp_opath = + match opt_exp with + | None -> None + | Some exp -> + match extract_concrete_record env exp.exp_type with + | Record_type (p0, p, _) -> Some (p0, p, is_principal exp.exp_type) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type exp.exp_type in + raise (Error (exp.exp_loc, env, error)) + in + match expected_opath, opt_exp_opath with + | None, None -> newvar (), None + | Some _, None -> ty_expected, expected_opath + | Some(_, _, true), Some _ -> ty_expected, expected_opath + | (None | Some (_, _, false)), Some (_, p', _) -> + let decl = Env.find_type p' env in + let ty = + with_local_level_generalize_structure + (fun () -> newconstr p' (instance_list decl.type_params)) + in + ty, opt_exp_opath + in + let closed = (opt_sexp = None) in + let lbl_exp_list = + wrap_disambiguate "This record expression is expected to have" + (mk_expected ty_record) + (type_label_a_list loc closed env Env.Construct + (type_label_exp true env loc ty_record) + expected_type) + lid_sexp_list + in + with_explanation (fun () -> + unify_exp_types loc env (instance ty_record) (instance ty_expected)); + + (* type_label_a_list returns a list of labels sorted by lbl_pos *) + (* note: check_duplicates would better be implemented in + type_label_a_list directly *) + let rec check_duplicates = function + | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos -> + raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name)) + | _ :: rem -> + check_duplicates rem + | [] -> () + in + check_duplicates lbl_exp_list; + let opt_exp, label_definitions = + let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in + let matching_label lbl = + List.find + (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos) + lbl_exp_list + in + match opt_exp with + None -> + let label_definitions = + Array.map (fun lbl -> + match matching_label lbl with + | (lid, _lbl, lbl_exp) -> + Overridden (lid, lbl_exp) + | exception Not_found -> + let present_indices = + List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list + in + let label_names = extract_label_names env ty_expected in + let rec missing_labels n = function + [] -> [] + | lbl :: rem -> + if List.mem n present_indices + then missing_labels (n + 1) rem + else lbl :: missing_labels (n + 1) rem + in + let missing = missing_labels 0 label_names in + raise(Error(loc, env, Label_missing missing))) + lbl.lbl_all + in + None, label_definitions + | Some exp -> + let ty_exp = instance exp.exp_type in + let unify_kept lbl = + let _, ty_arg1, ty_res1 = instance_label ~fixed:false lbl in + unify_exp_types exp.exp_loc env ty_exp ty_res1; + match matching_label lbl with + | lid, _lbl, lbl_exp -> + (* do not connect result types for overridden labels *) + Overridden (lid, lbl_exp) + | exception Not_found -> begin + let _, ty_arg2, ty_res2 = instance_label ~fixed:false lbl in + unify_exp_types loc env ty_arg1 ty_arg2; + with_explanation (fun () -> + unify_exp_types loc env (instance ty_expected) ty_res2); + Kept (ty_arg1, lbl.lbl_mut) + end + in + let label_definitions = Array.map unify_kept lbl.lbl_all in + Some {exp with exp_type = ty_exp}, label_definitions + in + let num_fields = + match lbl_exp_list with [] -> assert false + | (_, lbl,_)::_ -> Array.length lbl.lbl_all in + if opt_sexp <> None && List.length lid_sexp_list = num_fields then + Location.prerr_warning loc Warnings.Useless_record_with; + let label_descriptions, representation = + let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in + lbl_all, lbl_repres + in + let fields = + Array.map2 (fun descr def -> descr, def) + label_descriptions label_definitions + in + re { + exp_desc = Texp_record { + fields; representation; + extended_expression = opt_exp + }; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_field(srecord, lid) -> + let (record, label, _) = + type_label_access env srecord Env.Projection lid + in + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in + unify_exp ~sexp env record ty_res; + rue { + exp_desc = Texp_field(record, lid, label); + exp_loc = loc; exp_extra = []; + exp_type = ty_arg; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_setfield(srecord, lid, snewval) -> + let (record, label, expected_type) = + type_label_access env srecord Env.Mutation lid in + let ty_record = + if expected_type = None then newvar () else record.exp_type in + let (label_loc, label, newval) = + type_label_exp false env loc ty_record (lid, label, snewval) in + unify_exp ~sexp env record ty_record; + if label.lbl_mut = Immutable then + raise(Error(loc, env, Label_not_mutable lid.txt)); + rue { + exp_desc = Texp_setfield(record, label_loc, label, newval); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_array(sargl) -> + let ty = newgenvar() in + let to_unify = Predef.type_array ty in + with_explanation (fun () -> + unify_exp_types loc env to_unify (generic_instance ty_expected)); + let argl = + List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in + re { + exp_desc = Texp_array argl; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_ifthenelse(scond, sifso, sifnot) -> + let cond = type_expect env scond + (mk_expected ~explanation:If_conditional Predef.type_bool) in + begin match sifnot with + None -> + let ifso = type_expect env sifso + (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in + rue { + exp_desc = Texp_ifthenelse(cond, ifso, None); + exp_loc = loc; exp_extra = []; + exp_type = ifso.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Some sifnot -> + let ifso = type_expect env sifso ty_expected_explained in + let ifnot = type_expect env sifnot ty_expected_explained in + (* Keep sharing *) + unify_exp ~sexp env ifnot ifso.exp_type; + re { + exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); + exp_loc = loc; exp_extra = []; + exp_type = ifso.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end + | Pexp_sequence(sexp1, sexp2) -> + let exp1 = type_statement ~explanation:Sequence_left_hand_side + env sexp1 in + let exp2 = type_expect env sexp2 ty_expected_explained in + re { + exp_desc = Texp_sequence(exp1, exp2); + exp_loc = loc; exp_extra = []; + exp_type = exp2.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_while(scond, sbody) -> + let cond = type_expect env scond + (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in + let exp_type = + match cond.exp_desc with + | Texp_construct(_, {cstr_name="true"}, _) -> instance ty_expected + | _ -> instance Predef.type_unit + in + let body = type_statement ~explanation:While_loop_body env sbody in + rue { + exp_desc = Texp_while(cond, body); + exp_loc = loc; exp_extra = []; + exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_for(param, slow, shigh, dir, sbody) -> + let low = type_expect env slow + (mk_expected ~explanation:For_loop_start_index Predef.type_int) in + let high = type_expect env shigh + (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in + let id, new_env = + match param.ppat_desc with + | Ppat_any -> Ident.create_local "_for", env + | Ppat_var {txt} -> + Env.enter_value txt + {val_type = instance Predef.type_int; + val_attributes = []; + val_kind = Val_reg; + val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } env + ~check:(fun s -> Warnings.Unused_for_index s) + | _ -> + raise (Error (param.ppat_loc, env, Invalid_for_loop_index)) + in + let body = type_statement ~explanation:For_loop_body new_env sbody in + rue { + exp_desc = Texp_for(id, param, low, high, dir, body); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_constraint (sarg, sty) -> + let (ty, exp_extra) = type_constraint env sty in + let arg = type_argument env sarg ty (instance ty) in + rue { + exp_desc = arg.exp_desc; + exp_loc = arg.exp_loc; + exp_type = instance ty; + exp_attributes = arg.exp_attributes; + exp_env = env; + exp_extra = (exp_extra, loc, sexp.pexp_attributes) :: arg.exp_extra; + } + | Pexp_coerce(sarg, sty, sty') -> + let arg, ty', exp_extra = + type_coerce (expression_constraint sarg) env loc sty sty' + ~loc_arg:sarg.pexp_loc + in + rue { + exp_desc = arg.exp_desc; + exp_loc = arg.exp_loc; + exp_type = ty'; + exp_attributes = arg.exp_attributes; + exp_env = env; + exp_extra = (exp_extra, loc, sexp.pexp_attributes) :: arg.exp_extra; + } + | Pexp_send (e, {txt=met}) -> + let (obj,meth,typ) = + with_local_level_generalize_structure_if_principal + (fun () -> type_send env loc explanation e met) + in + let typ = + match get_desc typ with + | Tpoly (ty, []) -> + instance ty + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc + (not_principal "this use of a polymorphic method"); + snd (instance_poly ~fixed:false tl ty) + | Tvar _ -> + let ty' = newvar () in + unify env (instance typ) (newty(Tpoly(ty',[]))); + (* if not !Clflags.nolabels then + Location.prerr_warning loc (Warnings.Unknown_method met); *) + ty' + | _ -> + assert false + in + rue { + exp_desc = Texp_send(obj, meth); + exp_loc = loc; exp_extra = []; + exp_type = typ; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_new cl -> + let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in + begin match cl_decl.cty_new with + None -> + raise(Error(loc, env, Virtual_class cl.txt)) + | Some ty -> + rue { + exp_desc = Texp_new (cl_path, cl, cl_decl); + exp_loc = loc; exp_extra = []; + exp_type = instance ty; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end + | Pexp_setinstvar (lab, snewval) -> begin + let (path, mut, cl_num, ty) = + Env.lookup_instance_variable ~loc lab.txt env + in + match mut with + | Mutable -> + let newval = + type_expect env snewval (mk_expected (instance ty)) + in + let (path_self, _) = + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env + in + rue { + exp_desc = Texp_setinstvar(path_self, path, lab, newval); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + raise(Error(loc, env, Instance_variable_not_mutable lab.txt)) + end + | Pexp_override lst -> + let _ = + List.fold_right + (fun (lab, _) l -> + if List.exists (fun l -> l.txt = lab.txt) l then + raise(Error(loc, env, + Value_multiply_overridden lab.txt)); + lab::l) + lst + [] in + begin match + try + Env.find_value_by_name (Longident.Lident "selfpat-*") env, + Env.find_value_by_name (Longident.Lident "self-*") env + with Not_found -> + raise(Error(loc, env, Outside_class)) + with + (_, {val_type = self_ty; val_kind = Val_self (sign, _, vars, _)}), + (path_self, _) -> + let type_override (lab, snewval) = + begin try + let id = Vars.find lab.txt vars in + let ty = Btype.instance_variable_type lab.txt sign in + (id, lab, type_expect env snewval (mk_expected (instance ty))) + with + Not_found -> + let vars = Vars.fold (fun var _ li -> var::li) vars [] in + raise(Error(loc, env, + Unbound_instance_variable (lab.txt, vars))) + end + in + let modifs = List.map type_override lst in + rue { + exp_desc = Texp_override(path_self, modifs); + exp_loc = loc; exp_extra = []; + exp_type = self_ty; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + assert false + end + | Pexp_letmodule(name, smodl, sbody) -> + let lv = get_current_level () in + let (id, pres, modl, _, body) = + with_local_level_generalize begin fun () -> + let modl, pres, id, new_env = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let modl, md_shape = !type_module env smodl in + Mtype.lower_nongen lv modl.mod_type; + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let scope = create_scope () in + let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let md_shape = Shape.set_uid_if_none md_shape md_uid in + let md = + { md_type = modl.mod_type; md_attributes = []; + md_loc = name.loc; + md_uid; } + in + let (id, new_env) = + match name.txt with + | None -> None, env + | Some name -> + let id, env = + Env.enter_module_declaration + ~scope ~shape:md_shape name pres md env + in + Some id, env + in + modl, pres, id, new_env + end + in + (* Ideally, we should catch Expr_type_clash errors + in type_expect triggered by escaping identifiers + from the local module and refine them into + Scoping_let_module errors + *) + let body = type_expect new_env sbody ty_expected_explained in + (id, pres, modl, new_env, body) + end + ~before_generalize: begin fun (_id, _pres, _modl, new_env, body) -> + (* Ensure that local definitions do not leak. *) + (* required for implicit unpack *) + enforce_current_level new_env body.exp_type + end + in + re { + exp_desc = Texp_letmodule(id, name, pres, modl, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_letexception(cd, sbody) -> + let (cd, newenv, _shape) = Typedecl.transl_exception env cd in + let body = type_expect newenv sbody ty_expected_explained in + re { + exp_desc = Texp_letexception(cd, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + + | Pexp_assert (e) -> + let cond = type_expect env e + (mk_expected ~explanation:Assert_condition Predef.type_bool) in + let exp_type = + match cond.exp_desc with + | Texp_construct(_, {cstr_name="false"}, _) -> + instance ty_expected + | _ -> + instance Predef.type_unit + in + let rec innermost_location loc_stack = + match loc_stack with + | [] -> loc + | [l] -> l + | _ :: s -> innermost_location s + in + rue { + exp_desc = Texp_assert (cond, innermost_location sexp.pexp_loc_stack); + exp_loc = loc; exp_extra = []; + exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_lazy e -> + let ty = newgenvar () in + let to_unify = Predef.type_lazy_t ty in + with_explanation (fun () -> + unify_exp_types loc env to_unify (generic_instance ty_expected)); + let arg = type_expect env e (mk_expected ty) in + re { + exp_desc = Texp_lazy arg; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_object s -> + let desc, meths = !type_object env loc s in + rue { + exp_desc = Texp_object (desc, meths); + exp_loc = loc; exp_extra = []; + exp_type = desc.cstr_type.csig_self; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_poly(sbody, sty) -> + let ty, cty = + with_local_level_generalize_structure_if_principal + begin fun () -> + match sty with None -> protect_expansion env ty_expected, None + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = Typetexp.transl_simple_type env ~closed:false sty in + cty.ctyp_type, Some cty + end + in + if sty <> None then + with_explanation (fun () -> + unify_exp_types loc env (instance ty) (instance ty_expected)); + let exp = + match get_desc (expand_head env ty) with + Tpoly (ty', []) -> + let exp = type_expect env sbody (mk_expected ty') in + { exp with exp_type = instance ty } + | Tpoly (ty', tl) -> + (* One more level to generalize locally *) + let (exp, vars) = + with_local_level_generalize begin fun () -> + let vars, ty'' = + with_local_level_generalize_structure_if_principal + (fun () -> instance_poly ~fixed:true tl ty') + in + let exp = type_expect env sbody (mk_expected ty'') in + (exp, vars) + end + in + check_univars env "method" exp ty_expected vars; + { exp with exp_type = instance ty } + | Tvar _ -> + let exp = type_exp env sbody in + let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in + unify_exp ~sexp env exp ty; + exp + | _ -> assert false + in + re { exp with exp_extra = + (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } + | Pexp_newtype(name, sbody) -> + let body, ety = type_newtype env name (fun env -> + let expr = type_exp env sbody in + expr, expr.exp_type) + in + (* non-expansive if the body is non-expansive, so we don't introduce + any new extra node in the typed AST. *) + rue { body with exp_loc = loc; exp_type = ety; + exp_extra = + (Texp_newtype name.txt, loc, sexp.pexp_attributes) :: body.exp_extra + } + | Pexp_pack m -> + let (p, fl) = + match get_desc (Ctype.expand_head env (instance ty_expected)) with + Tpackage (p, fl) -> + if !Clflags.principal && + get_level (Ctype.expand_head env + (protect_expansion env ty_expected)) + < Btype.generic_level + then + Location.prerr_warning loc + (not_principal "this module packing"); + (p, fl) + | Tvar _ -> + raise (Error (loc, env, Cannot_infer_signature)) + | _ -> + raise (Error (loc, env, Not_a_packed_module ty_expected)) + in + let (modl, fl') = !type_package env m p fl in + rue { + exp_desc = Texp_pack modl; + exp_loc = loc; exp_extra = []; + exp_type = newty (Tpackage (p, fl')); + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_open (od, e) -> + let tv = newvar () in + let (od, _, newenv) = !type_open_decl env od in + let exp = type_expect newenv e ty_expected_explained in + (* Force the return type to be well-formed in the original + environment. *) + unify_var newenv tv exp.exp_type; + re { + exp_desc = Texp_open (od, exp); + exp_type = exp.exp_type; + exp_loc = loc; + exp_extra = []; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_letop{ let_ = slet; ands = sands; body = sbody } -> + let rec loop spat_acc ty_acc sands = + match sands with + | [] -> spat_acc, ty_acc + | { pbop_pat = spat; _} :: rest -> + let ty = newvar () in + let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in + let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in + let ty_acc = newty (Ttuple [ty_acc; ty]) in + loop spat_acc ty_acc rest + in + let op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops = + with_local_level_generalize_structure_if_principal begin fun () -> + let let_loc = slet.pbop_op.loc in + let op_path, op_desc = type_binding_op_ident env slet.pbop_op in + let op_type = instance op_desc.val_type in + let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in + let ty_func_result = newvar () in + let ty_func = + newty (Tarrow(Nolabel, ty_params, ty_func_result, commu_ok)) in + let ty_result = newvar () in + let ty_andops = newvar () in + let ty_op = + newty (Tarrow(Nolabel, ty_andops, + newty (Tarrow(Nolabel, ty_func, ty_result, commu_ok)), commu_ok)) + in + begin try + unify env op_type ty_op + with Unify err -> + raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) + end; + (op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops) + end + in + let exp, ands = type_andops env slet.pbop_exp sands ty_andops in + let scase = Ast_helper.Exp.case spat_params sbody in + let cases, partial = + type_cases Value env + ty_params (mk_expected ty_func_result) + ~check_if_total:true loc [scase] + in + let body = + match cases with + | [case] -> case + | _ -> assert false + in + let param = name_cases "param" cases in + let let_ = + { bop_op_name = slet.pbop_op; + bop_op_path = op_path; + bop_op_val = op_desc; + bop_op_type = op_type; + bop_exp = exp; + bop_loc = slet.pbop_loc; } + in + let desc = + Texp_letop{let_; ands; param; body; partial} + in + rue { exp_desc = desc; + exp_loc = sexp.pexp_loc; + exp_extra = []; + exp_type = instance ty_result; + exp_env = env; + exp_attributes = sexp.pexp_attributes; } + + | Pexp_extension ({ txt = ("ocaml.extension_constructor" + |"extension_constructor"); _ }, + payload) -> + begin match payload with + | PStr [ { pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _) + } ] -> + let path = + let cd = + Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env + in + match cd.cstr_tag with + | Cstr_extension (path, _) -> path + | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) + in + rue { + exp_desc = Texp_extension_constructor (lid, path); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_extension_constructor; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + raise (Error (loc, env, Invalid_extension_constructor_payload)) + end + | Pexp_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + + | Pexp_unreachable -> + re { exp_desc = Texp_unreachable; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + +and expression_constraint pexp = + { type_without_constraint = (fun env -> + let expr = type_exp env pexp in + expr, expr.exp_type); + type_with_constraint = + (fun env ty -> type_argument env pexp ty (instance ty)); + is_self = + (fun expr -> + match expr.exp_desc with + | Texp_ident (_, _, { val_kind = Val_self _ }) -> true + | _ -> false); + } + +(** Types a body in the scope of a coercion (with an optional constraint) + and returns the inferred type. See the comment on {!constraint_arg} for + an explanation of how this typechecking is polymorphic in the body. +*) +and type_coerce + : type a. a constraint_arg -> _ -> _ -> _ -> _ -> loc_arg:_ + -> a * type_expr * exp_extra = + fun constraint_arg env loc sty sty' ~loc_arg -> + (* Pretend separate = true, 1% slowdown for lablgtk *) + (* Also see PR#7199 for a problem with the following: + let separate = !Clflags.principal || Env.has_local_constraints env in*) + let { is_self; type_with_constraint; type_without_constraint } = + constraint_arg + in + match sty with + | None -> + let (cty', ty', force) = + Typetexp.transl_simple_type_delayed env sty' + in + let arg, arg_type, gen = + let lv = get_current_level () in + with_local_level_generalize begin fun () -> + let arg, arg_type = type_without_constraint env in + arg, arg_type, generalizable lv arg_type + end + ~before_generalize: + (fun (_, arg_type, _) -> enforce_current_level env arg_type) + in + begin match !self_coercion, get_desc ty' with + | ((path, r) :: _, Tconstr (path', _, _)) + when is_self arg && Path.same path path' -> + (* prerr_endline "self coercion"; *) + r := loc :: !r; + force () + | _ when free_variables ~env arg_type = [] + && free_variables ~env ty' = [] -> + if not gen && (* first try a single coercion *) + let snap = snapshot () in + let ty, _b = enlarge_type env ty' in + try + force (); Ctype.unify env arg_type ty; true + with Unify _ -> + backtrack snap; false + then () + else begin try + let force' = subtype env arg_type ty' in + force (); force' (); + if not gen && !Clflags.principal then + Location.prerr_warning loc + (not_principal "this ground coercion"); + with Subtype err -> + (* prerr_endline "coercion failed"; *) + raise (Error (loc, env, Not_subtype err)) + end; + | _ -> + let ty, b = enlarge_type env ty' in + force (); + begin try Ctype.unify env arg_type ty with Unify err -> + let expanded = full_expand ~may_forget_scope:true env ty' in + raise(Error(loc_arg, env, + Coercion_failure ({ ty = ty'; expanded }, err, b))) + end + end; + (arg, ty', Texp_coerce (None, cty')) + | Some sty -> + let cty, ty, force, cty', ty', force' = + with_local_level_generalize_structure begin fun () -> + let (cty, ty, force) = + Typetexp.transl_simple_type_delayed env sty + and (cty', ty', force') = + Typetexp.transl_simple_type_delayed env sty' + in + (cty, ty, force, cty', ty', force') + end + in + begin try + let force'' = subtype env (instance ty) (instance ty') in + force (); force' (); force'' () + with Subtype err -> + raise (Error (loc, env, Not_subtype err)) + end; + (type_with_constraint env ty, + instance ty', Texp_coerce (Some cty, cty')) + +and type_constraint env sty = + (* Pretend separate = true, 1% slowdown for lablgtk *) + let cty = + with_local_level_generalize_structure begin fun () -> + Typetexp.transl_simple_type env ~closed:false sty + end + in + cty.ctyp_type, Texp_constraint cty + +(** Types a body in the scope of a coercion (:>) or a constraint (:), and + unifies the inferred type with the expected type. + + @param loc the location of the overall constraint + @param loc_arg the location of the thing being constrained +*) +and type_constraint_expect + : type a. a constraint_arg -> _ -> _ -> loc_arg:_ -> _ -> _ -> a * _ * _ = + fun constraint_arg env loc ~loc_arg constraint_ ty_expected -> + let ret, ty, exp_extra = + match constraint_ with + | Pcoerce (ty_constrain, ty_coerce) -> + type_coerce constraint_arg env loc ty_constrain ty_coerce ~loc_arg + | Pconstraint ty_constrain -> + let ty, exp_extra = type_constraint env ty_constrain in + constraint_arg.type_with_constraint env ty, ty, exp_extra + in + unify_exp_types loc env ty (instance ty_expected); + ret, ty, exp_extra + +(** Typecheck the body of a newtype. The "body" of a newtype may be: + - an expression + - a suffix of function parameters together with a function body + That's why this function is polymorphic over the body. + + @param type_body A function that produces a type for the body given the + environment. When typechecking an expression, this is [type_exp]. + @return The type returned by [type_body] but with the Tconstr + nodes for the newtype properly linked. +*) +and type_newtype + : type a. _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr = + fun env { txt = name; loc = name_loc } type_body -> + let ty = + if Typetexp.valid_tyvar_name name then + newvar ~name () + else + newvar () + in + (* Use [with_local_level_generalize] just for scoping *) + with_local_level_generalize begin fun () -> + (* Create a fake abstract type declaration for [name]. *) + let decl = new_local_type ~loc:name_loc Definition in + let scope = create_scope () in + let (id, new_env) = Env.enter_type ~scope name decl env in + + let result, exp_type = type_body new_env in + (* Replace every instance of this type constructor in the resulting + type. *) + let seen = Hashtbl.create 8 in + let rec replace t = + if Hashtbl.mem seen (get_id t) then () + else begin + Hashtbl.add seen (get_id t) (); + match get_desc t with + | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty + | _ -> Btype.iter_type_expr replace t + end + in + let ety = Subst.type_expr Subst.identity exp_type in + replace ety; + (result, ety) + end + ~before_generalize:(fun (_,ety) -> enforce_current_level env ety) + +and type_ident env ?(recarg=Rejected) lid = + let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in + let is_recarg = + match get_desc desc.val_type with + | Tconstr(p, _, _) -> Path.is_constructor_typath p + | _ -> false + in + begin match is_recarg, recarg, get_desc desc.val_type with + | _, Allowed, _ + | true, Required, _ + | false, Rejected, _ -> () + | true, Rejected, _ + | false, Required, (Tvar _ | Tconstr _) -> + raise (Error (lid.loc, env, Inlined_record_escape)) + | false, Required, _ -> () (* will fail later *) + end; + path, desc + +and type_binding_op_ident env s = + let loc = s.loc in + let lid = Location.mkloc (Longident.Lident s.txt) loc in + let path, desc = type_ident env lid in + let path = + match desc.val_kind with + | Val_ivar _ -> + fatal_error "Illegal name for instance variable" + | Val_self (_, _, _, cl_num) -> + let path, _ = + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env + in + path + | _ -> path + in + path, desc + +(** Returns the argument type and then the return type. + + @param first Whether the parameter corresponding to the argument of + [ty_expected] is the first parameter to the (n-ary) function. This only + affects error messages. + @param in_function Information about the [Pexp_function] node that's in the + process of being typechecked (its overall type and its location). Again, + this is only used to improve error messages. +*) +and split_function_ty env ty_expected ~arg_label ~first ~in_function = + let { ty = ty_fun; explanation }, loc = in_function in + let separate = !Clflags.principal || Env.has_local_constraints env in + with_local_level_generalize_structure_if separate begin fun () -> + let ty_arg, ty_res = + try filter_arrow env (instance ty_expected) arg_label + with Filter_arrow_failed err -> + let err = match err with + | Unification_error unif_err -> + Expr_type_clash (unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type } -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> + if first + then Not_a_function (ty_fun, explanation) + else Too_many_arguments (ty_fun, explanation) + in + raise (Error(loc, env, err)) + in + let ty_arg = + if is_optional arg_label then + let tv = newvar () in + begin + try unify env ty_arg (type_option tv) + with Unify _ -> assert false + end; + type_option tv + else ty_arg + in + (ty_arg, ty_res) + end + +(* Typecheck parameters one at a time followed by the body. Later parameters + are checked in the scope of earlier ones. That's necessary to support + constructs like [fun (type a) (x : a) -> ...] and + [fun (module M : S) (x : M.t) -> ...]. + + Operates like [type_expect] in that it unifies the "type of the remaining + function params + body" with [ty_expected], and returns out the inferred + type. + + See [split_function_ty] for the meaning of [first] and [in_function]. + + Returns (inferred_ty, params, body, newtypes, contains_gadt), where: + - [newtypes] are the newtypes immediately bound by the prefix of function + parameters. These should be added to an [exp_extra] node. + - [contains_gadt] is whether any of [params] contains a GADT. Note + this does not indicate whether [body] contains a GADT (if it's + [Tfunction_cases]). +*) +and type_function + env params_suffix body_constraint body ty_expected ~first ~in_function + = + let ty_fun, (loc_function : Location.t) = in_function in + (* The "rest of the function" extends from the start of the first parameter + to the end of the overall function. The parser does not construct such + a location so we forge one for type errors. + *) + let loc : Location.t = + match params_suffix, body with + | param :: _, _ -> + { loc_start = param.pparam_loc.loc_start; + loc_end = loc_function.loc_end; + loc_ghost = true; + } + | [], Pfunction_body pexp -> pexp.pexp_loc + | [], Pfunction_cases (_, loc_cases, _) -> loc_cases + in + match params_suffix with + | { pparam_desc = Pparam_newtype newtype; pparam_loc = _ } :: rest -> + (* Check everything else in the scope of (type a). *) + let (params, body, newtypes, contains_gadt), exp_type = + type_newtype env newtype (fun env -> + let exp_type, params, body, newtypes, contains_gadt = + (* mimic the typing of Pexp_newtype by minting a new type var, + like [type_exp]. + *) + type_function env rest body_constraint body (newvar ()) + ~first:false ~in_function + in + (params, body, newtypes, contains_gadt), exp_type) + in + with_explanation ty_fun.explanation (fun () -> + unify_exp_types loc env exp_type (instance ty_expected)); + exp_type, params, body, newtype :: newtypes, contains_gadt + | { pparam_desc = Pparam_val (arg_label, default_arg, pat); pparam_loc } + :: rest + -> + let ty_arg, ty_res = + split_function_ty env ty_expected ~arg_label ~first ~in_function + in + (* [ty_arg_internal] is the type of the parameter viewed internally + to the function. This is different than [ty_arg] exactly for + optional arguments with defaults, where the external [ty_arg] + is optional and the internal view is not optional. + *) + let ty_arg_internal, default_arg = + match default_arg with + | None -> ty_arg, None + | Some default -> + assert (is_optional arg_label); + let ty_default = newvar () in + begin + try unify env (type_option ty_default) ty_arg + with Unify _ -> assert false; + end; + (* Issue#12668: Retain type-directed disambiguation of + ?x:(y : Variant.t = Constr) + *) + let default = + match pat.ppat_desc with + | Ppat_constraint (_, sty) -> + let gloc = { default.pexp_loc with loc_ghost = true } in + Ast_helper.Exp.constraint_ default sty ~loc:gloc + | _ -> default + in + let default = type_expect env default (mk_expected ty_default) in + ty_default, Some default + in + let (pat, params, body, newtypes, contains_gadt), partial = + (* Check everything else in the scope of the parameter. *) + map_half_typed_cases Value env ty_arg_internal ty_res pat.ppat_loc + ~check_if_total:true + (* We don't make use of [case_data] here so we pass unit. *) + [ { pattern = pat; has_guard = false; needs_refute = false }, () ] + ~type_body:begin + fun () pat ~when_env:_ ~ext_env ~cont:_ ~ty_expected ~ty_infer:_ + ~contains_gadt:param_contains_gadt -> + let _, params, body, newtypes, suffix_contains_gadt = + type_function ext_env rest body_constraint body + ty_expected ~first:false ~in_function + in + let contains_gadt = + if param_contains_gadt then + Contains_gadt + else + suffix_contains_gadt + in + (pat, params, body, newtypes, contains_gadt) + end + |> function + (* The result must be a singleton because we passed a singleton + list above. *) + | [ result ], partial -> result, partial + | ([] | _ :: _ :: _), _ -> assert false + in + let exp_type = + instance (newgenty (Tarrow (arg_label, ty_arg, ty_res, commu_ok))) + in + (* This is quadratic, as it operates over the entire tail of the + type for each new parameter. Now that functions are n-ary, we + could possibly run this once. + *) + with_explanation ty_fun.explanation (fun () -> + unify_exp_types loc env exp_type (instance ty_expected)); + (* This is quadratic, as it extracts all of the parameters from an arrow + type for each parameter that's added. Now that functions are n-ary, + there might be an opportunity to improve this. + *) + let not_nolabel_function ty = + let ls, tvar = list_labels env ty in + List.for_all (( <> ) Nolabel) ls && not tvar + in + if is_optional arg_label && not_nolabel_function ty_res + then + Location.prerr_warning + pat.pat_loc + Warnings.Unerasable_optional_argument; + let fp_kind, fp_param = + match default_arg with + | None -> + let param = name_pattern "param" [ pat ] in + Tparam_pat pat, param + | Some default_arg -> + let param = Ident.create_local "*opt*" in + Tparam_optional_default (pat, default_arg), param + in + let param = + { fp_kind; + fp_arg_label = arg_label; + fp_param; + fp_partial = partial; + fp_newtypes = newtypes; + fp_loc = pparam_loc; + } + in + exp_type, param :: params, body, [], contains_gadt + | [] -> + let exp_type, body = + match body with + | Pfunction_body body -> + let body = + match body_constraint with + | None -> type_expect env body (mk_expected ty_expected) + | Some constraint_ -> + let body_loc = body.pexp_loc in + let body, exp_type, exp_extra = + type_constraint_expect (expression_constraint body) + env body_loc ~loc_arg:body_loc constraint_ ty_expected + in + { body with + exp_extra = (exp_extra, body_loc, []) :: body.exp_extra; + exp_type; + } + in + body.exp_type, Tfunction_body body + | Pfunction_cases (cases, _, attributes) -> + let type_cases_expect env ty_expected = + type_function_cases_expect + env ty_expected loc cases attributes ~first ~in_function + in + let (cases, partial, exp_type), exp_extra = + match body_constraint with + | None -> type_cases_expect env ty_expected, None + | Some constraint_ -> + (* The typing of function case coercions/constraints is + analogous to the typing of expression coercions/constraints. + + - [type_with_constraint]: If there is a constraint, then call + [type_argument] on the cases, and discard the cases' + inferred type in favor of the constrained type. (Function + cases aren't inferred, so [type_argument] would just call + [type_expect] straight away, so we do the same here.) + - [type_without_constraint]: If there is just a coercion and + no constraint, call [type_exp] on the cases and surface the + cases' inferred type to [type_constraint_expect]. *) + let function_cases_constraint_arg = + { is_self = (fun _ -> false); + type_with_constraint = (fun env ty -> + let cases, partial, _ = type_cases_expect env ty in + cases, partial); + type_without_constraint = (fun env -> + let cases, partial, ty_fun = + (* The analogy to [type_exp] for expressions. *) + type_cases_expect env (newvar ()) + in + (cases, partial), ty_fun); + } + in + let (cases, partial), exp_type, exp_extra = + type_constraint_expect function_cases_constraint_arg + env loc constraint_ ty_expected ~loc_arg:loc + in + (cases, partial, exp_type), Some exp_extra + in + let param = name_cases "param" cases in + let body = + Tfunction_cases + { cases; partial; param; loc; exp_extra; attributes } + in + exp_type, body + in + (* [No_gadt] is fine because this return value is only meant to indicate + whether [params] (here, the empty list) contains any GADT, not whether + the body is a [Tfunction_cases] whose patterns include a GADT. + *) + exp_type, [], body, [], No_gadt + + +and type_label_access env srecord usage lid = + let record = + with_local_level_generalize_structure_if_principal + (fun () -> type_exp ~recarg:Allowed env srecord) + in + let ty_exp = record.exp_type in + let expected_type = + match extract_concrete_record env ty_exp with + | Record_type(p0, p, _) -> + Some(p0, p, is_principal ty_exp) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type ty_exp in + raise (Error (record.exp_loc, env, error)) + in + let labels = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in + let label = + wrap_disambiguate "This expression has" (mk_expected ty_exp) + (Label.disambiguate usage lid env expected_type) labels in + (record, label, expected_type) + +(* Typing format strings for printing or reading. + These formats are used by functions in modules Printf, Format, and Scanf. + (Handling of * modifiers contributed by Thorsten Ohl.) *) + +and type_format loc str env = + let loc = {loc with Location.loc_ghost = true} in + try + CamlinternalFormatBasics.(CamlinternalFormat.( + let mk_exp_loc pexp_desc = { + pexp_desc = pexp_desc; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; + } and mk_lid_loc lid = { + txt = lid; + loc = loc; + } in + let mk_constr name args = + let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in + let arg = match args with + | [] -> None + | [ e ] -> Some e + | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in + mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in + let mk_cst cst = + mk_exp_loc (Pexp_constant {pconst_desc = cst; pconst_loc = loc}) + in + let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None)) + and mk_string str = mk_cst (Pconst_string (str, loc, None)) + and mk_char chr = mk_cst (Pconst_char chr) in + let rec mk_formatting_lit fmting = match fmting with + | Close_box -> + mk_constr "Close_box" [] + | Close_tag -> + mk_constr "Close_tag" [] + | Break (org, ns, ni) -> + mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ] + | FFlush -> + mk_constr "FFlush" [] + | Force_newline -> + mk_constr "Force_newline" [] + | Flush_newline -> + mk_constr "Flush_newline" [] + | Magic_size (org, sz) -> + mk_constr "Magic_size" [ mk_string org; mk_int sz ] + | Escaped_at -> + mk_constr "Escaped_at" [] + | Escaped_percent -> + mk_constr "Escaped_percent" [] + | Scan_indic c -> + mk_constr "Scan_indic" [ mk_char c ] + and mk_formatting_gen : type a b c d e f . + (a, b, c, d, e, f) formatting_gen -> Parsetree.expression = + fun fmting -> match fmting with + | Open_tag (Format (fmt', str')) -> + mk_constr "Open_tag" [ mk_format fmt' str' ] + | Open_box (Format (fmt', str')) -> + mk_constr "Open_box" [ mk_format fmt' str' ] + and mk_format : type a b c d e f . + (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string -> + Parsetree.expression = fun fmt str -> + mk_constr "Format" [ mk_fmt fmt; mk_string str ] + and mk_side side = match side with + | Left -> mk_constr "Left" [] + | Right -> mk_constr "Right" [] + | Zeros -> mk_constr "Zeros" [] + and mk_iconv iconv = match iconv with + | Int_d -> mk_constr "Int_d" [] | Int_pd -> mk_constr "Int_pd" [] + | Int_sd -> mk_constr "Int_sd" [] | Int_i -> mk_constr "Int_i" [] + | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" [] + | Int_x -> mk_constr "Int_x" [] | Int_Cx -> mk_constr "Int_Cx" [] + | Int_X -> mk_constr "Int_X" [] | Int_CX -> mk_constr "Int_CX" [] + | Int_o -> mk_constr "Int_o" [] | Int_Co -> mk_constr "Int_Co" [] + | Int_u -> mk_constr "Int_u" [] | Int_Cd -> mk_constr "Int_Cd" [] + | Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" [] + and mk_fconv fconv = + let flag = match fst fconv with + | Float_flag_ -> mk_constr "Float_flag_" [] + | Float_flag_p -> mk_constr "Float_flag_p" [] + | Float_flag_s -> mk_constr "Float_flag_s" [] in + let kind = match snd fconv with + | Float_f -> mk_constr "Float_f" [] + | Float_e -> mk_constr "Float_e" [] + | Float_E -> mk_constr "Float_E" [] + | Float_g -> mk_constr "Float_g" [] + | Float_G -> mk_constr "Float_G" [] + | Float_h -> mk_constr "Float_h" [] + | Float_H -> mk_constr "Float_H" [] + | Float_F -> mk_constr "Float_F" [] + | Float_CF -> mk_constr "Float_CF" [] in + mk_exp_loc (Pexp_tuple [flag; kind]) + and mk_counter cnt = match cnt with + | Line_counter -> mk_constr "Line_counter" [] + | Char_counter -> mk_constr "Char_counter" [] + | Token_counter -> mk_constr "Token_counter" [] + and mk_int_opt n_opt = match n_opt with + | None -> + let lid_loc = mk_lid_loc (Longident.Lident "None") in + mk_exp_loc (Pexp_construct (lid_loc, None)) + | Some n -> + let lid_loc = mk_lid_loc (Longident.Lident "Some") in + mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n))) + and mk_fmtty : type a b c d e f g h i j k l . + (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression + = + fun fmtty -> match fmtty with + | Char_ty rest -> mk_constr "Char_ty" [ mk_fmtty rest ] + | String_ty rest -> mk_constr "String_ty" [ mk_fmtty rest ] + | Int_ty rest -> mk_constr "Int_ty" [ mk_fmtty rest ] + | Int32_ty rest -> mk_constr "Int32_ty" [ mk_fmtty rest ] + | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ] + | Int64_ty rest -> mk_constr "Int64_ty" [ mk_fmtty rest ] + | Float_ty rest -> mk_constr "Float_ty" [ mk_fmtty rest ] + | Bool_ty rest -> mk_constr "Bool_ty" [ mk_fmtty rest ] + | Alpha_ty rest -> mk_constr "Alpha_ty" [ mk_fmtty rest ] + | Theta_ty rest -> mk_constr "Theta_ty" [ mk_fmtty rest ] + | Any_ty rest -> mk_constr "Any_ty" [ mk_fmtty rest ] + | Reader_ty rest -> mk_constr "Reader_ty" [ mk_fmtty rest ] + | Ignored_reader_ty rest -> + mk_constr "Ignored_reader_ty" [ mk_fmtty rest ] + | Format_arg_ty (sub_fmtty, rest) -> + mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ] + | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) -> + mk_constr "Format_subst_ty" + [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ] + | End_of_fmtty -> mk_constr "End_of_fmtty" [] + and mk_ignored : type a b c d e f . + (a, b, c, d, e, f) ignored -> Parsetree.expression = + fun ign -> match ign with + | Ignored_char -> + mk_constr "Ignored_char" [] + | Ignored_caml_char -> + mk_constr "Ignored_caml_char" [] + | Ignored_string pad_opt -> + mk_constr "Ignored_string" [ mk_int_opt pad_opt ] + | Ignored_caml_string pad_opt -> + mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ] + | Ignored_int (iconv, pad_opt) -> + mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_int32 (iconv, pad_opt) -> + mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_nativeint (iconv, pad_opt) -> + mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_int64 (iconv, pad_opt) -> + mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_float (pad_opt, prec_opt) -> + mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ] + | Ignored_bool pad_opt -> + mk_constr "Ignored_bool" [ mk_int_opt pad_opt ] + | Ignored_format_arg (pad_opt, fmtty) -> + mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ] + | Ignored_format_subst (pad_opt, fmtty) -> + mk_constr "Ignored_format_subst" [ + mk_int_opt pad_opt; mk_fmtty fmtty ] + | Ignored_reader -> + mk_constr "Ignored_reader" [] + | Ignored_scan_char_set (width_opt, char_set) -> + mk_constr "Ignored_scan_char_set" [ + mk_int_opt width_opt; mk_string char_set ] + | Ignored_scan_get_counter counter -> + mk_constr "Ignored_scan_get_counter" [ + mk_counter counter + ] + | Ignored_scan_next_char -> + mk_constr "Ignored_scan_next_char" [] + and mk_padding : type x y . (x, y) padding -> Parsetree.expression = + fun pad -> match pad with + | No_padding -> mk_constr "No_padding" [] + | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ] + | Arg_padding s -> mk_constr "Arg_padding" [ mk_side s ] + and mk_precision : type x y . (x, y) precision -> Parsetree.expression = + fun prec -> match prec with + | No_precision -> mk_constr "No_precision" [] + | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ] + | Arg_precision -> mk_constr "Arg_precision" [] + and mk_fmt : type a b c d e f . + (a, b, c, d, e, f) fmt -> Parsetree.expression = + fun fmt -> match fmt with + | Char rest -> + mk_constr "Char" [ mk_fmt rest ] + | Caml_char rest -> + mk_constr "Caml_char" [ mk_fmt rest ] + | String (pad, rest) -> + mk_constr "String" [ mk_padding pad; mk_fmt rest ] + | Caml_string (pad, rest) -> + mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ] + | Int (iconv, pad, prec, rest) -> + mk_constr "Int" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Int32 (iconv, pad, prec, rest) -> + mk_constr "Int32" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Nativeint (iconv, pad, prec, rest) -> + mk_constr "Nativeint" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Int64 (iconv, pad, prec, rest) -> + mk_constr "Int64" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Float (fconv, pad, prec, rest) -> + mk_constr "Float" [ + mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Bool (pad, rest) -> + mk_constr "Bool" [ mk_padding pad; mk_fmt rest ] + | Flush rest -> + mk_constr "Flush" [ mk_fmt rest ] + | String_literal (s, rest) -> + mk_constr "String_literal" [ mk_string s; mk_fmt rest ] + | Char_literal (c, rest) -> + mk_constr "Char_literal" [ mk_char c; mk_fmt rest ] + | Format_arg (pad_opt, fmtty, rest) -> + mk_constr "Format_arg" [ + mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ] + | Format_subst (pad_opt, fmtty, rest) -> + mk_constr "Format_subst" [ + mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ] + | Alpha rest -> + mk_constr "Alpha" [ mk_fmt rest ] + | Theta rest -> + mk_constr "Theta" [ mk_fmt rest ] + | Formatting_lit (fmting, rest) -> + mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ] + | Formatting_gen (fmting, rest) -> + mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ] + | Reader rest -> + mk_constr "Reader" [ mk_fmt rest ] + | Scan_char_set (width_opt, char_set, rest) -> + mk_constr "Scan_char_set" [ + mk_int_opt width_opt; mk_string char_set; mk_fmt rest ] + | Scan_get_counter (cnt, rest) -> + mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ] + | Scan_next_char rest -> + mk_constr "Scan_next_char" [ mk_fmt rest ] + | Ignored_param (ign, rest) -> + mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ] + | End_of_format -> + mk_constr "End_of_format" [] + | Custom _ -> + (* Custom formatters have no syntax so they will never appear + in formats parsed from strings. *) + assert false + in + let legacy_behavior = not !Clflags.strict_formats in + let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in + mk_constr "Format" [ mk_fmt fmt; mk_string str ] + )) + with Failure msg -> + raise (Error (loc, env, Invalid_format msg)) + +and type_label_exp create env loc ty_expected + (lid, label, sarg) = + (* Here also ty_expected may be at generic_level *) + let separate = !Clflags.principal || Env.has_local_constraints env in + let is_poly = label_is_poly label in + let (vars, arg) = + (* raise level to check univars *) + with_local_level_generalize_if is_poly begin fun () -> + let (vars, ty_arg) = + with_local_level_generalize_structure_if separate begin fun () -> + let (vars, ty_arg, ty_res) = + with_local_level_generalize_structure_if separate + (fun () -> instance_label ~fixed:true label) + in + begin try + unify env (instance ty_res) (instance ty_expected) + with Unify err -> + raise (Error(lid.loc, env, Label_mismatch(lid.txt, err))) + end; + (* Instantiate so that we can generalize internal nodes *) + let ty_arg = instance ty_arg in + (vars, ty_arg) + end + in + + if label.lbl_private = Private then + if create then + raise (Error(loc, env, Private_type ty_expected)) + else + raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); + (vars, type_argument env sarg ty_arg (instance ty_arg)) + end + ~before_generalize:(fun (_,arg) -> may_lower_contravariant env arg) + in + if is_poly then check_univars env "field value" arg label.lbl_arg vars; + (lid, label, {arg with exp_type = instance arg.exp_type}) + +and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = + (* ty_expected' may be generic *) + let no_labels ty = + let ls, tvar = list_labels env ty in + not tvar && List.for_all ((=) Nolabel) ls + in + let may_coerce = + if not (is_inferred sarg) then None else + let work () = + let te = expand_head env ty_expected' in + match get_desc te with + Tarrow(Nolabel,_,ty_res0,_) -> + Some (no_labels ty_res0, get_level te) + | _ -> None + in + (* Need to be careful not to expand local constraints here *) + if Env.has_local_constraints env then + let snap = Btype.snapshot () in + try_finally ~always:(fun () -> Btype.backtrack snap) work + else work () + in + match may_coerce with + Some (safe_expect, lv) -> + (* apply optional arguments when expected type is "" *) + (* we must be very careful about not breaking the semantics *) + let texp = + with_local_level_generalize_structure_if_principal + (fun () -> type_exp env sarg) + in + let rec make_args args ty_fun = + match get_desc (expand_head env ty_fun) with + | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> + let ty = option_none env (instance ty_arg) sarg.pexp_loc in + make_args ((l, Some ty) :: args) ty_fun + | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic -> + List.rev args, ty_fun, no_labels ty_res' + | Tvar _ -> List.rev args, ty_fun, false + | _ -> [], texp.exp_type, false + in + let args, ty_fun', simple_res = make_args [] texp.exp_type + and texp = {texp with exp_type = instance texp.exp_type} in + if not (simple_res || safe_expect) then begin + unify_exp ~sexp:sarg env texp ty_expected; + texp + end else begin + let warn = !Clflags.principal && + (lv <> generic_level || get_level ty_fun' <> generic_level) + and ty_fun = instance ty_fun' in + let ty_arg, ty_res = + match get_desc (expand_head env ty_expected) with + Tarrow(Nolabel,ty_arg,ty_res,_) -> ty_arg, ty_res + | _ -> assert false + in + unify_exp ~sexp:sarg env {texp with exp_type = ty_fun} ty_expected; + if args = [] then texp else + (* eta-expand to avoid side effects *) + let var_pair name ty = + let id = Ident.create_local name in + let desc = + { val_type = ty; val_kind = Val_reg; + val_attributes = []; + val_loc = Location.none; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let exp_env = Env.add_value id desc env in + {pat_desc = + Tpat_var (id, mknoloc name, desc.val_uid); + pat_type = ty; + pat_extra=[]; + pat_attributes = []; + pat_loc = Location.none; pat_env = env}, + {exp_type = ty; exp_loc = Location.none; exp_env = exp_env; + exp_extra = []; exp_attributes = []; + exp_desc = + Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)} + in + let eta_pat, eta_var = var_pair "eta" ty_arg in + let func texp = + let e = + {texp with exp_type = ty_res; exp_desc = + Texp_apply + (texp, + args @ [Nolabel, Some eta_var])} + in + let cases = [ case eta_pat e ] in + let cases_loc = { texp.exp_loc with loc_ghost = true } in + let param = name_cases "param" cases in + { texp with exp_type = ty_fun; exp_desc = + Texp_function ([], + Tfunction_cases + { cases; partial = Total; param; loc = cases_loc; + exp_extra = None; attributes = []; + }) + } + in + Location.prerr_warning texp.exp_loc + (Warnings.Eliminated_optional_arguments + (List.map (fun (l, _) -> Asttypes.string_of_label l) args)); + if warn then Location.prerr_warning texp.exp_loc + (Warnings.Non_principal_labels "eliminated optional argument"); + (* let-expand to have side effects *) + let let_pat, let_var = var_pair "arg" texp.exp_type in + re { texp with exp_type = ty_fun; exp_desc = + Texp_let (Nonrecursive, + [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]; + vb_loc=Location.none; vb_rec_kind = Dynamic; + }], + func let_var) } + end + | None -> + let texp = type_expect ?recarg env sarg + (mk_expected ?explanation ty_expected') in + unify_exp ~sexp:sarg env texp ty_expected; + texp + +and type_application env funct sargs = + (* funct.exp_type may be generic *) + let result_type omitted ty_fun = + List.fold_left + (fun ty_fun (l,ty,lv) -> newty2 ~level:lv (Tarrow(l,ty,ty_fun,commu_ok))) + ty_fun omitted + in + let has_label l ty_fun = + let ls, tvar = list_labels env ty_fun in + tvar || List.mem l ls + in + let eliminated_optional_arguments = ref [] in + let omitted_parameters = ref [] in + let type_unknown_arg (ty_fun, typed_args) (lbl, sarg) = + let (ty_arg, ty_res) = + let ty_fun = expand_head env ty_fun in + match get_desc ty_fun with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if get_level ty_fun >= get_level t1 && + not (is_prim ~name:"%identity" funct) + then + Location.prerr_warning sarg.pexp_loc + Warnings.Ignored_extra_argument; + unify env ty_fun (newty (Tarrow(lbl,t1,t2,commu_var ()))); + (t1, t2) + | Tarrow (l,t1,t2,_) when l = lbl + || !Clflags.classic && lbl = Nolabel && not (is_optional l) -> + (t1, t2) + | td -> + let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in + let ty_res = + result_type (!omitted_parameters @ !eliminated_optional_arguments) + ty_fun + in + match get_desc ty_res with + | Tarrow _ -> + if !Clflags.classic || not (has_label lbl ty_fun) then + raise (Error(sarg.pexp_loc, env, + Apply_wrong_label(lbl, ty_res, false))) + else + raise (Error(funct.exp_loc, env, Incoherent_label_order)) + | _ -> + let previous_arg_loc = + (* [typed_args] is the arguments typed until now, in reverse + order of appearance. Not all arguments have a location + attached (eg. an optional argument that is not passed). *) + typed_args + |> List.find_map + (function (_, Some (_, loc)) -> loc | _ -> None) + |> Option.value ~default:funct.exp_loc + in + raise(Error(funct.exp_loc, env, Apply_non_function { + funct; + func_ty = expand_head env funct.exp_type; + res_ty = expand_head env ty_res; + previous_arg_loc; + extra_arg_loc = sarg.pexp_loc; })) + in + let arg () = + let arg = type_expect env sarg (mk_expected ty_arg) in + if is_optional lbl then + unify_exp ~sexp:sarg env arg (type_option(newvar())); + arg + in + (ty_res, (lbl, Some (arg, Some sarg.pexp_loc)) :: typed_args) + in + let ignore_labels = + !Clflags.classic || + begin + let ls, tvar = list_labels env funct.exp_type in + not tvar && + let labels = List.filter (fun l -> not (is_optional l)) ls in + List.length labels = List.length sargs && + List.for_all (fun (l,_) -> l = Nolabel) sargs && + List.exists (fun l -> l <> Nolabel) labels && + (Location.prerr_warning + funct.exp_loc + (Warnings.Labels_omitted + (List.map Asttypes.string_of_label + (List.filter ((<>) Nolabel) labels))); + true) + end + in + let warned = ref false in + (* [args] remember the location of each argument in sources. *) + let rec type_args args ty_fun ty_fun0 sargs = + let type_unknown_args () = + (* We're not looking at a *known* function type anymore, or there are no + arguments left. *) + let ty_fun, typed_args = + List.fold_left type_unknown_arg (ty_fun0, args) sargs + in + let args = + (* Force typing of arguments. + Careful: the order matters here. Using [List.rev_map] would be + incorrect. *) + List.map + (function + | l, None -> l, None + | l, Some (f, _loc) -> l, Some (f ())) + (List.rev typed_args) + in + let result_ty = instance (result_type !omitted_parameters ty_fun) in + args, result_ty + in + if sargs = [] then type_unknown_args () else + let ty_fun' = expand_head env ty_fun in + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + | Tarrow (l, ty, ty_fun, com), Tarrow (_, ty0, ty_fun0, _) + when is_commu_ok com -> + let lv = get_level ty_fun' in + let may_warn loc w = + if not !warned && !Clflags.principal && lv <> generic_level + then begin + warned := true; + Location.prerr_warning loc w + end + in + let name = label_name l + and optional = is_optional l in + let use_arg sarg l' = + if not optional || is_optional l' then + (fun () -> type_argument env sarg ty ty0) + else begin + may_warn sarg.pexp_loc + (not_principal "using an optional argument here"); + (fun () -> option_some env (type_argument env sarg + (extract_option_type env ty) + (extract_option_type env ty0))) + end + in + let eliminate_optional_arg () = + may_warn funct.exp_loc + (Warnings.Non_principal_labels "eliminated optional argument"); + eliminated_optional_arguments := + (l,ty,lv) :: !eliminated_optional_arguments; + (fun () -> option_none env (instance ty) Location.none) + in + let remaining_sargs, arg = + if ignore_labels then begin + (* No reordering is allowed, process arguments in order *) + match sargs with + | [] -> assert false + | (l', sarg) :: remaining_sargs -> + if name = label_name l' || (not optional && l' = Nolabel) then + (remaining_sargs, Some (use_arg sarg l', Some sarg.pexp_loc)) + else if + optional && + not (List.exists (fun (l, _) -> name = label_name l) + remaining_sargs) && + List.exists (function (Nolabel, _) -> true | _ -> false) + sargs + then + (sargs, Some (eliminate_optional_arg (), Some sarg.pexp_loc)) + else + raise(Error(sarg.pexp_loc, env, + Apply_wrong_label(l', ty_fun', optional))) + end else + (* Arguments can be commuted, try to fetch the argument + corresponding to the first parameter. *) + match extract_label name sargs with + | Some (l', sarg, commuted, remaining_sargs) -> + if commuted then begin + may_warn sarg.pexp_loc + (not_principal "commuting this argument") + end; + if not optional && is_optional l' then + Location.prerr_warning sarg.pexp_loc + (Warnings.Nonoptional_label (Asttypes.string_of_label l)); + remaining_sargs, Some (use_arg sarg l', Some sarg.pexp_loc) + | None -> + sargs, + if optional && List.mem_assoc Nolabel sargs then + Some (eliminate_optional_arg (), None) + else begin + (* No argument was given for this parameter, we abstract over + it. *) + may_warn funct.exp_loc + (Warnings.Non_principal_labels "commuted an argument"); + omitted_parameters := (l,ty,lv) :: !omitted_parameters; + None + end + in + type_args ((l,arg)::args) ty_fun ty_fun0 remaining_sargs + | _ -> + type_unknown_args () + in + let is_ignore funct = + is_prim ~name:"%ignore" funct && + (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true + with Filter_arrow_failed _ -> false) + in + match sargs with + | (* Special case for ignore: avoid discarding warning *) + [Nolabel, sarg] when is_ignore funct -> + let ty_arg, ty_res = + filter_arrow env (instance funct.exp_type) Nolabel in + let exp = type_expect env sarg (mk_expected ty_arg) in + check_partial_application ~statement:false exp; + ([Nolabel, Some exp], ty_res) + | _ -> + let ty = funct.exp_type in + type_args [] ty (instance ty) sargs + +and type_construct env ~sexp lid sarg ty_expected_explained = + let { ty = ty_expected; explanation } = ty_expected_explained in + let expected_type = + match extract_concrete_variant env ty_expected with + | Variant_type(p0, p,_) -> + Some(p0, p, is_principal ty_expected) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let ctx = Expression explanation in + let error = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (Error (sexp.pexp_loc, env, error)) + in + let constrs = + Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env + in + let constr = + wrap_disambiguate "This variant expression is expected to have" + ty_expected_explained + (Constructor.disambiguate Env.Positive lid env expected_type) constrs + in + let sargs = + match sarg with + None -> [] + | Some {pexp_desc = Pexp_tuple sel} when + constr.cstr_arity > 1 + || Builtin_attributes.explicit_arity sexp.pexp_attributes + -> sel + | Some se -> [se] in + if List.length sargs <> constr.cstr_arity then + raise(Error(sexp.pexp_loc, env, + Constructor_arity_mismatch + (lid.txt, constr.cstr_arity, List.length sargs))); + let separate = !Clflags.principal || Env.has_local_constraints env in + let ty_args, ty_res, texp = + with_local_level_generalize_structure_if separate begin fun () -> + let ty_args, ty_res, texp = + with_local_level_generalize_structure_if separate begin fun () -> + let (ty_args, ty_res, _) = + instance_constructor Keep_existentials_flexible constr + in + let texp = + re { + exp_desc = Texp_construct(lid, constr, []); + exp_loc = sexp.pexp_loc; exp_extra = []; + exp_type = ty_res; + exp_attributes = sexp.pexp_attributes; + exp_env = env } in + (ty_args, ty_res, texp) + end + in + with_explanation explanation (fun () -> + unify_exp ~sexp env {texp with exp_type = instance ty_res} + (instance ty_expected)); + (ty_args, ty_res, texp) + end + in + let ty_args0, ty_res = + match instance_list (ty_res :: ty_args) with + t :: tl -> tl, t + | _ -> assert false + in + let texp = {texp with exp_type = ty_res} in + if not separate then unify_exp ~sexp env texp (instance ty_expected); + let recarg = + match constr.cstr_inlined with + | None -> Rejected + | Some _ -> + begin match sargs with + | [{pexp_desc = + Pexp_ident _ | + Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> + Required + | _ -> + raise (Error(sexp.pexp_loc, env, Inlined_record_expected)) + end + in + let args = + List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs + (List.combine ty_args ty_args0) in + if constr.cstr_private = Private then + begin match constr.cstr_tag with + | Cstr_extension _ -> + raise(Error(sexp.pexp_loc, env, Private_constructor (constr, ty_res))) + | Cstr_constant _ | Cstr_block _ | Cstr_unboxed -> + raise (Error(sexp.pexp_loc, env, Private_type ty_res)); + end; + (* NOTE: shouldn't we call "re" on this final expression? -- AF *) + { texp with + exp_desc = Texp_construct(lid, constr, args) } + +(* Typing of statements (expressions whose values are discarded) *) + +and type_statement ?explanation env sexp = + (* OCaml 5.2.0 changed the type of 'while' to give 'while true do e done' + a polymorphic type. The change has the potential to trigger a + nonreturning-statement warning in existing code that follows + 'while true' with some other statement, e.g. + + while true do e done; assert false + + To avoid this issue, we disable the warning in this particular case. + We might consider re-enabling it at a point when most users have + migrated to OCaml 5.2.0 or later. *) + let allow_polymorphic e = match e.exp_desc with + | Texp_while _ -> true + | _ -> false + in + (* Raise the current level to detect non-returning functions *) + with_local_level_generalize (fun () -> type_exp env sexp) + ~before_generalize: begin fun exp -> + let subexp = final_subexpression exp in + let ty = expand_head env exp.exp_type in + if is_Tvar ty + && get_level ty > get_current_level () + && not (allow_polymorphic subexp) then + Location.prerr_warning + subexp.exp_loc + Warnings.Nonreturning_statement; + if !Clflags.strict_sequence then + let expected_ty = instance Predef.type_unit in + with_explanation explanation (fun () -> + unify_exp ~sexp env exp expected_ty) + else begin + check_partial_application ~statement:true exp; + enforce_current_level env ty + end + end + +(* Most of the arguments are the same as [type_cases]. + + Takes a callback which is responsible for typing the body of the case. + The arguments are documented inline in the type signature. + + It takes a callback rather than returning the half-typed cases directly + because the typing of the body must take place at an increased level. + + The overall function returns: + - The data returned by the callback + - Whether the cases' patterns are partial or total +*) +and map_half_typed_cases + : type k ret case_data. + ?additional_checks_for_split_cases:((_ * ret) list -> unit) -> ?conts:_ + -> k pattern_category -> _ -> _ -> _ -> _ + -> (untyped_case * case_data) list + -> type_body:( + case_data + -> k general_pattern (* the typed pattern *) + -> when_env:_ (* environment with module/pattern variables *) + -> ext_env:_ (* when_env + continuation var*) + -> cont:_ + -> ty_expected:_ (* type to check body in scope of *) + -> ty_infer:_ (* type to infer for body *) + -> contains_gadt:_ (* whether the pattern contains a GADT *) + -> ret) + -> check_if_total:bool (* if false, assume Partial right away *) + -> ret list * partial + = fun ?additional_checks_for_split_cases ?conts + category env ty_arg ty_res loc caselist ~type_body ~check_if_total -> + (* ty_arg is _fully_ generalized *) + let patterns = List.map (fun ((x : untyped_case), _) -> x.pattern) caselist in + let contains_polyvars = List.exists contains_polymorphic_variant patterns in + let erase_either = contains_polyvars && contains_variant_either ty_arg in + let may_contain_gadts = List.exists may_contain_gadts patterns in + let may_contain_modules = List.exists may_contain_modules patterns in + let create_inner_level = may_contain_gadts || may_contain_modules in + let ty_arg = + if (may_contain_gadts || erase_either) && not !Clflags.principal + then duplicate_type ty_arg else ty_arg + in + let rec is_var spat = + match spat.ppat_desc with + Ppat_any | Ppat_var _ -> true + | Ppat_alias (spat, _) -> is_var spat + | _ -> false in + let needs_exhaust_check = + match caselist with + [ ({ needs_refute = true }, _) ] -> true + | [ ({ pattern }, _) ] when is_var pattern -> false + | _ -> true + in + let outer_level = get_current_level () in + with_local_level_iter_if create_inner_level begin fun () -> + let lev = get_current_level () in + let allow_modules = + if may_contain_modules + then + (* The corresponding check for scope escape is done together with + the check for GADT-induced existentials by + [with_local_level_iter_if create_inner_level]. + *) + Modules_allowed { scope = lev } + else Modules_rejected + in + let take_partial_instance = + if erase_either + then Some false else None + in + let map_conts f conts caselist = match conts with + | None -> List.map (fun c -> f c None) caselist + | Some conts -> List.map2 f caselist conts + in + let half_typed_cases, ty_res, do_copy_types, ty_arg' = + (* propagation of the argument *) + with_local_level_generalize begin fun () -> + let pattern_force = ref [] in + (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_arg; *) + let half_typed_cases = + map_conts + (fun ({ Parmatch.pattern; _ } as untyped_case, case_data) cont -> + let htc = + with_local_level_generalize_structure_if_principal begin fun () -> + let ty_arg = + (* propagation of pattern *) + with_local_level_generalize_structure + (fun () -> instance ?partial:take_partial_instance ty_arg) + in + let (pat, ext_env, force, pvs, mvs) = + type_pattern ?cont category ~lev env pattern ty_arg + allow_modules + in + pattern_force := force @ !pattern_force; + { typed_pat = pat; + pat_type_for_unif = ty_arg; + untyped_case; + case_data; + branch_env = ext_env; + pat_vars = pvs; + module_vars = mvs; + contains_gadt = contains_gadt (as_comp_pattern category pat); + } + end + in + (* Ensure that no ambivalent pattern type escapes its branch *) + check_scope_escape htc.typed_pat.pat_loc env outer_level + htc.pat_type_for_unif; + let pat = htc.typed_pat in + {htc with typed_pat = { pat with pat_type = instance pat.pat_type }} + ) + conts caselist in + let patl = + List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in + let does_contain_gadt = + List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases + in + let ty_res, do_copy_types = + if does_contain_gadt && not !Clflags.principal then + duplicate_type ty_res, Env.make_copy_of_types env + else ty_res, (fun env -> env) + in + (* Unify all cases (delayed to keep it order-free) *) + let ty_arg' = newvar () in + let unify_pats ty = + List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } -> + unify_pat_types pat.pat_loc env pat_ty ty + ) half_typed_cases + in + unify_pats ty_arg'; + (* Check for polymorphic variants to close *) + if List.exists has_variants patl then begin + Parmatch.pressure_variants_in_computation_pattern env + (List.map (as_comp_pattern category) patl); + List.iter finalize_variants patl + end; + (* `Contaminating' unifications start here *) + List.iter (fun f -> f()) !pattern_force; + (* Post-processing and generalization *) + if take_partial_instance <> None then unify_pats (instance ty_arg); + List.iter (fun { pat_vars; _ } -> + iter_pattern_variables_type (enforce_current_level env) pat_vars + ) half_typed_cases; + (half_typed_cases, ty_res, do_copy_types, ty_arg') + end + in + (* type bodies *) + let ty_res' = instance ty_res in + (* Why is it needed to keep the level of result raised ? *) + let result = with_local_level_if_principal ~post:ignore begin fun () -> + map_conts + (fun { typed_pat = pat; branch_env = ext_env; + pat_vars = pvs; module_vars = mvs; + case_data; contains_gadt; _ } cont + -> + let ext_env = + if contains_gadt then + do_copy_types ext_env + else + ext_env + in + (* Before handing off the cases to the callback, first set up the the + branch environments by adding the variables (and module variables) + from the patterns. + *) + let cont_vars, pvs = + List.partition (fun pv -> pv.pv_kind = Continuation_var) pvs in + let add_pattern_vars = add_pattern_variables + ~check:(fun s -> Warnings.Unused_var_strict s) + ~check_as:(fun s -> Warnings.Unused_var s) + in + let when_env = add_pattern_vars ext_env pvs in + let when_env = add_module_variables when_env mvs in + let ext_env = add_pattern_vars when_env cont_vars in + let ty_expected = + if contains_gadt && not !Clflags.principal then + (* Take a generic copy of [ty_res] again to allow propagation of + type information from preceding branches *) + duplicate_type ty_res + else ty_res in + type_body case_data pat ~when_env ~ext_env ~cont ~ty_expected + ~ty_infer:ty_res' ~contains_gadt) + conts half_typed_cases + end in + let do_init = may_contain_gadts || needs_exhaust_check in + let ty_arg_check = + if do_init then + (* Hack: use for_saving to copy variables too *) + Subst.type_expr (Subst.for_saving Subst.identity) ty_arg' + else ty_arg' + in + (* Split the cases into val and exn cases so we can do the appropriate checks + for exhaustivity and unused variables. + + The caller of this function can define custom checks. For some of these + checks, the half-typed case doesn't provide enough info on its own -- for + instance, the check for ambiguous bindings in when guards needs to know the + case body's expression -- so the code pairs each case with its + corresponding element in [result] before handing it off to the caller's + custom checks. + *) + let val_cases_with_result, exn_cases_with_result = + match category with + | Value -> + let val_cases = + List.map2 + (fun htc res -> + { htc.untyped_case with pattern = htc.typed_pat }, res) + half_typed_cases + result + in + (val_cases : (pattern Parmatch.parmatch_case * ret) list), [] + | Computation -> + split_half_typed_cases env (List.combine half_typed_cases result) + in + let val_cases = List.map fst val_cases_with_result in + let exn_cases = List.map fst exn_cases_with_result in + if val_cases = [] && exn_cases <> [] then + raise (Error (loc, env, No_value_clauses)); + let partial = + if check_if_total then + check_partial ~lev env ty_arg_check loc val_cases + else + Partial + in + let unused_check delayed = + List.iter (fun { typed_pat; branch_env; _ } -> + check_absent_variant branch_env (as_comp_pattern category typed_pat) + ) half_typed_cases; + with_level_if delayed ~level:lev begin fun () -> + check_unused ~lev env ty_arg_check val_cases ; + check_unused ~lev env Predef.type_exn exn_cases ; + end; + in + if contains_polyvars then + add_delayed_check (fun () -> unused_check true) + else + (* Check for unused cases, do not delay because of gadts *) + unused_check false; + begin + match additional_checks_for_split_cases with + | None -> () + | Some check -> + check val_cases_with_result; + check exn_cases_with_result; + end; + (result, partial), [ty_res'] + end + (* Ensure that existential types do not escape *) + ~post:(fun ty_res' -> unify_exp_types loc env ty_res' (newvar ())) + +(* Typing of match cases *) +and type_cases + : type k . k pattern_category -> _ -> _ -> _ -> ?conts:_ -> + check_if_total:bool -> _ -> Parsetree.case list -> + k case list * partial + = fun category env + ty_arg ty_res_explained ?conts ~check_if_total loc caselist -> + let { ty = ty_res; explanation } = ty_res_explained in + let caselist = + List.map (fun case -> Parmatch.untyped_case case, case) caselist + in + (* Most of the work is done by [map_half_typed_cases]. All that's left + is to typecheck the guards and the cases, and then to check for some + warnings that can fire in the presence of guards. + *) + map_half_typed_cases ?conts category env ty_arg ty_res loc caselist + ~check_if_total + ~type_body:begin + fun { pc_guard; pc_rhs } pat ~when_env ~ext_env ~cont ~ty_expected + ~ty_infer ~contains_gadt:_ -> + let cont = Option.map (fun (id,_) -> id) cont in + let guard = + match pc_guard with + | None -> None + | Some scond -> + (* It is crucial that the continuation is not used in the + `when' expression as the extent of the continuation is + yet to be determined. We make the continuation + inaccessible by typing the `when' expression using the + environment `ext_env' which does not bind the + continuation variable. *) + Some + (type_expect when_env scond + (mk_expected ~explanation:When_guard Predef.type_bool)) + in + let exp = + type_expect ext_env pc_rhs (mk_expected ?explanation ty_expected) + in + { + c_lhs = pat; + c_cont = cont; + c_guard = guard; + c_rhs = {exp with exp_type = ty_infer} + } + end + ~additional_checks_for_split_cases:(fun cases -> + let cases = + List.map + (fun (case_with_pat, case) -> + { case with c_lhs = case_with_pat.Parmatch.pattern }) cases + in + Parmatch.check_ambiguous_bindings cases) + + +(** A version of [type_expect], but that operates over function cases instead + of expressions. The input type is like the [ty_expected] argument to + [type_expect], and the returned type is like the [exp_type] of the + expression returned by [type_expect]. + + See [split_function_ty] for the meaning of [first] and [in_function]. +*) +and type_function_cases_expect + env ty_expected loc cases attrs ~first ~in_function = + Builtin_attributes.warning_scope attrs begin fun () -> + let ty_arg, ty_res = + split_function_ty env ty_expected ~arg_label:Nolabel ~first ~in_function + in + let cases, partial = + type_cases Value env ty_arg (mk_expected ty_res) + ~check_if_total:true loc cases + in + let ty_fun = + instance (newgenty (Tarrow (Nolabel, ty_arg, ty_res, commu_ok))) + in + unify_exp_types loc env ty_fun (instance ty_expected); + cases, partial, ty_fun + end + +and type_effect_cases + : type k . k pattern_category -> _ -> _ -> _ -> Parsetree.case list -> _ + -> k case list + = fun category env ty_res_explained loc caselist conts -> + let { ty = ty_res; explanation = _ } = ty_res_explained in + let _ = newvar () in + (* remember original level *) + with_local_level begin fun () -> + (* Create a locally type abstract type for effect type. *) + let new_env, ty_arg, ty_cont = + let decl = Ctype.new_local_type ~loc Definition in + let scope = create_scope () in + let name = Ctype.get_new_abstract_name env "%eff" in + let id = Ident.create_scoped ~scope name in + let new_env = Env.add_type ~check:false id decl env in + let ty_eff = newgenty (Tconstr (Path.Pident id,[],ref Mnil)) in + new_env, + Predef.type_eff ty_eff, + Predef.type_continuation ty_eff ty_res + in + let conts = List.map (type_continuation_pat env ty_cont) conts in + let cases, _ = type_cases category new_env ty_arg + ty_res_explained ~conts ~check_if_total:false loc caselist + in + cases + end + +(* Typing of let bindings *) + +and type_let ?check ?check_strict + existential_context env rec_flag spat_sexp_list allow_modules = + let spatl = List.map vb_pat_constraint spat_sexp_list in + let attrs_list = List.map fst spatl in + let is_recursive = (rec_flag = Recursive) in + + let (pat_list, exp_list, new_env, mvs) = + with_local_level_generalize begin fun () -> + if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); + let (pat_list, new_env, force, pvs, mvs) = + with_local_level_generalize_structure_if_principal begin fun () -> + let nvs = List.map (fun _ -> newvar ()) spatl in + let (pat_list, _new_env, _force, _pvs, _mvs as res) = + type_pattern_list + Value existential_context env spatl nvs allow_modules in + (* If recursive, first unify with an approximation of the + expression *) + if is_recursive then + List.iter2 + (fun pat binding -> + let pat = + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + {pat with pat_type = + snd (instance_poly ~keep_names:true ~fixed:false tl ty)} + | _ -> pat + in + let bound_expr = vb_exp_constraint binding in + unify_pat env pat (type_approx env bound_expr)) + pat_list spat_sexp_list; + (* Polymorphic variant processing *) + List.iter + (fun pat -> + if has_variants pat then begin + Parmatch.pressure_variants env [pat]; + finalize_variants pat + end) + pat_list; + res + end + in + (* Note [add_module_variables after checking expressions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Don't call [add_module_variables] here, because its use of + [type_module] will fail until after we have type-checked the expression + of the let. Example: [let m : (module S) = ... in let (module M) = m in + ...] We learn the signature [S] from the type of [m] in the RHS of the + second let, and we need that knowledge for [type_module] to succeed. If + we type-checked expressions before patterns, then we could call + [add_module_variables] here. + *) + let new_env = add_pattern_variables new_env pvs in + let pat_list = + List.map + (fun pat -> {pat with pat_type = instance pat.pat_type}) + pat_list + in + (* Only bind pattern variables after generalizing *) + List.iter (fun f -> f()) force; + + let exp_list = + (* See Note [add_module_variables after checking expressions] + We can't defer type-checking module variables with recursive + definitions, so things like [let rec (module M) = m in ...] always + fail, even if the type of [m] is known. + *) + let exp_env = + if is_recursive then add_module_variables new_env mvs else env + in + type_let_def_wrap_warnings ?check ?check_strict ~is_recursive + ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + (fun exp_env ({pvb_attributes; _} as vb) pat -> + let sexp = vb_exp_constraint vb in + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + let vars, ty' = + with_local_level_generalize_structure_if_principal + (fun () -> instance_poly ~keep_names:true ~fixed:true tl ty) + in + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected ty')) + in + exp, Some vars + | _ -> + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected pat.pat_type)) + in + exp, None) + in + List.iter2 + (fun pat (attrs, exp) -> + Builtin_attributes.warning_scope ~ppwarning:false attrs + (fun () -> + let case = Parmatch.typed_case (case pat exp) in + ignore(check_partial env pat.pat_type pat.pat_loc + [case] : Typedtree.partial) + ) + ) + pat_list + (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list); + (pat_list, exp_list, new_env, mvs) + end + ~before_generalize: begin fun (pat_list, exp_list, _, _) -> + List.iter2 (fun pat (exp, vars) -> + if maybe_expansive exp then begin + lower_contravariant env pat.pat_type; + if vars <> None then lower_contravariant env exp.exp_type + end) + pat_list exp_list + end + in + List.iter2 + (fun pat (exp, vars) -> + Option.iter (check_univars env "definition" exp pat.pat_type) vars) + pat_list exp_list; + let l = List.combine pat_list exp_list in + let l = + List.map2 + (fun (p, (e, _)) pvb -> + (* vb_rec_kind will be computed later for recursive bindings *) + {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; + vb_loc=pvb.pvb_loc; vb_rec_kind = Dynamic; + }) + l spat_sexp_list + in + if is_recursive then + List.iter + (fun {vb_pat=pat} -> match pat.pat_desc with + Tpat_var _ -> () + | Tpat_alias ({pat_desc=Tpat_any}, _, _, _) -> () + | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat))) + l; + List.iter (fun vb -> + if pattern_needs_partial_application_check vb.vb_pat then + check_partial_application ~statement:false vb.vb_expr + ) l; + (* See Note [add_module_variables after checking expressions] *) + let new_env = add_module_variables new_env mvs in + (l, new_env) + +and type_let_def_wrap_warnings + ?(check = fun s -> Warnings.Unused_var s) + ?(check_strict = fun s -> Warnings.Unused_var_strict s) + ~is_recursive ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + type_def = + let is_fake_let = + match spat_sexp_list with + | [{pvb_expr={pexp_desc=Pexp_match( + {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] -> + true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) + | _ -> + false + in + let check = if is_fake_let then check_strict else check in + let warn_about_unused_bindings = + List.exists + (fun attrs -> + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + Warnings.is_active (check "") || Warnings.is_active (check_strict "") + || (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag)))) + attrs_list + in + let sexp_is_fun { pvb_expr = sexp; _ } = + match sexp.pexp_desc with + | Pexp_function _ -> true + | _ -> false + in + let exp_env = + if not is_recursive && List.for_all sexp_is_fun spat_sexp_list then begin + (* Add ghost bindings to help detecting missing "rec" keywords. + + We only add those if the body of the definition is obviously a + function. The rationale is that, in other cases, the hint is probably + wrong (and the user is using "advanced features" anyway (lazy, + recursive values...)). + + [pvb_loc] (below) is the location of the first let-binding (in case of + a let .. and ..), and is where the missing "rec" hint suggests to add a + "rec" keyword. *) + match spat_sexp_list with + | {pvb_loc; _} :: _ -> + maybe_add_pattern_variables_ghost pvb_loc exp_env pvs + | _ -> assert false + end + else exp_env + in + (* Algorithm to detect unused declarations in recursive bindings: + - During type checking of the definitions, we capture the 'value_used' + events on the bound identifiers and record them in a slot corresponding + to the current definition (!current_slot). + In effect, this creates a dependency graph between definitions. + + - After type checking the definition (!current_slot = None), + when one of the bound identifier is effectively used, we trigger + again all the events recorded in the corresponding slot. + The effect is to traverse the transitive closure of the graph created + in the first step. + + We also keep track of whether *all* variables in a given pattern + are unused. If this is the case, for local declarations, the issued + warning is 26, not 27. + *) + let current_slot = ref None in + let rec_needed = ref false in + let pat_slot_list = + List.map2 + (fun attrs pat -> + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + if not warn_about_unused_bindings then pat, None + else + let some_used = ref false in + (* has one of the identifier of this pattern been used? *) + let slot = ref [] in + List.iter + (fun id -> + let vd = Env.find_value (Path.Pident id) new_env in + (* note: Env.find_value does not trigger the value_used + event *) + let name = Ident.name id in + let used = ref false in + if not (name = "" || name.[0] = '_' || name.[0] = '#') then + add_delayed_check + (fun () -> + if not !used then + Location.prerr_warning vd.Types.val_loc + ((if !some_used then check_strict else check) name) + ); + Env.set_value_used_callback + vd + (fun () -> + match !current_slot with + | Some slot -> + slot := vd.val_uid :: !slot; rec_needed := true + | None -> + List.iter Env.mark_value_used (get_ref slot); + used := true; + some_used := true + ) + ) + (Typedtree.pat_bound_idents pat); + pat, Some slot + )) + attrs_list + pat_list + in + let exp_list = + List.map2 + (fun case (pat, slot) -> + if is_recursive then current_slot := slot; + type_def exp_env case pat) + spat_sexp_list pat_slot_list + in + current_slot := None; + if is_recursive && not !rec_needed then begin + let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in + (* See PR#6677 *) + Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes + (fun () -> + Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag + ) + end; + exp_list + +and type_andops env sarg sands expected_ty = + let rec loop env let_sarg rev_sands expected_ty = + match rev_sands with + | [] -> type_expect env let_sarg (mk_expected expected_ty), [] + | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest -> + let op_path, op_desc, op_type, ty_arg, ty_rest, ty_result = + with_local_level_generalize_structure_if_principal begin fun () -> + let op_path, op_desc = type_binding_op_ident env sop in + let op_type = instance op_desc.val_type in + let ty_arg = newvar () in + let ty_rest = newvar () in + let ty_result = newvar() in + let ty_rest_fun = + newty (Tarrow(Nolabel, ty_arg, ty_result, commu_ok)) in + let ty_op = + newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in + begin try + unify env op_type ty_op + with Unify err -> + raise(Error(sop.loc, env, Andop_type_clash(sop.txt, err))) + end; + (op_path, op_desc, op_type, ty_arg, ty_rest, ty_result) + end + in + let let_arg, rest = loop env let_sarg rest ty_rest in + let exp = type_expect env sexp (mk_expected ty_arg) in + begin try + unify env (instance ty_result) (instance expected_ty) + with Unify err -> + raise(Error(loc, env, Bindings_type_clash(err))) + end; + let andop = + { bop_op_name = sop; + bop_op_path = op_path; + bop_op_val = op_desc; + bop_op_type = op_type; + bop_exp = exp; + bop_loc = loc } + in + let_arg, andop :: rest + in + let let_arg, rev_ands = loop env sarg (List.rev sands) expected_ty in + let_arg, List.rev rev_ands + +(* Typing of method call *) +and type_send env loc explanation e met = + let obj = type_exp env e in + let (meth, typ) = + match obj.exp_desc with + | Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}) -> + let id, typ = + match meths with + | Self_concrete meths -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + id, typ + | Self_virtual meths_ref -> begin + match Meths.find met !meths_ref with + | id -> id, Btype.method_type met sign + | exception Not_found -> + let id = Ident.create_local met in + let ty = newvar () in + meths_ref := Meths.add met id !meths_ref; + add_method env met Private Virtual ty sign; + Location.prerr_warning loc + (Warnings.Undeclared_virtual_method met); + id, ty + end + in + Tmeth_val id, typ + | Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}) -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Tmeth_ancestor(id, self_path), typ + | _ -> + let ty = + match filter_method env met obj.exp_type with + | ty -> ty + | exception Filter_method_failed err -> + let error = + match err with + | Unification_error err -> + Expr_type_clash(err, explanation, None) + | Not_an_object ty -> + Not_an_object(ty, explanation) + | Not_a_method -> + let valid_methods = + match get_desc (expand_head env obj.exp_type) with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if field_kind_repr meth_kind = Fpublic + then meth::li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + Undefined_method(obj.exp_type, met, valid_methods) + in + raise (Error(e.pexp_loc, env, error)) + in + Tmeth_name met, ty + in + (obj,meth,typ) + +(* Typing of toplevel bindings *) + +let type_binding env rec_flag spat_sexp_list = + let (pat_exp_list, new_env) = + type_let + ~check:(fun s -> Warnings.Unused_value_declaration s) + ~check_strict:(fun s -> Warnings.Unused_value_declaration s) + At_toplevel + env rec_flag spat_sexp_list Modules_rejected + in + (pat_exp_list, new_env) + +let type_let existential_ctx env rec_flag spat_sexp_list = + let (pat_exp_list, new_env) = + type_let existential_ctx env rec_flag spat_sexp_list Modules_rejected in + (pat_exp_list, new_env) + +(* Typing of toplevel expressions *) + +let type_expression env sexp = + let exp = + with_local_level_generalize begin fun () -> + Typetexp.TyVarEnv.reset(); + type_exp env sexp + end + ~before_generalize:(may_lower_contravariant env) + in + match sexp.pexp_desc with + Pexp_ident lid -> + let loc = sexp.pexp_loc in + (* Special case for keeping type variables when looking-up a variable *) + let (_path, desc) = Env.lookup_value ~use:false ~loc lid.txt env in + {exp with exp_type = desc.val_type} + | _ -> exp + +(* Error report *) + +let spellcheck ppf unbound_name valid_names = + Misc.did_you_mean ppf (fun () -> + Misc.spellcheck valid_names unbound_name + ) + +let spellcheck_idents ppf unbound valid_idents = + spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) + +open Format_doc +module Fmt = Format_doc +module Printtyp = Printtyp.Doc + +let longident = Printtyp.longident + +(* Returns the first diff of the trace *) +let type_clash_of_trace trace = + Errortrace.(explain trace (fun ~prev:_ -> function + | Diff diff -> Some diff + | _ -> None + )) + +(** More precise denomination for type errors. Used by messages: + + - [This ...] + - [The "foo" ...] *) +let pp_exp_denom ppf pexp = + let d = pp_print_string ppf in + let d_expression = fprintf ppf "%a expression" Style.inline_code in + match pexp.pexp_desc with + | Pexp_constant _ -> d "constant" + | Pexp_ident _ -> d "value" + | Pexp_construct _ | Pexp_variant _ -> d "constructor" + | Pexp_field _ -> d "field access" + | Pexp_send _ -> d "method call" + | Pexp_while _ -> d_expression "while" + | Pexp_for _ -> d_expression "for" + | Pexp_ifthenelse _ -> d_expression "if-then-else" + | Pexp_match _ -> d_expression "match" + | Pexp_try _ -> d_expression "try-with" + | _ -> d "expression" + +(** Implements the "This expression" message, printing the expression if it + should be according to {!Parsetree.Doc.nominal_exp}. *) +let report_this_pexp_has_type denom ppf exp = + let denom ppf = + match denom, exp with + | Some d, _ -> fprintf ppf "%s" d + | None, Some exp -> pp_exp_denom ppf exp + | None, None -> fprintf ppf "expression" + in + let nexp = Option.bind exp Pprintast.Doc.nominal_exp in + match nexp with + | Some nexp -> + fprintf ppf "The %t %a has type" denom (Style.as_inline_code pp_doc) nexp + | _ -> fprintf ppf "This %t has type" denom + +let report_this_texp_has_type denom ppf texp = + report_this_pexp_has_type denom ppf (Some (Untypeast.untype_expression texp)) + +(* Hint on type error on integer literals + To avoid confusion, it is disabled on float literals + and when the expected type is `int` *) +let report_literal_type_constraint expected_type const = + let const_str = match const.pconst_desc with + | Pconst_integer (s, _) -> Some s + | _ -> None + in + let suffix = + if Path.same expected_type Predef.path_int32 then + Some 'l' + else if Path.same expected_type Predef.path_int64 then + Some 'L' + else if Path.same expected_type Predef.path_nativeint then + Some 'n' + else if Path.same expected_type Predef.path_float then + Some '.' + else None + in + let pp_const ppf (c,s) = Fmt.fprintf ppf "%s%c" c s in + match const_str, suffix with + | Some c, Some s -> [ + Location.msg + "@[@{Hint@}: Did you mean %a?@]" + (Style.as_inline_code pp_const) (c,s) + ] + | _, _ -> [] + +let report_literal_type_constraint const = function + | Some tr -> + begin match get_desc Errortrace.(tr.expected.ty) with + Tconstr (typ, [], _) -> + report_literal_type_constraint typ const + | _ -> [] + end + | None -> [] + +let report_partial_application = function + | Some tr -> begin + match get_desc tr.Errortrace.got.Errortrace.expanded with + | Tarrow _ -> + [ Location.msg + "@[@{Hint@}: This function application is partial,@ \ + maybe some arguments are missing.@]" ] + | _ -> [] + end + | None -> [] + +let report_expr_type_clash_hints exp diff = + match exp with + | Some exp -> begin + match exp.pexp_desc with + | Pexp_constant const -> report_literal_type_constraint const diff + | Pexp_apply _ -> report_partial_application diff + | _ -> [] + end + | None -> [] + +let report_pattern_type_clash_hints pat diff = + match pat with + | Some (Ppat_constant const) -> report_literal_type_constraint const diff + | _ -> [] + +let report_type_expected_explanation expl = + let because expl_str = doc_printf "@ because it is in %s" expl_str in + match expl with + | If_conditional -> + because "the condition of an if-statement" + | If_no_else_branch -> + because "the result of a conditional with no else branch" + | While_loop_conditional -> + because "the condition of a while-loop" + | While_loop_body -> + because "the body of a while-loop" + | For_loop_start_index -> + because "a for-loop start index" + | For_loop_stop_index -> + because "a for-loop stop index" + | For_loop_body -> + because "the body of a for-loop" + | Assert_condition -> + because "the condition of an assertion" + | Sequence_left_hand_side -> + because "the left-hand side of a sequence" + | When_guard -> + because "a when-guard" + +let report_type_expected_explanation_opt expl = + match expl with + | None -> Format_doc.Doc.empty + | Some expl -> report_type_expected_explanation expl + +let report_unification_error ~loc ?sub env err + ?type_expected_explanation txt1 txt2 = + Location.error_of_printer ~loc ?sub (fun ppf () -> + Errortrace_report.unification ppf env err + ?type_expected_explanation txt1 txt2 + ) () + +let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc = + let open Location in + let cnum_offset off (pos : Lexing.position) = + { pos with pos_cnum = pos.pos_cnum + off } + in + let app_loc = + (* Span the application, including the extra argument. *) + { loc_start = loc.loc_start; + loc_end = extra_arg_loc.loc_end; + loc_ghost = false } + and tail_loc = + (* Possible location for a ';'. The location is widened to overlap the end + of the argument. *) + let arg_end = previous_arg_loc.loc_end in + { loc_start = cnum_offset ~-1 arg_end; + loc_end = cnum_offset ~+1 arg_end; + loc_ghost = false } + in + let hint_semicolon = if returns_unit then [ + msg ~loc:tail_loc "@{Hint@}: Did you forget a ';'?"; + ] else [] in + let sub = hint_semicolon @ [ + msg ~loc:extra_arg_loc "This extra argument is not expected."; + ] in + errorf ~loc:app_loc ~sub + "@[@[<2>%a@ %a@]\ + @ It is applied to too many arguments@]" + (report_this_texp_has_type (Some "function")) funct + Printtyp.type_expr func_ty + +let msg = Fmt.doc_printf + +let report_error ~loc env = function + | Constructor_arity_mismatch(lid, expected, provided) -> + Location.errorf ~loc + "@[The constructor %a@ expects %i argument(s),@ \ + but is applied here to %i argument(s)@]" + (Style.as_inline_code longident) lid expected provided + | Label_mismatch(lid, err) -> + report_unification_error ~loc env err + (msg "The record field %a@ belongs to the type" + (Style.as_inline_code longident) lid) + (msg "but is mixed here with fields of type") + | Pattern_type_clash (err, pat) -> + let diff = type_clash_of_trace err.trace in + let sub = report_pattern_type_clash_hints pat diff in + report_unification_error ~loc ~sub env err + (msg "This pattern matches values of type") + (msg "but a pattern was expected which matches values of type"); + | Or_pattern_type_clash (id, err) -> + report_unification_error ~loc env err + (msg "The variable %a on the left-hand side of this \ + or-pattern has type" Style.inline_code (Ident.name id)) + (msg "but on the right-hand side it has type") + | Multiply_bound_variable name -> + Location.errorf ~loc + "Variable %a is bound several times in this matching" + Style.inline_code name + | Orpat_vars (id, valid_idents) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf + "Variable %a must occur on both sides of this %a pattern" + Style.inline_code (Ident.name id) + Style.inline_code "|" + ; + spellcheck_idents ppf id valid_idents + ) () + | Expr_type_clash (err, explanation, exp) -> + let diff = type_clash_of_trace err.trace in + let sub = report_expr_type_clash_hints exp diff in + report_unification_error ~loc ~sub env err + ~type_expected_explanation: + (report_type_expected_explanation_opt explanation) + (msg "%a" (report_this_pexp_has_type None) exp) + (msg "but an expression was expected of type"); + | Function_arity_type_clash { + syntactic_arity; type_constraint; trace = { trace }; + } -> + (* The last diff's expected type will be the locally-abstract type + that the GADT pattern introduced an equation on. + *) + let type_with_local_equation = + let last_diff = + List.find_map + (function Errortrace.Diff diff -> Some diff | _ -> None) + (List.rev trace) + in + match last_diff with + | None -> None + | Some diff -> Some diff.expected.ty + in + (* [syntactic_arity>1] for this error, so "arguments" is always plural. *) + Location.errorf ~loc + "@[\ + @[\ + The syntactic arity of the function doesn't match the type constraint:@ \ + @[<2>\ + This function has %d syntactic arguments, but its type is constrained \ + to@ %a.\ + @]@ \ + @]@ \ + @[\ + @[<2>@{Hint@}: \ + consider splitting the function definition into@ %a@ \ + where %a is the pattern with the GADT constructor that@ \ + introduces the local type equation%t.\ + @]" + syntactic_arity + (Style.as_inline_code Printtyp.type_expr) type_constraint + Style.inline_code "fun ... gadt_pat -> fun ..." + Style.inline_code "gadt_pat" + (fun ppf -> + Option.iter + (fprintf ppf " on %a" (Style.as_inline_code Printtyp.type_expr)) + type_with_local_equation) + | Apply_non_function { + funct; func_ty; res_ty; previous_arg_loc; extra_arg_loc + } -> + begin match get_desc func_ty with + Tarrow _ -> + let returns_unit = match get_desc res_ty with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + in + report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc + | _ -> + Location.errorf ~loc "@[@[<2>This expression has type@ %a@]@ %s@]" + (Style.as_inline_code Printtyp.type_expr) func_ty + "This is not a function; it cannot be applied." + end + | Apply_wrong_label (l, ty, extra_info) -> + let print_label ppf = function + | Nolabel -> fprintf ppf "without label" + | l -> + fprintf ppf "with label %a" + Style.inline_code (prefixed_label_name l) + in + let extra_info = + if not extra_info then + [] + else + [ Location.msg + "Since OCaml 4.11, optional arguments do not commute when \ + -nolabels is given" ] + in + Location.errorf ~loc ~sub:extra_info + "@[@[<2>The function applied to this argument has type@ %a@]@.\ + This argument cannot be applied %a@]" + Printtyp.type_expr ty print_label l + | Label_multiply_defined s -> + Location.errorf ~loc "The record field label %s is defined several times" + s + | Label_missing labels -> + let print_label ppf lbl = Style.inline_code ppf (Ident.name lbl) in + let print_labels ppf = List.iter (fprintf ppf "@ %a" print_label) in + Location.errorf ~loc "@[Some record fields are undefined:%a@]" + print_labels labels + | Label_not_mutable lid -> + Location.errorf ~loc "The record field %a is not mutable" + (Style.as_inline_code longident) lid + | Wrong_name (eorp, ty_expected, { type_path; kind; name; valid_names; }) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + let { ty; explanation } = ty_expected in + if Path.is_constructor_typath type_path then begin + fprintf ppf + "@[The field %a is not part of the record \ + argument for the %a constructor@]" + Style.inline_code name.txt + (Style.as_inline_code Printtyp.type_path) type_path; + end else begin + fprintf ppf + "@[@[<2>%s type@ %a%a@]@ \ + There is no %s %a within type %a@]" + eorp (Style.as_inline_code Printtyp.type_expr) ty + pp_doc (report_type_expected_explanation_opt explanation) + (Datatype_kind.label_name kind) + Style.inline_code name.txt + (Style.as_inline_code Printtyp.type_path) type_path; + end; + spellcheck ppf name.txt valid_names + )) () + | Name_type_mismatch (kind, lid, tp, tpl) -> + let type_name = Datatype_kind.type_name kind in + let name = Datatype_kind.label_name kind in + Location.error_of_printer ~loc (fun ppf () -> + Errortrace_report.ambiguous_type ppf env tp tpl + (msg "The %s %a@ belongs to the %s type" + name (Style.as_inline_code longident) lid + type_name) + (msg "The %s %a@ belongs to one of the following %s types:" + name (Style.as_inline_code longident) lid type_name) + (msg "but a %s was expected belonging to the %s type" + name type_name) + ) () + | Invalid_format msg -> + Location.errorf ~loc "%s" msg + | Not_an_object (ty, explanation) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression is not an object;@ \ + it has type %a" + (Style.as_inline_code Printtyp.type_expr) ty; + pp_doc ppf @@ report_type_expected_explanation_opt explanation + ) () + | Undefined_method (ty, me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + fprintf ppf + "@[@[This expression has type@;<1 2>%a@]@,\ + It has no method %a@]" + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code me; + begin match valid_methods with + | None -> () + | Some valid_methods -> spellcheck ppf me valid_methods + end + )) () + | Undefined_self_method (me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression has no method %a" Style.inline_code me; + spellcheck ppf me valid_methods; + ) () + | Virtual_class cl -> + Location.errorf ~loc "Cannot instantiate the virtual class %a" + (Style.as_inline_code longident) cl + | Unbound_instance_variable (var, valid_vars) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "Unbound instance variable %a" Style.inline_code var; + spellcheck ppf var valid_vars; + ) () + | Instance_variable_not_mutable v -> + Location.errorf ~loc "The instance variable %a is not mutable" + Style.inline_code v + | Not_subtype err -> + Location.error_of_printer ~loc (fun ppf () -> + Errortrace_report.subtype ppf env err "is not a subtype of" + ) () + | Outside_class -> + Location.errorf ~loc + "This object duplication occurs outside a method definition" + | Value_multiply_overridden v -> + Location.errorf ~loc + "The instance variable %a is overridden several times" + Style.inline_code v + | Coercion_failure (ty_exp, err, b) -> + Location.error_of_printer ~loc (fun ppf () -> + let intro = + let ty_exp = Out_type.prepare_expansion ty_exp in + doc_printf "This expression cannot be coerced to type@;<1 2>%a;@ \ + it has type" + (Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp + in + Errortrace_report.unification ppf env err + intro + (Fmt.doc_printf "but is here used with type"); + if b then + fprintf ppf + ".@.@[This simple coercion was not fully general.@ \ + @{Hint@}: Consider using a fully explicit coercion@ \ + of the form: %a@]" + Style.inline_code "(foo : ty1 :> ty2)" + ) () + | Not_a_function (ty, explanation) -> + Location.errorf ~loc + "This expression should not be a function,@ \ + the expected type is@ %a%a" + (Style.as_inline_code Printtyp.type_expr) ty + pp_doc (report_type_expected_explanation_opt explanation) + | Too_many_arguments (ty, explanation) -> + Location.errorf ~loc + "This function expects too many arguments,@ \ + it should have type@ %a%a" + (Style.as_inline_code Printtyp.type_expr) ty + pp_doc (report_type_expected_explanation_opt explanation) + | Abstract_wrong_label {got; expected; expected_type; explanation} -> + let label ~long ppf = function + | Nolabel -> fprintf ppf "unlabeled" + | l -> + if long then + fprintf ppf "labeled %a" Style.inline_code (prefixed_label_name l) + else + Style.inline_code ppf (prefixed_label_name l) + in + let second_long = match got, expected with + | Nolabel, _ | _, Nolabel -> true + | _ -> false + in + Location.errorf ~loc + "@[@[<2>This function should have type@ %a%a@]@,\ + @[but its first argument is %a@ instead of %s%a@]@]" + (Style.as_inline_code Printtyp.type_expr) expected_type + pp_doc (report_type_expected_explanation_opt explanation) + (label ~long:true) got + (if second_long then "being " else "") + (label ~long:second_long) expected + | Scoping_let_module(id, ty) -> + Location.errorf ~loc + "This %a expression has type@ %a@ \ + In this type, the locally bound module name %a escapes its scope" + Style.inline_code "let module" + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code id + | Private_type ty -> + Location.errorf ~loc "Cannot create values of the private type %a" + (Style.as_inline_code Printtyp.type_expr) ty + | Private_label (lid, ty) -> + Location.errorf ~loc "Cannot assign field %a of the private type %a" + (Style.as_inline_code longident) lid + (Style.as_inline_code Printtyp.type_expr) ty + | Private_constructor (constr, ty) -> + Location.errorf ~loc + "Cannot use private constructor %a to create values of type %a" + Style.inline_code constr.cstr_name + (Style.as_inline_code Printtyp.type_expr) ty + | Not_a_polymorphic_variant_type lid -> + Location.errorf ~loc "The type %a@ is not a variant type" + (Style.as_inline_code longident) lid + | Incoherent_label_order -> + Location.errorf ~loc + "This function is applied to arguments@ \ + in an order different from other calls.@ \ + This is only allowed when the real type is known." + | Less_general (kind, err) -> + report_unification_error ~loc env err + (Fmt.doc_printf "This %s has type" kind) + (Fmt.doc_printf "which is less general than") + | Modules_not_allowed -> + Location.errorf ~loc "Modules are not allowed in this pattern." + | Cannot_infer_signature -> + Location.errorf ~loc + "The signature for this packaged module couldn't be inferred." + | Not_a_packed_module ty -> + Location.errorf ~loc + "This expression is packed module, but the expected type is@ %a" + (Style.as_inline_code Printtyp.type_expr) ty + | Unexpected_existential (reason, name) -> + let reason_str = + match reason with + | In_class_args -> + dprintf "Existential types are not allowed in class arguments" + | In_class_def -> + dprintf "Existential types are not allowed in bindings inside \ + class definition" + | In_self_pattern -> + dprintf "Existential types are not allowed in self patterns" + | At_toplevel -> + dprintf "Existential types are not allowed in toplevel bindings" + | In_group -> + dprintf "Existential types are not allowed in %a bindings" + Style.inline_code "let ... and ..." + | In_rec -> + dprintf "Existential types are not allowed in recursive bindings" + | With_attributes -> + dprintf + "Existential types are not allowed in presence of attributes" + in + Location.errorf ~loc + "%t,@ but the constructor %a introduces existential types." + reason_str Style.inline_code name + | Invalid_interval -> + Location.errorf ~loc + "@[Only character intervals are supported in patterns.@]" + | Invalid_for_loop_index -> + Location.errorf ~loc + "@[Invalid for-loop index: only variables and %a are allowed.@]" + Style.inline_code "_" + | No_value_clauses -> + Location.errorf ~loc + "None of the patterns in this %a expression match values." + Style.inline_code "match" + | Exception_pattern_disallowed -> + Location.errorf ~loc + "@[Exception patterns are not allowed in this position.@]" + | Mixed_value_and_exception_patterns_under_guard -> + Location.errorf ~loc + "@[Mixing value and exception patterns under when-guards is not \ + supported.@]" + | Effect_pattern_below_toplevel -> + Location.errorf ~loc + "@[Effect patterns must be at the top level of a match case.@]" + | Invalid_continuation_pattern -> + Location.errorf ~loc + "@[Invalid continuation pattern: only variables and _ are allowed .@]" + | Inlined_record_escape -> + Location.errorf ~loc + "@[This form is not allowed as the type of the inlined record could \ + escape.@]" + | Inlined_record_expected -> + Location.errorf ~loc + "@[This constructor expects an inlined record argument.@]" + | Unrefuted_pattern pat -> + Location.errorf ~loc + "@[%s@ %s@ @[%a@]@]" + "This match case could not be refuted." + "Here is an example of a value that would reach it:" + (Style.as_inline_code Printpat.top_pretty) pat + | Invalid_extension_constructor_payload -> + Location.errorf ~loc + "Invalid %a payload, a constructor is expected." + Style.inline_code "[%extension_constructor]" + | Not_an_extension_constructor -> + Location.errorf ~loc + "This constructor is not an extension constructor." + | Literal_overflow ty -> + Location.errorf ~loc + "Integer literal exceeds the range of representable integers of type %a" + Style.inline_code ty + | Unknown_literal (n, m) -> + let pp_lit ppf (n,m) = fprintf ppf "%s%c" n m in + Location.errorf ~loc "Unknown modifier %a for literal %a" + (Style.as_inline_code pp_print_char) m + (Style.as_inline_code pp_lit) (n,m) + | Illegal_letrec_pat -> + Location.errorf ~loc + "Only variables are allowed as left-hand side of %a" + Style.inline_code "let rec" + | Illegal_letrec_expr -> + Location.errorf ~loc + "This kind of expression is not allowed as right-hand side of %a" + Style.inline_code "let rec" + | Illegal_class_expr -> + Location.errorf ~loc + "This kind of recursive class expression is not allowed" + | Letop_type_clash(name, err) -> + report_unification_error ~loc env err + (msg "The operator %a has type" Style.inline_code name) + (msg "but it was expected to have type") + | Andop_type_clash(name, err) -> + report_unification_error ~loc env err + (msg "The operator %a has type" Style.inline_code name) + (msg "but it was expected to have type") + | Bindings_type_clash(err) -> + report_unification_error ~loc env err + (Fmt.doc_printf "These bindings have type") + (Fmt.doc_printf "but bindings were expected of type") + | Unbound_existential (ids, ty) -> + let pp_ident ppf id = pp_print_string ppf (Ident.name id) in + let pp_type ppf (ids,ty)= + fprintf ppf "@[type %a.@ %a@]@]" + (pp_print_list ~pp_sep:pp_print_space pp_ident) ids + Printtyp.type_expr ty + in + Location.errorf ~loc + "@[<2>%s:@ %a@]" + "This type does not bind all existentials in the constructor" + (Style.as_inline_code pp_type) (ids, ty) + | Bind_existential (reason, id, ty) -> + let reason1, reason2 = match reason with + | Bind_already_bound -> "the name", "that is already bound" + | Bind_not_in_scope -> "the name", "that was defined before" + | Bind_non_locally_abstract -> "the type", + "that is not a locally abstract type" + in + Location.errorf ~loc + "@[The local name@ %a@ %s@ %s.@ %s@ %s@ %a@ %s.@]" + (Style.as_inline_code Printtyp.ident) id + "can only be given to an existential variable" + "introduced by this GADT constructor" + "The type annotation tries to bind it to" + reason1 (Style.as_inline_code Printtyp.type_expr) ty reason2 + | Missing_type_constraint -> + Location.errorf ~loc + "@[%s@ %s@]" + "Existential types introduced in a constructor pattern" + "must be bound by a type constraint on the argument." + | Wrong_expected_kind(sort, ctx, ty) -> + let ctx, explanation = + match ctx with + | Expression explanation -> "expression", explanation + | Pattern -> "pattern", None + in + let sort = + match sort with + | Constructor -> "constructor" + | Boolean -> "boolean literal" + | List -> "list literal" + | Unit -> "unit literal" + | Record -> "record" + in + Location.errorf ~loc + "This %s should not be a %s,@ \ + the expected type is@ %a%a" + ctx sort (Style.as_inline_code Printtyp.type_expr) ty + pp_doc (report_type_expected_explanation_opt explanation) + | Expr_not_a_record_type ty -> + Location.errorf ~loc + "This expression has type %a@ \ + which is not a record type." + (Style.as_inline_code Printtyp.type_expr) ty + +let report_error ~loc env err = + Printtyp.wrap_printing_env ~error:true env + (fun () -> report_error ~loc env err) + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (report_error ~loc env err) + | Error_forward err -> + Some err + | _ -> + None + ) + +let () = + Persistent_env.add_delayed_check_forward := add_delayed_check; + Env.add_delayed_check_forward := add_delayed_check; + () + +(* drop the need to call [Parmatch.typed_case] from the external API *) +let check_partial ?lev a b c cases = + check_partial ?lev a b c (List.map Parmatch.typed_case cases) + +(* drop ?recarg argument from the external API *) +let type_expect env e ty = type_expect env e ty +let type_exp env e = type_exp env e +let type_argument env e t1 t2 = type_argument env e t1 t2 diff --git a/upstream/ocaml_503/typing/typecore.mli b/upstream/ocaml_503/typing/typecore.mli new file mode 100644 index 000000000..1b89ddd68 --- /dev/null +++ b/upstream/ocaml_503/typing/typecore.mli @@ -0,0 +1,275 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Type inference for the core language *) + +open Asttypes +open Types + +(* This variant is used to print improved error messages, and does not affect + the behavior of the typechecker itself. + + It describes possible explanation for types enforced by a keyword of the + language; e.g. "if" requires the condition to be of type bool, and the + then-branch to be of type unit if there is no else branch; "for" requires + indices to be of type int, and the body to be of type unit. +*) +type type_forcing_context = + | If_conditional + | If_no_else_branch + | While_loop_conditional + | While_loop_body + | For_loop_start_index + | For_loop_stop_index + | For_loop_body + | Assert_condition + | Sequence_left_hand_side + | When_guard + +(* The combination of a type and a "type forcing context". The intent is that it + describes a type that is "expected" (required) by the context. If unifying + with such a type fails, then the "explanation" field explains why it was + required, in order to display a more enlightening error message. +*) +type type_expected = private { + ty: type_expr; + explanation: type_forcing_context option; +} + +(* Variables in patterns *) +type pattern_variable_kind = + | Std_var + | As_var + | Continuation_var + +type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_kind: pattern_variable_kind; + pv_attributes: Typedtree.attributes; + pv_uid : Uid.t; + } + +val mk_expected: + ?explanation:type_forcing_context -> + type_expr -> + type_expected + +val is_nonexpansive: Typedtree.expression -> bool + +module Datatype_kind : sig + type t = Record | Variant + val type_name : t -> string + val label_name : t -> string +end + +type wrong_name = { + type_path: Path.t; + kind: Datatype_kind.t; + name: string loc; + valid_names: string list; +} + +type wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +type existential_restriction = + | At_toplevel (** no existential types at the toplevel *) + | In_group (** nor with [let ... and ...] *) + | In_rec (** or recursive definition *) + | With_attributes (** or [let[@any_attribute] = ...] *) + | In_class_args (** or in class arguments [class c (...) = ...] *) + | In_class_def (** or in [class c = let ... in ...] *) + | In_self_pattern (** or in self pattern *) + +val type_binding: + Env.t -> rec_flag -> + Parsetree.value_binding list -> + Typedtree.value_binding list * Env.t +val type_let: + existential_restriction -> Env.t -> rec_flag -> + Parsetree.value_binding list -> + Typedtree.value_binding list * Env.t +val type_expression: + Env.t -> Parsetree.expression -> Typedtree.expression +val type_class_arg_pattern: + string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern -> + Typedtree.pattern * + (Ident.t * Ident.t * type_expr) list * + Env.t * Env.t +val type_self_pattern: + Env.t -> Parsetree.pattern -> + Typedtree.pattern * pattern_variable list +val check_partial: + ?lev:int -> Env.t -> type_expr -> + Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial +val type_expect: + Env.t -> Parsetree.expression -> type_expected -> Typedtree.expression +val type_exp: + Env.t -> Parsetree.expression -> Typedtree.expression +val type_approx: + Env.t -> Parsetree.expression -> type_expr +val type_argument: + Env.t -> Parsetree.expression -> + type_expr -> type_expr -> Typedtree.expression + +val option_some: Env.t -> Typedtree.expression -> Typedtree.expression +val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression +val extract_option_type: Env.t -> type_expr -> type_expr +val generalizable: int -> type_expr -> bool +val reset_delayed_checks: unit -> unit +val force_delayed_checks: unit -> unit + +val name_pattern : string -> Typedtree.pattern list -> Ident.t +val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t + +val self_coercion : (Path.t * Location.t list ref) list ref + +type existential_binding = + | Bind_already_bound + | Bind_not_in_scope + | Bind_non_locally_abstract + +type error = + | Constructor_arity_mismatch of Longident.t * int * int + | Label_mismatch of Longident.t * Errortrace.unification_error + | Pattern_type_clash : + Errortrace.unification_error * Parsetree.pattern_desc option + -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option + * Parsetree.expression option + | Function_arity_type_clash of + { syntactic_arity : int; + type_constraint : type_expr; + trace : Errortrace.unification_error; + } + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } + | Apply_wrong_label of arg_label * type_expr * bool + | Label_multiply_defined of string + | Label_missing of Ident.t list + | Label_not_mutable of Longident.t + | Wrong_name of string * type_expected * wrong_name + | Name_type_mismatch of + Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list + | Invalid_format of string + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_method of string * string list + | Virtual_class of Longident.t + | Private_type of type_expr + | Private_label of Longident.t * type_expr + | Private_constructor of constructor_description * type_expr + | Unbound_instance_variable of string * string list + | Instance_variable_not_mutable of string + | Not_subtype of Errortrace.Subtype.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | Modules_not_allowed + | Cannot_infer_signature + | Not_a_packed_module of type_expr + | Unexpected_existential of existential_restriction * string + | Invalid_interval + | Invalid_for_loop_index + | No_value_clauses + | Exception_pattern_disallowed + | Mixed_value_and_exception_patterns_under_guard + | Effect_pattern_below_toplevel + | Invalid_continuation_pattern + | Inlined_record_escape + | Inlined_record_expected + | Unrefuted_pattern of Typedtree.pattern + | Invalid_extension_constructor_payload + | Not_an_extension_constructor + | Literal_overflow of string + | Unknown_literal of string * char + | Illegal_letrec_pat + | Illegal_letrec_expr + | Illegal_class_expr + | Letop_type_clash of string * Errortrace.unification_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Bind_existential of existential_binding * Ident.t * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +val report_error: loc:Location.t -> Env.t -> error -> Location.error + (** @deprecated. Use {!Location.error_of_exn}, {!Location.print_report}. *) + +(* Forward declaration, to be filled in by Typemod.type_module *) +val type_module: + (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) ref +(* Forward declaration, to be filled in by Typemod.type_open *) +val type_open: + (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> + Longident.t loc -> Path.t * Env.t) + ref +(* Forward declaration, to be filled in by Typemod.type_open_decl *) +val type_open_decl: + (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration -> + Typedtree.open_declaration * Types.signature * Env.t) + ref +(* Forward declaration, to be filled in by Typeclass.class_structure *) +val type_object: + (Env.t -> Location.t -> Parsetree.class_structure -> + Typedtree.class_structure * string list) ref +val type_package: + (Env.t -> Parsetree.module_expr -> Path.t -> (Longident.t * type_expr) list -> + Typedtree.module_expr * (Longident.t * type_expr) list) ref + +val constant: Parsetree.constant -> (Asttypes.constant, error) result + +val annotate_recursive_bindings : + Env.t -> Typedtree.value_binding list -> Typedtree.value_binding list +val check_recursive_class_bindings : + Env.t -> Ident.t list -> Typedtree.class_expr list -> unit diff --git a/upstream/ocaml_503/typing/typedecl.ml b/upstream/ocaml_503/typing/typedecl.ml new file mode 100644 index 000000000..cbde24b40 --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl.ml @@ -0,0 +1,2270 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(**** Typing of type definitions ****) + +open Misc +open Asttypes +open Parsetree +open Primitive +open Types +open Typetexp + +module String = Misc.Stdlib.String + +type native_repr_kind = Unboxed | Untagged + +(* Our static analyses explore the set of type expressions "reachable" + from a type declaration, by expansion of definitions or by the + subterm relation (a type expression is syntactically contained + in another). *) +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + +type error = + Repeated_parameter + | Duplicate_constructor of string + | Too_many_constructors + | Duplicate_label of string + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | Non_regular of { + definition: Path.t; + used_as: type_expr; + defined_as: type_expr; + reaching_path: reaching_type_path; + } + | Null_arity_external + | Missing_native_external + | Unbound_type_var of type_expr * type_declaration + | Cannot_extend_private_type of Path.t + | Not_extensible_type of Path.t + | Extension_mismatch of Path.t * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | Rebind_mismatch of Longident.t * Path.t * Path.t + | Rebind_private of Longident.t + | Variance of Typedecl_variance.error + | Unavailable_type_constructor of Path.t + | Unbound_type_var_ext of type_expr * extension_constructor + | Val_in_structure + | Multiple_native_repr_attributes + | Cannot_unbox_or_untag_type of native_repr_kind + | Deep_unbox_or_untag_attribute of native_repr_kind + | Immediacy of Typedecl_immediacy.error + | Separability of Typedecl_separability.error + | Bad_unboxed_attribute of string + | Boxed_and_unboxed + | Nonrec_gadt + | Invalid_private_row_declaration of type_expr + +open Typedtree + +exception Error of Location.t * error + +let get_unboxed_from_attributes sdecl = + let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in + let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in + match boxed, unboxed with + | true, true -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed)) + | true, false -> Some false + | false, true -> Some true + | false, false -> None + +(* Enter all declared types in the environment as abstract types *) + +let add_type ~check ?shape id decl env = + Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes + (fun () -> Env.add_type ~check ?shape id decl env) + +(* Add a dummy type declaration to the environment, with the given arity. + The [type_kind] is [Type_abstract], but there is a generic [type_manifest] + for abbreviations, to allow polymorphic expansion, except if + [abstract_abbrevs] is given along with a reason for not allowing expansion. + This function is only used in [transl_type_decl]. *) +let enter_type ?abstract_abbrevs rec_flag env sdecl (id, uid) = + let needed = + match rec_flag with + | Asttypes.Nonrecursive -> + begin match sdecl.ptype_kind with + | Ptype_variant scds -> + List.iter (fun cd -> + if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt))) + scds + | _ -> () + end; + Btype.is_row_name (Ident.name id) + | Asttypes.Recursive -> true + in + let arity = List.length sdecl.ptype_params in + if not needed then env else + let abstract_source, type_manifest = + match sdecl.ptype_manifest, abstract_abbrevs with + | None, _ -> Definition, None + | Some _, None -> Definition, Some (Btype.newgenvar ()) + | Some _, Some reason -> reason, None + in + let decl = + { type_params = + List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; + type_arity = arity; + type_kind = Type_abstract abstract_source; + type_private = sdecl.ptype_private; + type_manifest = type_manifest; + type_variance = Variance.unknown_signature ~injective:false ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = uid; + } + in + add_type ~check:true id decl env + +(* Determine if a type's values are represented by floats at run-time. *) +let is_float env ty = + match Typedecl_unboxed.get_unboxed_type_representation env ty with + Some ty' -> + begin match get_desc ty' with + Tconstr(p, _, _) -> Path.same p Predef.path_float + | _ -> false + end + | _ -> false + +(* Determine if a type definition defines a fixed type. (PW) *) +let is_fixed_type sd = + let rec has_row_var sty = + match sty.ptyp_desc with + Ptyp_alias (sty, _) -> has_row_var sty + | Ptyp_class _ + | Ptyp_object (_, Open) + | Ptyp_variant (_, Open, _) + | Ptyp_variant (_, Closed, Some _) -> true + | _ -> false + in + match sd.ptype_manifest with + None -> false + | Some sty -> + sd.ptype_kind = Ptype_abstract && + sd.ptype_private = Private && + has_row_var sty + +(* Set the row variable to a fixed type in a private row type declaration. + (e.g. [ type t = private [< `A | `B ] ] or [type u = private < .. > ]) + Require [is_fixed_type decl] as a precondition +*) +let set_private_row env loc p decl = + let tm = + match decl.type_manifest with + None -> assert false + | Some t -> Ctype.expand_head env t + in + let rv = + match get_desc tm with + Tvariant row -> + let Row {fields; more; closed; name} = row_repr row in + set_type_desc tm + (Tvariant (create_row ~fields ~more ~closed ~name + ~fixed:(Some Fixed_private))); + if Btype.static_row row then + (* the syntax hinted at the existence of a row variable, + but there is in fact no row variable to make private, e.g. + [ type t = private [< `A > `A] ] *) + raise (Error(loc, Invalid_private_row_declaration tm)) + else more + | Tobject (ty, _) -> + let r = snd (Ctype.flatten_fields ty) in + if not (Btype.is_Tvar r) then + (* a syntactically open object was closed by a constraint *) + raise (Error(loc, Invalid_private_row_declaration tm)); + r + | _ -> assert false + in + set_type_desc rv (Tconstr (p, decl.type_params, ref Mnil)) + +(* Translate one type declaration *) + +let make_params env params = + let make_param (sty, v) = + try + (transl_type_param env sty, v) + with Already_bound -> + raise(Error(sty.ptyp_loc, Repeated_parameter)) + in + List.map make_param params + +let transl_labels env univars closed lbls = + assert (lbls <> []); + let all_labels = ref String.Set.empty in + List.iter + (fun {pld_name = {txt=name; loc}} -> + if String.Set.mem name !all_labels then + raise(Error(loc, Duplicate_label name)); + all_labels := String.Set.add name !all_labels) + lbls; + let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc; + pld_attributes=attrs} = + Builtin_attributes.warning_scope attrs + (fun () -> + let arg = Ast_helper.Typ.force_poly arg in + let cty = transl_simple_type env ?univars ~closed arg in + {ld_id = Ident.create_local name.txt; + ld_name = name; + ld_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + ld_mutable = mut; + ld_type = cty; ld_loc = loc; ld_attributes = attrs} + ) + in + let lbls = List.map mk lbls in + let lbls' = + List.map + (fun ld -> + let ty = ld.ld_type.ctyp_type in + let ty = match get_desc ty with Tpoly(t,[]) -> t | _ -> ty in + {Types.ld_id = ld.ld_id; + ld_mutable = ld.ld_mutable; + ld_type = ty; + ld_loc = ld.ld_loc; + ld_attributes = ld.ld_attributes; + ld_uid = ld.ld_uid; + } + ) + lbls in + lbls, lbls' + +let transl_constructor_arguments env univars closed = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env ?univars ~closed) l in + Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), + Cstr_tuple l + | Pcstr_record l -> + let lbls, lbls' = transl_labels env univars closed l in + Types.Cstr_record lbls', + Cstr_record lbls + +let make_constructor env loc type_path type_params svars sargs sret_type = + match sret_type with + | None -> + let args, targs = + transl_constructor_arguments env None true sargs + in + targs, None, args, None + | Some sret_type -> + (* if it's a generalized constructor we must first narrow and + then widen so as to not introduce any new constraints *) + (* narrow and widen are now invoked through wrap_type_variable_scope *) + TyVarEnv.with_local_scope begin fun () -> + let closed = svars <> [] in + let targs, tret_type, args, ret_type, univars = + Ctype.with_local_level_generalize_if closed begin fun () -> + TyVarEnv.reset (); + let univar_list = + TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) svars) in + let univars = if closed then Some univar_list else None in + let args, targs = + transl_constructor_arguments env univars closed sargs + in + let tret_type = + transl_simple_type env ?univars ~closed sret_type in + let ret_type = tret_type.ctyp_type in + (* TODO add back type_path as a parameter ? *) + begin match get_desc ret_type with + | Tconstr (p', _, _) when Path.same type_path p' -> () + | _ -> + let trace = + (* Expansion is not helpful here -- the restriction on GADT + return types is purely syntactic. (In the worst case, + expansion produces gibberish.) *) + [Ctype.unexpanded_diff + ~got:ret_type + ~expected:(Ctype.newconstr type_path type_params)] + in + raise (Error(sret_type.ptyp_loc, + Constraint_failed( + env, Errortrace.unification_error ~trace))) + end; + (targs, tret_type, args, ret_type, univar_list) + end + in + if closed then begin + ignore (TyVarEnv.instance_poly_univars env loc univars); + let set_level t = Ctype.enforce_current_level env t in + Btype.iter_type_expr_cstr_args set_level args; + set_level ret_type + end; + targs, Some tret_type, args, Some ret_type + end + + +let shape_map_labels = + List.fold_left (fun map { ld_id; ld_uid; _} -> + Shape.Map.add_label map ld_id ld_uid) + Shape.Map.empty + +let shape_map_cstrs = + List.fold_left (fun map { cd_id; cd_uid; cd_args; _ } -> + let cstr_shape_map = + let label_decls = + match cd_args with + | Cstr_tuple _ -> [] + | Cstr_record ldecls -> ldecls + in + shape_map_labels label_decls + in + Shape.Map.add_constr map cd_id + @@ Shape.str ~uid:cd_uid cstr_shape_map) + (Shape.Map.empty) + + +let transl_declaration env sdecl (id, uid) = + (* Bind type parameters *) + TyVarEnv.reset(); + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in + let cstrs = List.map + (fun (sty, sty', loc) -> + transl_simple_type env ~closed:false sty, + transl_simple_type env ~closed:false sty', loc) + sdecl.ptype_cstrs + in + let unboxed_attr = get_unboxed_from_attributes sdecl in + begin match unboxed_attr with + | (None | Some false) -> () + | Some true -> + let bad msg = raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute msg)) in + match sdecl.ptype_kind with + | Ptype_abstract -> bad "it is abstract" + | Ptype_open -> bad "extensible variant types cannot be unboxed" + | Ptype_record fields -> begin match fields with + | [] -> bad "it has no fields" + | _::_::_ -> bad "it has more than one field" + | [{pld_mutable = Mutable}] -> bad "it is mutable" + | [{pld_mutable = Immutable}] -> () + end + | Ptype_variant constructors -> begin match constructors with + | [] -> bad "it has no constructor" + | (_::_::_) -> bad "it has more than one constructor" + | [c] -> begin match c.pcd_args with + | Pcstr_tuple [] -> + bad "its constructor has no argument" + | Pcstr_tuple (_::_::_) -> + bad "its constructor has more than one argument" + | Pcstr_tuple [_] -> + () + | Pcstr_record [] -> + bad "its constructor has no fields" + | Pcstr_record (_::_::_) -> + bad "its constructor has more than one field" + | Pcstr_record [{pld_mutable = Mutable}] -> + bad "it is mutable" + | Pcstr_record [{pld_mutable = Immutable}] -> + () + end + end + end; + let unbox, unboxed_default = + match sdecl.ptype_kind with + | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] + | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]; _}] + | Ptype_record [{pld_mutable=Immutable; _}] -> + Option.value unboxed_attr ~default:!Clflags.unboxed_types, + Option.is_none unboxed_attr + | _ -> false, false (* Not unboxable, mark as boxed *) + in + let (tkind, kind) = + match sdecl.ptype_kind with + | Ptype_abstract -> Ttype_abstract, Type_abstract Definition + | Ptype_variant scstrs -> + if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin + match cstrs with + [] -> () + | (_,_,loc)::_ -> + Location.prerr_warning loc Warnings.Constraint_on_gadt + end; + let all_constrs = ref String.Set.empty in + List.iter + (fun {pcd_name = {txt = name}} -> + if String.Set.mem name !all_constrs then + raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); + all_constrs := String.Set.add name !all_constrs) + scstrs; + if List.length + (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs) + > (Config.max_tag + 1) then + raise(Error(sdecl.ptype_loc, Too_many_constructors)); + let make_cstr scstr = + let name = Ident.create_local scstr.pcd_name.txt in + let targs, tret_type, args, ret_type = + make_constructor env scstr.pcd_loc (Path.Pident id) params + scstr.pcd_vars scstr.pcd_args scstr.pcd_res + in + let tcstr = + { cd_id = name; + cd_name = scstr.pcd_name; + cd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + cd_vars = scstr.pcd_vars; + cd_args = targs; + cd_res = tret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = scstr.pcd_attributes } + in + let cstr = + { Types.cd_id = name; + cd_args = args; + cd_res = ret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = scstr.pcd_attributes; + cd_uid = tcstr.cd_uid } + in + tcstr, cstr + in + let make_cstr scstr = + Builtin_attributes.warning_scope scstr.pcd_attributes + (fun () -> make_cstr scstr) + in + let rep = if unbox then Variant_unboxed else Variant_regular in + let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in + Ttype_variant tcstrs, Type_variant (cstrs, rep) + | Ptype_record lbls -> + let lbls, lbls' = transl_labels env None true lbls in + let rep = + if unbox then Record_unboxed false + else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' + then Record_float + else Record_regular + in + Ttype_record lbls, Type_record(lbls', rep) + | Ptype_open -> Ttype_open, Type_open + in + begin + let (tman, man) = match sdecl.ptype_manifest with + None -> None, None + | Some sty -> + let no_row = not (is_fixed_type sdecl) in + let cty = transl_simple_type env ~closed:no_row sty in + Some cty, Some cty.ctyp_type + in + let arity = List.length params in + let decl = + { type_params = params; + type_arity = arity; + type_kind = kind; + type_private = sdecl.ptype_private; + type_manifest = man; + type_variance = Variance.unknown_signature ~injective:false ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = Unknown; + type_unboxed_default = unboxed_default; + type_uid = uid; + } in + + (* Check constraints *) + List.iter + (fun (cty, cty', loc) -> + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + try Ctype.unify env ty ty' with Ctype.Unify err -> + raise(Error(loc, Inconsistent_constraint (env, err)))) + cstrs; + (* Add abstract row *) + if is_fixed_type sdecl then begin + let p, _ = + try Env.find_type_by_name + (Longident.Lident(Ident.name id ^ "#row")) env + with Not_found -> assert false + in + set_private_row env sdecl.ptype_loc p decl + end; + let decl = + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = decl; + typ_cstrs = cstrs; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = tkind; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } + in + let typ_shape = + let uid = decl.typ_type.type_uid in + match decl.typ_kind with + | Ttype_variant cstrs -> Shape.str ~uid (shape_map_cstrs cstrs) + | Ttype_record labels -> Shape.str ~uid (shape_map_labels labels) + | Ttype_abstract | Ttype_open -> Shape.leaf uid + in + decl, typ_shape + end + +(* Check that all constraints are enforced *) + +module TypeSet = Btype.TypeSet +module TypeMap = Btype.TypeMap + +let rec check_constraints_rec env loc visited ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + | Tconstr (path, args, _) -> + let decl = + try Env.find_type path env + with Not_found -> + raise (Error(loc, Unavailable_type_constructor path)) in + let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in + begin + (* We don't expand the error trace because that produces types that + *already* violate the constraints -- we need to report a problem with + the unexpanded types, or we get errors that talk about the same type + twice. This is generally true for constraint errors. *) + try Ctype.matches ~expand_error_trace:false env ty ty' + with Ctype.Matches_failure (env, err) -> + raise (Error(loc, Constraint_failed (env, err))) + end; + List.iter (check_constraints_rec env loc visited) args + | Tpoly (ty, tl) -> + let _, ty = Ctype.instance_poly ~fixed:false tl ty in + check_constraints_rec env loc visited ty + | _ -> + Btype.iter_type_expr (check_constraints_rec env loc visited) ty + end + +let check_constraints_labels env visited l pl = + let rec get_loc name = function + [] -> assert false + | pld :: tl -> + if name = pld.pld_name.txt then pld.pld_type.ptyp_loc + else get_loc name tl + in + List.iter + (fun {Types.ld_id=name; ld_type=ty} -> + check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) + l + +let check_constraints env sdecl (_, decl) = + let visited = ref TypeSet.empty in + List.iter2 + (fun (sty, _) ty -> check_constraints_rec env sty.ptyp_loc visited ty) + sdecl.ptype_params decl.type_params; + begin match decl.type_kind with + | Type_abstract _ -> () + | Type_variant (l, _rep) -> + let find_pl = function + Ptype_variant pl -> pl + | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false + in + let pl = find_pl sdecl.ptype_kind in + let pl_index = + let foldf acc x = + String.Map.add x.pcd_name.txt x acc + in + List.fold_left foldf String.Map.empty pl + in + List.iter + (fun {Types.cd_id=name; cd_args; cd_res} -> + let {pcd_args; pcd_res; _} = + try String.Map.find (Ident.name name) pl_index + with Not_found -> assert false in + begin match cd_args, pcd_args with + | Cstr_tuple tyl, Pcstr_tuple styl -> + List.iter2 + (fun sty ty -> + check_constraints_rec env sty.ptyp_loc visited ty) + styl tyl + | Cstr_record tyl, Pcstr_record styl -> + check_constraints_labels env visited tyl styl + | _ -> assert false + end; + match pcd_res, cd_res with + | Some sr, Some r -> + check_constraints_rec env sr.ptyp_loc visited r + | _ -> + () ) + l + | Type_record (l, _) -> + let find_pl = function + Ptype_record pl -> pl + | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false + in + let pl = find_pl sdecl.ptype_kind in + check_constraints_labels env visited l pl + | Type_open -> () + end; + begin match decl.type_manifest with + | None -> () + | Some ty -> + let sty = + match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false + in + check_constraints_rec env sty.ptyp_loc visited ty + end + +(* + If both a variant/record definition and a type equation are given, + need to check that the equation refers to a type of the same kind + with the same constructors and labels. +*) +let check_coherence env loc dpath decl = + match decl with + { type_kind = (Type_variant _ | Type_record _| Type_open); + type_manifest = Some ty } -> + begin match get_desc ty with + Tconstr(path, args, _) -> + begin try + let decl' = Env.find_type path env in + let err = + if List.length args <> List.length decl.type_params + then Some Includecore.Arity + else begin + match Ctype.equal env false args decl.type_params with + | exception Ctype.Equality err -> + Some (Includecore.Constraint err) + | () -> + Includecore.type_declarations ~loc ~equality:true env + ~mark:true + (Path.last path) + decl' + dpath + (Subst.type_declaration + (Subst.add_type_path dpath path Subst.identity) decl) + end + in + if err <> None then + raise(Error(loc, Definition_mismatch (ty, env, err))) + with Not_found -> + raise(Error(loc, Unavailable_type_constructor path)) + end + | _ -> raise(Error(loc, Definition_mismatch (ty, env, None))) + end + | _ -> () + +let check_abbrev env sdecl (id, decl) = + check_coherence env sdecl.ptype_loc (Path.Pident id) decl + + +(* Note: Well-foundedness for OCaml types + + We want to guarantee that all cycles within OCaml types are + "guarded". + + More precisely, we consider a reachability relation + "[t] is reachable [guarded|unguarded] from [u]" + defined as follows: + + - [t1, t2...] are reachable guarded from object types + [< m1 : t1; m2 : t2; ... >] + or polymorphic variants + [[`A of t1 | `B of t2 | ...]]. + + - [t1, t2...] are reachable rectypes-guarded from + [t1 -> t2], [t1 * t2 * ...], and all other built-in + contractive type constructors. + + (By rectypes-guarded we mean: guarded if -rectypes is set, + unguarded if it is not set.) + + - If [(t1, t2...) c] is a datatype (variant or record), + then [t1, t2...] are reachable rectypes-guarded from it. + + - If [(t1, t2...) c] is an abstract type, + then [t1, t2...] are reachable unguarded from it. + + - If [(t1, t2...) c] is an (expandable) abbreviation, + then its expansion is reachable unguarded from it. + Note that we do not define [t1, t2...] as reachable. + + - The relation is transitive and guardedness of a composition + is the disjunction of each guardedness: + if t1 is reachable from t2 and t2 is reachable from t3; + then t1 is reachable guarded from t3 if t1 is guarded in t2 + or t2 is guarded in t3, and reachable unguarded otherwise. + + A type [t] is not well-founded if and only if [t] is reachable + unguarded in [t]. + + Notice that, in the case of datatypes, the arguments of + a parametrized datatype are reachable (they must not contain + recursive occurrences of the type), but the definition of the + datatype is not defined as reachable. + + (* well-founded *) + type t = Foo of u + and u = t + + (* ill-founded *) + type 'a t = Foo of 'a + and u = u t + > Error: The type abbreviation u is cyclic + + Indeed, in the second example [u] is reachable unguarded in [u t] + -- its own definition. +*) + +(* Note: Forms of ill-foundedness + + Several OCaml language constructs could introduce ill-founded + types, and there are several distinct checks that forbid different + sources of ill-foundedness. + + 1. Type aliases. + + (* well-founded *) + type t = < x : 'a > as 'a + + (* ill-founded, unless -rectypes is used *) + type t = (int * 'a) as 'a + > Error: This alias is bound to type int * 'a + > but is used as an instance of type 'a + > The type variable 'a occurs inside int * 'a + + Ill-foundedness coming from type aliases is detected by the "occur check" + used by our type unification algorithm. See typetexp.ml. + + 2. Type abbreviations. + + (* well-founded *) + type t = < x : t > + + (* ill-founded, unless -rectypes is used *) + type t = (int * t) + > Error: The type abbreviation t is cyclic + + Ill-foundedness coming from type abbreviations is detected by + [check_well_founded] below. + + 3. Recursive modules. + + (* well-founded *) + module rec M : sig type t = < x : M.t > end = M + + (* ill-founded, unless -rectypes is used *) + module rec M : sig type t = int * M.t end = M + > Error: The definition of M.t contains a cycle: + > int * M.t + + This is also checked by [check_well_founded] below, + as called from [check_recmod_typedecl]. + + 4. Functor application + + A special case of (3) is that a type can be abstract + in a functor definition, and be instantiated with + an abbreviation in an application of the functor. + This can introduce ill-foundedness, so functor applications + must be checked by re-checking the type declarations of their result. + + module type T = sig type t end + module Fix(F:(T -> T)) = struct + (* this recursive definition is well-founded + as F(Fixed).t contains no reachable type expression. *) + module rec Fixed : T with type t = F(Fixed).t = F(Fixed) + end + + (* well-founded *) + Module M = Fix(functor (M:T) -> struct type t = < x : M.t > end) + + (* ill-founded *) + module M = Fix(functor (M:T) -> struct type t = int * M.t end);; + > Error: In the signature of this functor application: + > The definition of Fixed.t contains a cycle: + > F(Fixed).t +*) + +(* Check that a type expression is well-founded: + - if -rectypes is used, we must prevent non-contractive fixpoints + ('a as 'a) + - if -rectypes is not used, we only allow cycles in the type graph + if they go through an object or polymorphic variant type *) + +let check_well_founded ~abs_env env loc path to_check visited ty0 = + let rec check parents trace ty = + if TypeSet.mem ty parents then begin + (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) + let err = + let reaching_path, rec_abbrev = + (* The reaching trace is accumulated in reverse order, we + reverse it to get a reaching path. *) + match trace with + | [] -> assert false + | Expands_to (ty1, _) :: trace when (match get_desc ty1 with + Tconstr (p,_,_) -> Path.same p path | _ -> false) -> + List.rev trace, true + | trace -> List.rev trace, false + in + if rec_abbrev + then Recursive_abbrev (Path.name path, abs_env, reaching_path) + else Cycle_in_def (Path.name path, abs_env, reaching_path) + in raise (Error (loc, err)) + end; + let (fini, parents) = + try + (* Map each node to the set of its already checked parents *) + let prev = TypeMap.find ty !visited in + if TypeSet.subset parents prev then (true, parents) else + let parents = TypeSet.union parents prev in + visited := TypeMap.add ty parents !visited; + (false, parents) + with Not_found -> + visited := TypeMap.add ty parents !visited; + (false, parents) + in + if fini then () else + let rec_ok = + match get_desc ty with + | Tconstr(p,_,_) -> + !Clflags.recursive_types && Ctype.is_contractive env p + | Tobject _ | Tvariant _ -> true + | _ -> !Clflags.recursive_types + in + if rec_ok then () else + let parents = TypeSet.add ty parents in + match get_desc ty with + | Tconstr(p, tyl, _) -> + let to_check = to_check p in + if to_check then List.iter (check_subtype parents trace ty) tyl; + begin match Ctype.try_expand_once_opt env ty with + | ty' -> check parents (Expands_to (ty, ty') :: trace) ty' + | exception Ctype.Cannot_expand -> + if not to_check then List.iter (check_subtype parents trace ty) tyl + end + | _ -> + Btype.iter_type_expr (check_subtype parents trace ty) ty + and check_subtype parents trace outer_ty inner_ty = + check parents (Contains (outer_ty, inner_ty) :: trace) inner_ty + in + let snap = Btype.snapshot () in + try Ctype.wrap_trace_gadt_instances env (check TypeSet.empty []) ty0 + with Ctype.Escape _ -> + (* Will be detected by check_regularity *) + Btype.backtrack snap + +let check_well_founded_manifest ~abs_env env loc path decl = + if decl.type_manifest = None then () else + let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in + let visited = ref TypeMap.empty in + check_well_founded ~abs_env env loc path (Path.same path) visited + (Ctype.newconstr path args) + +(* Given a new type declaration [type t = ...] (potentially mutually-recursive), + we check that accepting the declaration does not introduce ill-founded types. + + Note: we check that the types at the toplevel of the declaration + are not reachable unguarded from themselves, that is, we check that + there is no cycle going through the "root" of the declaration. But + we *also* check that all the type sub-expressions reachable from + the root even those that are guarded, are themselves + well-founded. (So we check the absence of cycles, even for cycles + going through inner type subexpressions but not the root. + + We are not actually sure that this "deep check" is necessary + (we don't have an example at hand where it is necessary), but we + are doing it anyway out of caution. +*) +let check_well_founded_decl ~abs_env env loc path decl to_check = + let open Btype in + (* We iterate on all subexpressions of the declaration to check + "in depth" that no ill-founded type exists. *) + with_type_mark begin fun mark -> + let super = type_iterators mark in + let visited = + (* [visited] remembers the inner visits performed by + [check_well_founded] on each type expression reachable from + this declaration. This avoids unnecessary duplication of + [check_well_founded] work when invoked on two parts of the + type declaration that have common subexpressions. *) + ref TypeMap.empty in + let it = + {super with it_do_type_expr = + (fun self ty -> + check_well_founded ~abs_env env loc path to_check visited ty; + super.it_do_type_expr self ty + )} in + it.it_type_declaration it (Ctype.generic_instance_declaration decl) + end + +(* Check for non-regular abbreviations; an abbreviation + [type 'a t = ...] is non-regular if the expansion of [...] + contains instances [ty t] where [ty] is not equal to ['a]. + + Note: in the case of a constrained type definition + [type 'a t = ... constraint 'a = ...], we require + that all instances in [...] be equal to the constrained type. +*) + +let check_regularity ~abs_env env loc path decl to_check = + (* to_check is true for potentially mutually recursive paths. + (path, decl) is the type declaration to be checked. *) + + if decl.type_params = [] then () else + + let visited = ref TypeSet.empty in + + let rec check_regular cpath args prev_exp trace ty = + if not (TypeSet.mem ty !visited) then begin + visited := TypeSet.add ty !visited; + match get_desc ty with + | Tconstr(path', args', _) -> + if Path.same path path' then begin + if not (Ctype.is_equal abs_env false args args') then + raise (Error(loc, + Non_regular { + definition=path; + used_as=ty; + defined_as=Ctype.newconstr path args; + reaching_path=List.rev trace; + })) + end + (* Attempt to expand a type abbreviation if: + 1- [to_check path'] holds + (otherwise the expansion cannot involve [path]); + 2- we haven't expanded this type constructor before + (otherwise we could loop if [path'] is itself + a non-regular abbreviation). *) + else if to_check path' && not (List.mem path' prev_exp) then begin + try + (* Attempt expansion *) + let (params0, body0, _) = Env.find_type_expansion path' env in + let (params, body) = + Ctype.instance_parameterized_type params0 body0 in + begin + try List.iter2 (Ctype.unify abs_env) args' params + with Ctype.Unify err -> + raise (Error(loc, Constraint_failed (abs_env, err))); + end; + check_regular path' args + (path' :: prev_exp) (Expands_to (ty,body) :: trace) + body + with Not_found -> () + end; + List.iter (check_subtype cpath args prev_exp trace ty) args' + | Tpoly (ty, tl) -> + let (_, ty) = + Ctype.instance_poly ~keep_names:true ~fixed:false tl ty in + check_regular cpath args prev_exp trace ty + | _ -> + Btype.iter_type_expr + (check_subtype cpath args prev_exp trace ty) ty + end + and check_subtype cpath args prev_exp trace outer_ty inner_ty = + let trace = Contains (outer_ty, inner_ty) :: trace in + check_regular cpath args prev_exp trace inner_ty + in + + Option.iter + (fun body -> + let (args, body) = + Ctype.instance_parameterized_type + ~keep_names:true decl.type_params body in + List.iter (check_regular path args [] []) args; + check_regular path args [] [] body) + decl.type_manifest + +let check_abbrev_regularity ~abs_env env id_loc_list to_check tdecl = + let decl = tdecl.typ_type in + let id = tdecl.typ_id in + check_regularity ~abs_env env (List.assoc id id_loc_list) (Path.Pident id) + decl to_check + +let check_duplicates sdecl_list = + let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in + List.iter + (fun sdecl -> match sdecl.ptype_kind with + Ptype_variant cl -> + List.iter + (fun pcd -> + try + let name' = Hashtbl.find constrs pcd.pcd_name.txt in + Location.prerr_warning pcd.pcd_loc + (Warnings.Duplicate_definitions + ("constructor", pcd.pcd_name.txt, name', + sdecl.ptype_name.txt)) + with Not_found -> + Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) + cl + | Ptype_record fl -> + List.iter + (fun {pld_name=cname;pld_loc=loc} -> + try + let name' = Hashtbl.find labels cname.txt in + Location.prerr_warning loc + (Warnings.Duplicate_definitions + ("label", cname.txt, name', sdecl.ptype_name.txt)) + with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt) + fl + | Ptype_abstract -> () + | Ptype_open -> ()) + sdecl_list + +(* Force recursion to go through id for private types*) +let name_recursion sdecl id decl = + match decl with + | { type_kind = Type_abstract _; + type_manifest = Some ty; + type_private = Private; } when is_fixed_type sdecl -> + let ty' = Btype.newty2 ~level:(get_level ty) (get_desc ty) in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + link_type ty (Btype.newty2 ~level:(get_level ty) td); + {decl with type_manifest = Some ty'} + else decl + | _ -> decl + +let name_recursion_decls sdecls decls = + List.map2 (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl)) + sdecls decls + +(* Warn on definitions of type "type foo = ()" which redefine a different unit + type and are likely a mistake. *) +let check_redefined_unit (td: Parsetree.type_declaration) = + let open Parsetree in + let is_unit_constructor cd = cd.pcd_name.txt = "()" in + match td with + | { ptype_name = { txt = name }; + ptype_manifest = None; + ptype_kind = Ptype_variant [ cd ] } + when is_unit_constructor cd -> + Location.prerr_warning td.ptype_loc (Warnings.Redefining_unit name) + | _ -> + () + +let add_types_to_env decls shapes env = + List.fold_right2 + (fun (id, decl) shape env -> + add_type ~check:true ~shape id decl env) + decls shapes env + +(* Translate a set of type declarations, mutually recursive or not *) +let transl_type_decl env rec_flag sdecl_list = + List.iter check_redefined_unit sdecl_list; + (* Add dummy types for fixed rows *) + let fixed_types = List.filter is_fixed_type sdecl_list in + let sdecl_list = + List.map + (fun sdecl -> + let ptype_name = + let loc = { sdecl.ptype_name.loc with Location.loc_ghost = true } in + mkloc (sdecl.ptype_name.txt ^"#row") loc + in + let ptype_kind = Ptype_abstract in + let ptype_manifest = None in + let ptype_loc = { sdecl.ptype_loc with Location.loc_ghost = true } in + {sdecl with + ptype_name; ptype_kind; ptype_manifest; ptype_loc }) + fixed_types + @ sdecl_list + in + + (* Create identifiers. *) + let scope = Ctype.create_scope () in + let ids_list = + List.map (fun sdecl -> + Ident.create_scoped ~scope sdecl.ptype_name.txt, + Uid.mk ~current_unit:(Env.get_current_unit ()) + ) sdecl_list + in + (* Translate declarations, using a temporary environment where abbreviations + expand to a generic type variable. After that, we check the coherence of + the translated declarations in the resulting new environment. *) + let tdecls, decls, shapes, new_env = + Ctype.with_local_level_generalize begin fun () -> + (* Enter types. *) + let temp_env = + List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in + (* Translate each declaration. *) + let current_slot = ref None in + let warn_unused = + Warnings.is_active (Warnings.Unused_type_declaration "") in + let ids_slots (id, _uid as ids) = + match rec_flag with + | Asttypes.Recursive when warn_unused -> + (* See typecore.ml for a description of the algorithm used to + detect unused declarations in a set of recursive definitions. *) + let slot = ref [] in + let td = Env.find_type (Path.Pident id) temp_env in + Env.set_type_used_callback + td + (fun old_callback -> + match !current_slot with + | Some slot -> slot := td.type_uid :: !slot + | None -> + List.iter Env.mark_type_used (get_ref slot); + old_callback () + ); + ids, Some slot + | Asttypes.Recursive | Asttypes.Nonrecursive -> + ids, None + in + let transl_declaration name_sdecl (id, slot) = + current_slot := slot; + Builtin_attributes.warning_scope + name_sdecl.ptype_attributes + (fun () -> transl_declaration temp_env name_sdecl id) + in + let tdecls = + List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in + let decls, shapes = + List.map (fun (tdecl, shape) -> + (tdecl.typ_id, tdecl.typ_type), shape) tdecls + |> List.split + in + current_slot := None; + (* Check for duplicates *) + check_duplicates sdecl_list; + (* Build the final env. *) + let new_env = add_types_to_env decls shapes env in + (tdecls, decls, shapes, new_env) + end + in + (* Check for ill-formed abbrevs *) + let id_loc_list = + List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc)) + ids_list sdecl_list + in + (* [check_abbrev_regularity] and error messages cannot use the new + environment, as this might result in non-termination. Instead we use a + completely abstract version of the temporary environment, giving a reason + for why abbreviations cannot be expanded (#12334, #12368) *) + let abs_env = + List.fold_left2 + (enter_type ~abstract_abbrevs:Rec_check_regularity rec_flag) + env sdecl_list ids_list in + List.iter (fun (id, decl) -> + check_well_founded_manifest ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) decl) + decls; + let to_check = + function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in + List.iter (fun (id, decl) -> + check_well_founded_decl ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) + decl to_check) + decls; + List.iter (fun (tdecl, _shape) -> + check_abbrev_regularity ~abs_env new_env id_loc_list to_check tdecl) + tdecls; + (* Check that all type variables are closed *) + List.iter2 + (fun sdecl (tdecl, _shape) -> + let decl = tdecl.typ_type in + match Ctype.closed_type_decl decl with + Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) + | None -> ()) + sdecl_list tdecls; + (* Check that constraints are enforced *) + List.iter2 (check_constraints new_env) sdecl_list decls; + (* Add type properties to declarations *) + let decls = + try + decls + |> name_recursion_decls sdecl_list + |> Typedecl_variance.update_decls env sdecl_list + |> Typedecl_immediacy.update_decls env + |> Typedecl_separability.update_decls env + with + | Typedecl_variance.Error (loc, err) -> + raise (Error (loc, Variance err)) + | Typedecl_immediacy.Error (loc, err) -> + raise (Error (loc, Immediacy err)) + | Typedecl_separability.Error (loc, err) -> + raise (Error (loc, Separability err)) + in + (* Compute the final environment with variance and immediacy *) + let final_env = add_types_to_env decls shapes env in + (* Check re-exportation *) + List.iter2 (check_abbrev final_env) sdecl_list decls; + (* Keep original declaration *) + let final_decls = + List.map2 + (fun (tdecl, _shape) (_id2, decl) -> + { tdecl with typ_type = decl } + ) tdecls decls + in + (* Done *) + (final_decls, final_env, shapes) + +(* Translating type extensions *) + +let transl_extension_constructor ~scope env type_path type_params + typext_params priv sext = + let id = Ident.create_scoped ~scope sext.pext_name.txt in + let args, ret_type, kind = + match sext.pext_kind with + Pext_decl(svars, sargs, sret_type) -> + let targs, tret_type, args, ret_type = + make_constructor env sext.pext_loc type_path typext_params + svars sargs sret_type + in + args, ret_type, Text_decl(svars, targs, tret_type) + | Pext_rebind lid -> + let usage : Env.constructor_usage = + if priv = Public then Env.Exported else Env.Exported_private + in + let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in + let (args, cstr_res, _ex) = + Ctype.instance_constructor Keep_existentials_flexible cdescr + in + let res, ret_type = + if cdescr.cstr_generalized then + let params = Ctype.instance_list type_params in + let res = Ctype.newconstr type_path params in + let ret_type = Some (Ctype.newconstr type_path params) in + res, ret_type + else (Ctype.newconstr type_path typext_params), None + in + begin + try + Ctype.unify env cstr_res res + with Ctype.Unify err -> + raise (Error(lid.loc, + Rebind_wrong_type(lid.txt, env, err))) + end; + (* Remove "_" names from parameters used in the constructor *) + if not cdescr.cstr_generalized then begin + let vars = + Ctype.free_variables (Btype.newgenty (Ttuple args)) + in + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") + && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + typext_params + end; + (* Ensure that constructor's type matches the type being extended *) + let cstr_type_path = Btype.cstr_type_path cdescr in + let cstr_type_params = (Env.find_type cstr_type_path env).type_params in + let cstr_types = + (Btype.newgenty + (Tconstr(cstr_type_path, cstr_type_params, ref Mnil))) + :: cstr_type_params + in + let ext_types = + (Btype.newgenty + (Tconstr(type_path, type_params, ref Mnil))) + :: type_params + in + if not (Ctype.is_equal env true cstr_types ext_types) then + raise (Error(lid.loc, + Rebind_mismatch(lid.txt, cstr_type_path, type_path))); + (* Disallow rebinding private constructors to non-private *) + begin + match cdescr.cstr_private, priv with + Private, Public -> + raise (Error(lid.loc, Rebind_private lid.txt)) + | _ -> () + end; + let path = + match cdescr.cstr_tag with + Cstr_extension(path, _) -> path + | _ -> assert false + in + let args = + match cdescr.cstr_inlined with + | None -> + Types.Cstr_tuple args + | Some decl -> + let tl = + match List.map get_desc args with + | [ Tconstr(_, tl, _) ] -> tl + | _ -> assert false + in + let decl = Ctype.instance_declaration decl in + assert (List.length decl.type_params = List.length tl); + List.iter2 (Ctype.unify env) decl.type_params tl; + let lbls = + match decl.type_kind with + | Type_record (lbls, Record_extension _) -> lbls + | _ -> assert false + in + Types.Cstr_record lbls + in + args, ret_type, Text_rebind(path, lid) + in + let ext = + { ext_type_path = type_path; + ext_type_params = typext_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = priv; + Types.ext_loc = sext.pext_loc; + Types.ext_attributes = sext.pext_attributes; + ext_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let ext_cstrs = + { ext_id = id; + ext_name = sext.pext_name; + ext_type = ext; + ext_kind = kind; + Typedtree.ext_loc = sext.pext_loc; + Typedtree.ext_attributes = sext.pext_attributes; } + in + let shape = + let map = match ext_cstrs.ext_kind with + | Text_decl (_, Cstr_record lbls, _) -> shape_map_labels lbls + | _ -> Shape.Map.empty + in + Shape.str ~uid:ext_cstrs.ext_type.ext_uid map + in + ext_cstrs, shape + +let transl_extension_constructor ~scope env type_path type_params + typext_params priv sext = + Builtin_attributes.warning_scope sext.pext_attributes + (fun () -> transl_extension_constructor ~scope env type_path type_params + typext_params priv sext) + +let is_rebind ext = + match ext.ext_kind with + | Text_rebind _ -> true + | Text_decl _ -> false + +let transl_type_extension extend env loc styext = + let type_path, type_decl = + let lid = styext.ptyext_path in + Env.lookup_type ~loc:lid.loc lid.txt env + in + begin + match type_decl.type_kind with + | Type_open -> begin + match type_decl.type_private with + | Private when extend -> begin + match + List.find + (function {pext_kind = Pext_decl _} -> true + | {pext_kind = Pext_rebind _} -> false) + styext.ptyext_constructors + with + | {pext_loc} -> + raise (Error(pext_loc, Cannot_extend_private_type type_path)) + | exception Not_found -> () + end + | _ -> () + end + | _ -> + raise (Error(loc, Not_extensible_type type_path)) + end; + let type_variance = + List.map (fun v -> + let (co, cn) = Variance.get_upper v in + (not cn, not co, false)) + type_decl.type_variance + in + let err = + if type_decl.type_arity <> List.length styext.ptyext_params then + Some Includecore.Arity + else + if List.for_all2 + (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1)) + type_variance + (Typedecl_variance.variance_of_params styext.ptyext_params) + then None else Some Includecore.Variance + in + begin match err with + | None -> () + | Some err -> raise (Error(loc, Extension_mismatch (type_path, env, err))) + end; + let ttype_params, _type_params, constructors = + (* Note: it would be incorrect to call [create_scope] *after* + [TyVarEnv.reset] or after [with_local_level] (see #10010). *) + let scope = Ctype.create_scope () in + Ctype.with_local_level_generalize begin fun () -> + TyVarEnv.reset(); + let ttype_params = make_params env styext.ptyext_params in + let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in + List.iter2 (Ctype.unify_var env) + (Ctype.instance_list type_decl.type_params) + type_params; + let constructors = + List.map (transl_extension_constructor ~scope env type_path + type_decl.type_params type_params styext.ptyext_private) + styext.ptyext_constructors + in + (ttype_params, type_params, constructors) + end + in + (* Check that all type variables are closed *) + List.iter + (fun (ext, _shape) -> + match Ctype.closed_extension_constructor ext.ext_type with + Some ty -> + raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) + | None -> ()) + constructors; + (* Check variances are correct *) + List.iter + (fun (ext, _shape) -> + (* Note that [loc] here is distinct from [type_decl.type_loc], which + makes the [loc] parameter to this function useful. [loc] is the + location of the extension, while [type_decl] points to the original + type declaration being extended. *) + try Typedecl_variance.check_variance_extension + env type_decl ext (type_variance, loc) + with Typedecl_variance.Error (loc, err) -> + raise (Error (loc, Variance err))) + constructors; + (* Add extension constructors to the environment *) + let newenv = + List.fold_left + (fun env (ext, shape) -> + let rebind = is_rebind ext in + Env.add_extension ~check:true ~shape ~rebind + ext.ext_id ext.ext_type env) + env constructors + in + let constructors, shapes = List.split constructors in + let tyext = + { tyext_path = type_path; + tyext_txt = styext.ptyext_path; + tyext_params = ttype_params; + tyext_constructors = constructors; + tyext_private = styext.ptyext_private; + tyext_loc = styext.ptyext_loc; + tyext_attributes = styext.ptyext_attributes; } + in + (tyext, newenv, shapes) + +let transl_type_extension extend env loc styext = + Builtin_attributes.warning_scope styext.ptyext_attributes + (fun () -> transl_type_extension extend env loc styext) + +let transl_exception env sext = + let ext, shape = + let scope = Ctype.create_scope () in + Ctype.with_local_level_generalize + (fun () -> + TyVarEnv.reset(); + transl_extension_constructor ~scope env + Predef.path_exn [] [] Asttypes.Public sext) + in + (* Check that all type variables are closed *) + begin match Ctype.closed_extension_constructor ext.ext_type with + Some ty -> + raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) + | None -> () + end; + let rebind = is_rebind ext in + let newenv = + Env.add_extension ~check:true ~shape ~rebind ext.ext_id ext.ext_type env + in + ext, newenv, shape + +let transl_type_exception env t = + let contructor, newenv, shape = + Builtin_attributes.warning_scope t.ptyexn_attributes + (fun () -> + transl_exception env t.ptyexn_constructor + ) + in + {tyexn_constructor = contructor; + tyexn_loc = t.ptyexn_loc; + tyexn_attributes = t.ptyexn_attributes}, newenv, shape + + +type native_repr_attribute = + | Native_repr_attr_absent + | Native_repr_attr_present of native_repr_kind + +let get_native_repr_attribute attrs ~global_repr = + match + Attr_helper.get_no_payload_attribute "unboxed" attrs, + Attr_helper.get_no_payload_attribute "untagged" attrs, + global_repr + with + | None, None, None -> Native_repr_attr_absent + | None, None, Some repr -> Native_repr_attr_present repr + | Some _, None, None -> Native_repr_attr_present Unboxed + | None, Some _, None -> Native_repr_attr_present Untagged + | Some { Location.loc }, _, _ + | _, Some { Location.loc }, _ -> + raise (Error (loc, Multiple_native_repr_attributes)) + +let native_repr_of_type env kind ty = + match kind, get_desc (Ctype.expand_head_opt env ty) with + | Untagged, Tconstr (_, _, _) when + Typeopt.maybe_pointer_type env ty = Lambda.Immediate -> + Some Untagged_immediate + | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float -> + Some Unboxed_float + | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 -> + Some (Unboxed_integer Pint32) + | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 -> + Some (Unboxed_integer Pint64) + | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint -> + Some (Unboxed_integer Pnativeint) + | _ -> + None + +(* Raises an error when [core_type] contains an [@unboxed] or [@untagged] + attribute in a strict sub-term. *) +let error_if_has_deep_native_repr_attributes core_type = + let open Ast_iterator in + let this_iterator = + { default_iterator with typ = fun iterator core_type -> + begin + match + get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None + with + | Native_repr_attr_present kind -> + raise (Error (core_type.ptyp_loc, + Deep_unbox_or_untag_attribute kind)) + | Native_repr_attr_absent -> () + end; + default_iterator.typ iterator core_type } + in + default_iterator.typ this_iterator core_type + +let make_native_repr env core_type ty ~global_repr = + error_if_has_deep_native_repr_attributes core_type; + match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with + | Native_repr_attr_absent -> + Same_as_ocaml_repr + | Native_repr_attr_present kind -> + begin match native_repr_of_type env kind ty with + | None -> + raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind)) + | Some repr -> repr + end + +let rec parse_native_repr_attributes env core_type ty ~global_repr = + match core_type.ptyp_desc, get_desc ty, + get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None + with + | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind -> + raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind)) + | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ -> + let repr_arg = make_native_repr env ct1 t1 ~global_repr in + let repr_args, repr_res = + parse_native_repr_attributes env ct2 t2 ~global_repr + in + (repr_arg :: repr_args, repr_res) + | (Ptyp_poly (_, t) | Ptyp_alias (t, _)), _, _ -> + parse_native_repr_attributes env t ty ~global_repr + | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false + | _ -> ([], make_native_repr env core_type ty ~global_repr) + + +let check_unboxable env loc ty = + let check_type acc ty : Path.Set.t = + let ty = Ctype.expand_head_opt env ty in + try match get_desc ty with + | Tconstr (p, _, _) -> + let tydecl = Env.find_type p env in + if tydecl.type_unboxed_default then + Path.Set.add p acc + else acc + | _ -> acc + with Not_found -> acc + in + let all_unboxable_types = Btype.fold_type_expr check_type Path.Set.empty ty in + Path.Set.fold + (fun p () -> + Location.prerr_warning loc + (Warnings.Unboxable_type_in_prim_decl (Path.name p)) + ) + all_unboxable_types + () + +(* Translate a value declaration *) +let transl_value_decl env loc valdecl = + let cty = Typetexp.transl_type_scheme env valdecl.pval_type in + let ty = cty.ctyp_type in + let v = + match valdecl.pval_prim with + [] when Env.is_in_signature env -> + { val_type = ty; val_kind = Val_reg; Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + | [] -> + raise (Error(valdecl.pval_loc, Val_in_structure)) + | _ -> + let global_repr = + match + get_native_repr_attribute valdecl.pval_attributes ~global_repr:None + with + | Native_repr_attr_present repr -> Some repr + | Native_repr_attr_absent -> None + in + let native_repr_args, native_repr_res = + parse_native_repr_attributes env valdecl.pval_type ty ~global_repr + in + let prim = + Primitive.parse_declaration valdecl + ~native_repr_args + ~native_repr_res + in + if prim.prim_arity = 0 && + (prim.prim_name = "" || prim.prim_name.[0] <> '%') then + raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); + if !Clflags.native_code + && prim.prim_arity > 5 + && prim.prim_native_name = "" + then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external)); + check_unboxable env loc ty; + { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let (id, newenv) = + Env.enter_value valdecl.pval_name.txt v env + ~check:(fun s -> Warnings.Unused_value_declaration s) + in + let desc = + { + val_id = id; + val_name = valdecl.pval_name; + val_desc = cty; val_val = v; + val_prim = valdecl.pval_prim; + val_loc = valdecl.pval_loc; + val_attributes = valdecl.pval_attributes; + } + in + desc, newenv + +let transl_value_decl env loc valdecl = + Builtin_attributes.warning_scope valdecl.pval_attributes + (fun () -> transl_value_decl env loc valdecl) + +(* Translate a "with" constraint -- much simplified version of + transl_type_decl. For a constraint [Sig with t = sdecl], + there are two declarations of interest in two environments: + - [sig_decl] is the declaration of [t] in [Sig], + in the environment [sig_env] (containing the declarations + of [Sig] before [t]) + - [sdecl] is the new syntactic declaration, to be type-checked + in the current, outer environment [with_env]. + + In particular, note that [sig_env] is an extension of + [outer_env]. +*) +let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env + sdecl = + Env.mark_type_used sig_decl.type_uid; + Ctype.with_local_level_generalize begin fun () -> + TyVarEnv.reset(); + (* In the first part of this function, we typecheck the syntactic + declaration [sdecl] in the outer environment [outer_env]. *) + let env = outer_env in + let loc = sdecl.ptype_loc in + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in + let arity = List.length params in + let constraints = + List.map (fun (ty, ty', loc) -> + let cty = transl_simple_type env ~closed:false ty in + let cty' = transl_simple_type env ~closed:false ty' in + (* Note: We delay the unification of those constraints + after the unification of parameters, so that clashing + constraints report an error on the constraint location + rather than the parameter location. *) + (cty, cty', loc) + ) sdecl.ptype_cstrs + in + let no_row = not (is_fixed_type sdecl) in + let (tman, man) = match sdecl.ptype_manifest with + None -> Misc.fatal_error "Typedecl.transl_with_constraint: no manifest" + | Some sty -> + let cty = transl_simple_type env ~closed:no_row sty in + cty, cty.ctyp_type + in + (* In the second part, we check the consistency between the two + declarations and compute a "merged" declaration; we now need to + work in the larger signature environment [sig_env], because + [sig_decl.type_params] and [sig_decl.type_kind] are only valid + there. *) + let env = sig_env in + let sig_decl = Ctype.instance_declaration sig_decl in + let arity_ok = arity = sig_decl.type_arity in + if arity_ok then + List.iter2 (fun (cty, _) tparam -> + try Ctype.unify_var env cty.ctyp_type tparam + with Ctype.Unify err -> + raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, err))) + ) tparams sig_decl.type_params; + List.iter (fun (cty, cty', loc) -> + (* Note: constraints must also be enforced in [sig_env] because + they may contain parameter variables from [tparams] + that have now be unified in [sig_env]. *) + try Ctype.unify env cty.ctyp_type cty'.ctyp_type + with Ctype.Unify err -> + raise(Error(loc, Inconsistent_constraint (env, err))) + ) constraints; + let sig_decl_abstract = Btype.type_kind_is_abstract sig_decl in + let priv = + if sdecl.ptype_private = Private then Private else + if arity_ok && not sig_decl_abstract + then sig_decl.type_private else sdecl.ptype_private + in + if arity_ok && not sig_decl_abstract + && sdecl.ptype_private = Private then + Location.deprecated loc "spurious use of private"; + let type_kind, type_unboxed_default = + if arity_ok then + sig_decl.type_kind, sig_decl.type_unboxed_default + else + Type_abstract Definition, false + in + let new_sig_decl = + { type_params = params; + type_arity = arity; + type_kind; + type_private = priv; + type_manifest = Some man; + type_variance = []; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = Unknown; + type_unboxed_default; + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + Option.iter (fun p -> set_private_row env sdecl.ptype_loc p new_sig_decl) + fixed_row_path; + begin match Ctype.closed_type_decl new_sig_decl with None -> () + | Some ty -> raise(Error(loc, Unbound_type_var(ty, new_sig_decl))) + end; + let new_sig_decl = name_recursion sdecl id new_sig_decl in + let new_type_variance = + let required = Typedecl_variance.variance_of_sdecl sdecl in + try + Typedecl_variance.compute_decl env ~check:(Some id) new_sig_decl required + with Typedecl_variance.Error (loc, err) -> + raise (Error (loc, Variance err)) in + let new_type_immediate = + (* Typedecl_immediacy.compute_decl never raises *) + Typedecl_immediacy.compute_decl env new_sig_decl in + let new_type_separability = + try Typedecl_separability.compute_decl env new_sig_decl + with Typedecl_separability.Error (loc, err) -> + raise (Error (loc, Separability err)) in + let new_sig_decl = + (* we intentionally write this without a fragile { decl with ... } + to ensure that people adding new fields to type declarations + consider whether they need to recompute it here; for an example + of bug caused by the previous approach, see #9607 *) + { + type_params = new_sig_decl.type_params; + type_arity = new_sig_decl.type_arity; + type_kind = new_sig_decl.type_kind; + type_private = new_sig_decl.type_private; + type_manifest = new_sig_decl.type_manifest; + type_unboxed_default = new_sig_decl.type_unboxed_default; + type_is_newtype = new_sig_decl.type_is_newtype; + type_expansion_scope = new_sig_decl.type_expansion_scope; + type_loc = new_sig_decl.type_loc; + type_attributes = new_sig_decl.type_attributes; + type_uid = new_sig_decl.type_uid; + + type_variance = new_type_variance; + type_immediate = new_type_immediate; + type_separability = new_type_separability; + } in + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = new_sig_decl; + typ_cstrs = constraints; + typ_loc = loc; + typ_manifest = Some tman; + typ_kind = Ttype_abstract; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } + end + +(* A simplified version of [transl_with_constraint], for the case of packages. + Package constraints are much simpler than normal with type constraints (e.g., + they can not have parameters and can only update abstract types.) *) +let transl_package_constraint ~loc env ty = + let new_sig_decl = + { type_params = []; + type_arity = 0; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = Some ty; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) + } + in + let new_type_immediate = + (* Typedecl_immediacy.compute_decl never raises *) + Typedecl_immediacy.compute_decl env new_sig_decl + in + { new_sig_decl with type_immediate = new_type_immediate } + +(* Approximate a type declaration: just make all types abstract *) + +let abstract_type_decl ~injective arity = + let rec make_params n = + if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in + Ctype.with_local_level_generalize begin fun () -> + { type_params = make_params arity; + type_arity = arity; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = None; + type_variance = Variance.unknown_signature ~injective ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = Location.none; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + } + end + +let approx_type_decl sdecl_list = + let scope = Ctype.create_scope () in + List.map + (fun sdecl -> + let injective = sdecl.ptype_kind <> Ptype_abstract in + (Ident.create_scoped ~scope sdecl.ptype_name.txt, + abstract_type_decl ~injective (List.length sdecl.ptype_params))) + sdecl_list + +(* Check the well-formedness conditions on type abbreviations defined + within recursive modules. *) + +let check_recmod_typedecl env loc recmod_ids path decl = + (* recmod_ids is the list of recursively-defined module idents. + (path, decl) is the type declaration to be checked. *) + let to_check path = Path.exists_free recmod_ids path in + check_well_founded_decl ~abs_env:env env loc path decl to_check; + check_regularity ~abs_env:env env loc path decl to_check; + (* additional coherence check, as one might build an incoherent signature, + and use it to build an incoherent module, cf. #7851 *) + check_coherence env loc path decl + + +(**** Error report ****) + +open Format_doc +module Style = Misc.Style +module Printtyp = Printtyp.Doc + +let explain_unbound_gen ppf tv tl typ kwd pr = + try + let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in + let ty0 = (* Hack to force aliasing when needed *) + Btype.newgenty (Tobject(tv, ref None)) in + Out_type.prepare_for_printing [typ ti; ty0]; + fprintf ppf + ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd (Style.as_inline_code pr) ti + (Style.as_inline_code Out_type.prepared_type_expr) tv + with Not_found -> () + +let explain_unbound ppf tv tl typ kwd lab = + explain_unbound_gen ppf tv tl typ kwd + (fun ppf ti -> + fprintf ppf "%s%a" (lab ti) Out_type.prepared_type_expr (typ ti) + ) + +let explain_unbound_single ppf tv ty = + let trivial ty = + explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in + match get_desc ty with + Tobject(fi,_) -> + let (tl, rv) = Ctype.flatten_fields fi in + if eq_type rv tv then trivial ty else + explain_unbound ppf tv tl (fun (_,_,t) -> t) + "method" (fun (lab,_,_) -> lab ^ ": ") + | Tvariant row -> + if eq_type (row_more row) tv then trivial ty else + explain_unbound ppf tv (row_fields row) + (fun (_l,f) -> match row_field_repr f with + Rpresent (Some t) -> t + | Reither (_,[t],_) -> t + | Reither (_,tl,_) -> Btype.newgenty (Ttuple tl) + | _ -> Btype.newgenty (Ttuple[])) + "case" (fun (lab,_) -> "`" ^ lab ^ " of ") + | _ -> trivial ty + + +let tys_of_constr_args = function + | Types.Cstr_tuple tl -> tl + | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls + +module Reaching_path = struct + type t = reaching_type_path + + (* Simplify a reaching path before showing it in error messages. *) + let simplify path = + let rec simplify : t -> t = function + | Contains (ty1, _ty2) :: Contains (_ty2', ty3) :: rest -> + (* If t1 contains t2 and t2 contains t3, then t1 contains t3 + and we don't need to show t2. *) + simplify (Contains (ty1, ty3) :: rest) + | hd :: rest -> hd :: simplify rest + | [] -> [] + in simplify path + + (* See Out_type.add_type_to_preparation. + + Note: it is better to call this after [simplify], otherwise some + type variable names may be used for types that are removed + by simplification and never actually shown to the user. + *) + let add_to_preparation path = + List.iter (function + | Contains (ty1, ty2) | Expands_to (ty1, ty2) -> + List.iter Out_type.add_type_to_preparation [ty1; ty2] + ) path + + module Fmt = Format_doc + + let pp ppf reaching_path = + let pp_step ppf = function + | Expands_to (ty, body) -> + Fmt.fprintf ppf "%a = %a" + (Style.as_inline_code Out_type.prepared_type_expr) ty + (Style.as_inline_code Out_type.prepared_type_expr) body + | Contains (outer, inner) -> + Fmt.fprintf ppf "%a contains %a" + (Style.as_inline_code Out_type.prepared_type_expr) outer + (Style.as_inline_code Out_type.prepared_type_expr) inner + in + Fmt.(pp_print_list ~pp_sep:comma) pp_step ppf reaching_path + + let pp_colon ppf path = + Fmt.fprintf ppf ":@;<1 2>@[%a@]" pp path +end + +let quoted_out_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty +let quoted_type ppf ty = Style.as_inline_code Printtyp.type_expr ppf ty + +let report_error_doc ppf = function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Duplicate_constructor s -> + fprintf ppf "Two constructors are named %a" Style.inline_code s + | Too_many_constructors -> + fprintf ppf + "@[Too many non-constant constructors@ -- maximum is %i %s@]" + (Config.max_tag + 1) "non-constant constructors" + | Duplicate_label s -> + fprintf ppf "Two labels are named %a" Style.inline_code s + | Recursive_abbrev (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Out_type.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The type abbreviation %a is cyclic%a@]" + Style.inline_code s + Reaching_path.pp_colon reaching_path + | Cycle_in_def (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Out_type.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The definition of %a contains a cycle%a@]" + Style.inline_code s + Reaching_path.pp_colon reaching_path + | Definition_mismatch (ty, _env, None) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" + "This variant or record definition" "does not match that of type" + quoted_type ty + | Definition_mismatch (ty, env, Some err) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" + "This variant or record definition" "does not match that of type" + quoted_type ty + (Includecore.report_type_mismatch + "the original" "this" "definition" env) + err + | Constraint_failed (env, err) -> + let msg = Format_doc.Doc.msg in + fprintf ppf "@[Constraints are not satisfied in this type.@ "; + Errortrace_report.unification ppf env err + (msg "Type") + (msg "should be an instance of"); + fprintf ppf "@]" + | Non_regular { definition; used_as; defined_as; reaching_path } -> + let reaching_path = Reaching_path.simplify reaching_path in + Out_type.prepare_for_printing [used_as; defined_as]; + Reaching_path.add_to_preparation reaching_path; + fprintf ppf + "@[This recursive type is not regular.@ \ + The type constructor %a is defined as@;<1 2>type %a@ \ + but it is used as@;<1 2>%a%t\ + All uses need to match the definition for the recursive type \ + to be regular.@]" + Style.inline_code (Path.name definition) + quoted_out_type (Out_type.tree_of_typexp Type defined_as) + quoted_out_type (Out_type.tree_of_typexp Type used_as) + (fun pp -> + let is_expansion = function Expands_to _ -> true | _ -> false in + if List.exists is_expansion reaching_path then + fprintf pp "@ after the following expansion(s)%a@ " + Reaching_path.pp_colon reaching_path + else fprintf pp ".@ ") + | Inconsistent_constraint (env, err) -> + let msg = Format_doc.Doc.msg in + fprintf ppf "@[The type constraints are not consistent.@ "; + Errortrace_report.unification ppf env err + (msg "Type") + (msg "is not compatible with type"); + fprintf ppf "@]" + | Type_clash (env, err) -> + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf env err + (msg "This type constructor expands to type") + (msg "but is used here with type") + | Null_arity_external -> + fprintf ppf "External identifiers must be functions" + | Missing_native_external -> + fprintf ppf "@[An external function with more than 5 arguments \ + requires a second stub function@ \ + for native-code compilation@]" + | Unbound_type_var (ty, decl) -> + fprintf ppf "@[A type variable is unbound in this type declaration"; + begin match decl.type_kind, decl.type_manifest with + | Type_variant (tl, _rep), _ -> + explain_unbound_gen ppf ty tl (fun c -> + let tl = tys_of_constr_args c.Types.cd_args in + Btype.newgenty (Ttuple tl) + ) + "case" (fun ppf c -> + fprintf ppf + "%a of %a" Printtyp.ident c.Types.cd_id + Printtyp.constructor_arguments c.Types.cd_args) + | Type_record (tl, _), _ -> + explain_unbound ppf ty tl (fun l -> l.Types.ld_type) + "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") + | Type_abstract _, Some ty' -> + explain_unbound_single ppf ty ty' + | _ -> () + end; + fprintf ppf "@]" + | Unbound_type_var_ext (ty, ext) -> + fprintf ppf "@[A type variable is unbound in this extension constructor"; + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> ""); + fprintf ppf "@]" + | Cannot_extend_private_type path -> + fprintf ppf "@[%s@ %a@]" + "Cannot extend private type definition" + Printtyp.path path + | Not_extensible_type path -> + fprintf ppf "@[%s@ %a@ %s@]" + "Type definition" + (Style.as_inline_code Printtyp.path) path + "is not extensible" + | Extension_mismatch (path, env, err) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" + "This extension" "does not match the definition of type" + Style.inline_code (Path.name path) + (Includecore.report_type_mismatch + "the type" "this extension" "definition" env) + err + | Rebind_wrong_type (lid, env, err) -> + let msg = Format_doc.doc_printf in + Errortrace_report.unification ppf env err + (msg "The constructor %a@ has type" + (Style.as_inline_code Printtyp.longident) lid) + (msg "but was expected to be of type") + | Rebind_mismatch (lid, p, p') -> + fprintf ppf + "@[%s@ %a@ %s@ %a@ %s@ %s@ %a@]" + "The constructor" + (Style.as_inline_code Printtyp.longident) lid + "extends type" Style.inline_code (Path.name p) + "whose declaration does not match" + "the declaration of type" Style.inline_code (Path.name p') + | Rebind_private lid -> + fprintf ppf "@[%s@ %a@ %s@]" + "The constructor" + (Style.as_inline_code Printtyp.longident) lid + "is private" + | Variance (Typedecl_variance.Bad_variance (n, v1, v2)) -> + let variance (p,n,i) = + let inj = if i then "injective " else "" in + match p, n with + true, true -> inj ^ "invariant" + | true, false -> inj ^ "covariant" + | false, true -> inj ^ "contravariant" + | false, false -> if inj = "" then "unrestricted" else inj + in + (match n with + | Variance_variable_error { error; variable; context } -> + Out_type.prepare_for_printing [ variable ]; + begin match context with + | Type_declaration (id, decl) -> + Out_type.add_type_declaration_to_preparation id decl; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the definition" + (Style.as_inline_code @@ Out_type.prepared_type_declaration id) + decl + | Gadt_constructor c -> + Out_type.add_constructor_to_preparation c; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the GADT constructor" + (Style.as_inline_code Out_type.prepared_constructor) + c + | Extension_constructor (id, e) -> + Out_type.add_extension_constructor_to_preparation e; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the extension constructor" + (Out_type.prepared_extension_constructor id) + e + end; + begin match error with + | Variance_not_reflected -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + (Style.as_inline_code Out_type.prepared_type_expr) variable + "has a variance that" + "is not reflected by its occurrence in type parameters." + | No_variable -> + fprintf ppf "@[%s@ %a@ %s@ %s@]@]" + "the type variable" + (Style.as_inline_code Out_type.prepared_type_expr) variable + "cannot be deduced" + "from the type parameters." + | Variance_not_deducible -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + (Style.as_inline_code Out_type.prepared_type_expr) variable + "has a variance that" + "cannot be deduced from the type parameters." + end + | Variance_not_satisfied n -> + fprintf ppf "@[@[%s@ %s@ The %d%s type parameter" + "In this definition, expected parameter" + "variances are not satisfied." + n (Misc.ordinal_suffix n)); + (match n with + | Variance_variable_error { error = No_variable; _ } -> () + | _ -> + fprintf ppf " was expected to be %s,@ but it is %s.@]@]" + (variance v2) (variance v1)) + | Unavailable_type_constructor p -> + fprintf ppf "The definition of type %a@ is unavailable" + (Style.as_inline_code Printtyp.path) p + | Variance Typedecl_variance.Varying_anonymous -> + fprintf ppf "@[%s@ %s@ %s@]" + "In this GADT definition," "the variance of some parameter" + "cannot be checked" + | Val_in_structure -> + fprintf ppf "Value declarations are only allowed in signatures" + | Multiple_native_repr_attributes -> + fprintf ppf "Too many %a/%a attributes" + Style.inline_code "[@@unboxed]" + Style.inline_code "[@@untagged]" + | Cannot_unbox_or_untag_type Unboxed -> + fprintf ppf "@[Don't know how to unbox this type.@ \ + Only %a, %a, %a, and %a can be unboxed.@]" + Style.inline_code "float" + Style.inline_code "int32" + Style.inline_code "int64" + Style.inline_code "nativeint" + | Cannot_unbox_or_untag_type Untagged -> + fprintf ppf "@[Don't know how to untag this type. Only %a@ \ + and other immediate types can be untagged.@]" + Style.inline_code "int" + | Deep_unbox_or_untag_attribute kind -> + fprintf ppf + "@[The attribute %a should be attached to@ \ + a direct argument or result of the primitive,@ \ + it should not occur deeply into its type.@]" + Style.inline_code + (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged") + | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) -> + (match violation with + | Type_immediacy.Violation.Not_always_immediate -> + fprintf ppf + "@[Types@ marked@ with@ the@ immediate@ attribute@ must@ be@ \ + non-pointer@ types@ like@ %a@ or@ %a.@]" + Style.inline_code "int" + Style.inline_code "bool" + | Type_immediacy.Violation.Not_always_immediate_on_64bits -> + fprintf ppf + "@[Types@ marked@ with@ the@ %a@ attribute@ must@ be@ \ + produced@ using@ the@ %a@ functor.@]" + Style.inline_code "immediate64" + Style.inline_code "Stdlib.Sys.Immediate64.Make" + ) + | Bad_unboxed_attribute msg -> + fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg + | Separability (Typedecl_separability.Non_separable_evar evar) -> + let pp_evar ppf = function + | None -> + fprintf ppf "an unnamed existential variable" + | Some str -> + fprintf ppf "the existential variable %a" + (Style.as_inline_code Pprintast.Doc.tyvar) str in + fprintf ppf "@[This type cannot be unboxed because@ \ + it might contain both float and non-float values,@ \ + depending on the instantiation of %a.@ \ + You should annotate it with %a.@]" + pp_evar evar + Style.inline_code "[@@ocaml.boxed]" + | Boxed_and_unboxed -> + fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]" + | Nonrec_gadt -> + fprintf ppf + "@[GADT case syntax cannot be used in a %a block.@]" + Style.inline_code "nonrec" + | Invalid_private_row_declaration ty -> + let pp_private ppf ty = fprintf ppf "private %a" Printtyp.type_expr ty in + fprintf ppf + "@[This private row type declaration is invalid.@ \ + The type expression on the right-hand side reduces to@;<1 2>%a@ \ + which does not have a free row type variable.@]@,\ + @[@[@{Hint@}: If you intended to define a private \ + type abbreviation,@ \ + write explicitly@]@;<1 2>%a@]" + (Style.as_inline_code Printtyp.type_expr) ty + (Style.as_inline_code pp_private) ty + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error_doc err) + | _ -> + None + ) + +let report_error = Format_doc.compat report_error_doc diff --git a/upstream/ocaml_503/typing/typedecl.mli b/upstream/ocaml_503/typing/typedecl.mli new file mode 100644 index 000000000..38c00487e --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl.mli @@ -0,0 +1,113 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Typing of type definitions and primitive definitions *) + +open Types +val transl_type_decl: + Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> + Typedtree.type_declaration list * Env.t * Shape.t list + +val transl_exception: + Env.t -> Parsetree.extension_constructor -> + Typedtree.extension_constructor * Env.t * Shape.t + +val transl_type_exception: + Env.t -> + Parsetree.type_exception -> Typedtree.type_exception * Env.t * Shape.t + +val transl_type_extension: + bool -> Env.t -> Location.t -> Parsetree.type_extension -> + Typedtree.type_extension * Env.t * Shape.t list + +val transl_value_decl: + Env.t -> Location.t -> + Parsetree.value_description -> Typedtree.value_description * Env.t + +(* If the [fixed_row_path] optional argument is provided, + the [Parsetree.type_declaration] argument should satisfy [is_fixed_type] *) +val transl_with_constraint: + Ident.t -> ?fixed_row_path:Path.t -> + sig_env:Env.t -> sig_decl:Types.type_declaration -> + outer_env:Env.t -> Parsetree.type_declaration -> + Typedtree.type_declaration + +val transl_package_constraint: + loc:Location.t -> Env.t -> type_expr -> Types.type_declaration + +val abstract_type_decl: injective:bool -> int -> type_declaration +val approx_type_decl: + Parsetree.type_declaration list -> + (Ident.t * type_declaration) list +val check_recmod_typedecl: + Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit +val check_coherence: + Env.t -> Location.t -> Path.t -> type_declaration -> unit + +(* for fixed types *) +val is_fixed_type : Parsetree.type_declaration -> bool + +type native_repr_kind = Unboxed | Untagged + +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + +type error = + Repeated_parameter + | Duplicate_constructor of string + | Too_many_constructors + | Duplicate_label of string + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | Non_regular of { + definition: Path.t; + used_as: type_expr; + defined_as: type_expr; + reaching_path: reaching_type_path; + } + | Null_arity_external + | Missing_native_external + | Unbound_type_var of type_expr * type_declaration + | Cannot_extend_private_type of Path.t + | Not_extensible_type of Path.t + | Extension_mismatch of Path.t * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | Rebind_mismatch of Longident.t * Path.t * Path.t + | Rebind_private of Longident.t + | Variance of Typedecl_variance.error + | Unavailable_type_constructor of Path.t + | Unbound_type_var_ext of type_expr * extension_constructor + | Val_in_structure + | Multiple_native_repr_attributes + | Cannot_unbox_or_untag_type of native_repr_kind + | Deep_unbox_or_untag_attribute of native_repr_kind + | Immediacy of Typedecl_immediacy.error + | Separability of Typedecl_separability.error + | Bad_unboxed_attribute of string + | Boxed_and_unboxed + | Nonrec_gadt + | Invalid_private_row_declaration of type_expr + +exception Error of Location.t * error + +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer diff --git a/upstream/ocaml_503/typing/typedecl_immediacy.ml b/upstream/ocaml_503/typing/typedecl_immediacy.ml new file mode 100644 index 000000000..71e49a10b --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_immediacy.ml @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +type error = Bad_immediacy_attribute of Type_immediacy.Violation.t +exception Error of Location.t * error + +let compute_decl env tdecl = + match (tdecl.type_kind, tdecl.type_manifest) with + | (Type_variant ([{cd_args = Cstr_tuple [arg] + | Cstr_record [{ld_type = arg; _}]; _}], + Variant_unboxed) + | Type_record ([{ld_type = arg; _}], Record_unboxed _)), _ -> + begin match Typedecl_unboxed.get_unboxed_type_representation env arg with + | None -> Type_immediacy.Unknown + | Some argrepr -> Ctype.immediacy env argrepr + end + | (Type_variant (cstrs, _), _) -> + if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) + then + Type_immediacy.Always + else + Type_immediacy.Unknown + | (Type_abstract _, Some(typ)) -> Ctype.immediacy env typ + | (Type_abstract _, None) -> + Type_immediacy.of_attributes tdecl.type_attributes + | _ -> Type_immediacy.Unknown + +let property : (Type_immediacy.t, unit) Typedecl_properties.property = + let open Typedecl_properties in + let eq = (=) in + let merge ~prop:_ ~new_prop = new_prop in + let default _decl = Type_immediacy.Unknown in + let compute env decl () = compute_decl env decl in + let update_decl decl immediacy = { decl with type_immediate = immediacy } in + let check _env _id decl () = + let written_by_user = Type_immediacy.of_attributes decl.type_attributes in + match Type_immediacy.coerce decl.type_immediate ~as_:written_by_user with + | Ok () -> () + | Error violation -> + raise (Error (decl.type_loc, + Bad_immediacy_attribute violation)) + in + { + eq; + merge; + default; + compute; + update_decl; + check; + } + +let update_decls env decls = + Typedecl_properties.compute_property_noreq property env decls diff --git a/upstream/ocaml_503/typing/typedecl_immediacy.mli b/upstream/ocaml_503/typing/typedecl_immediacy.mli new file mode 100644 index 000000000..17fb985c8 --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_immediacy.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type error = Bad_immediacy_attribute of Type_immediacy.Violation.t +exception Error of Location.t * error + +val compute_decl : Env.t -> Types.type_declaration -> Type_immediacy.t + +val property : (Type_immediacy.t, unit) Typedecl_properties.property + +val update_decls : + Env.t -> + (Ident.t * Typedecl_properties.decl) list -> + (Ident.t * Typedecl_properties.decl) list diff --git a/upstream/ocaml_503/typing/typedecl_properties.ml b/upstream/ocaml_503/typing/typedecl_properties.ml new file mode 100644 index 000000000..28a1bb667 --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_properties.ml @@ -0,0 +1,73 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type decl = Types.type_declaration + +type ('prop, 'req) property = { + eq : 'prop -> 'prop -> bool; + merge : prop:'prop -> new_prop:'prop -> 'prop; + + default : decl -> 'prop; + compute : Env.t -> decl -> 'req -> 'prop; + update_decl : decl -> 'prop -> decl; + + check : Env.t -> Ident.t -> decl -> 'req -> unit; +} + +let add_type ~check id decl env = + let open Types in + Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes + (fun () -> Env.add_type ~check id decl env) + +let add_types_to_env decls env = + List.fold_right + (fun (id, decl) env -> add_type ~check:true id decl env) + decls env + +let compute_property +: ('prop, 'req) property -> Env.t -> + (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list += fun property env decls required -> + (* [decls] and [required] must be lists of the same size, + with [required] containing the requirement for the corresponding + declaration in [decls]. *) + let props = List.map (fun (_id, decl) -> property.default decl) decls in + let rec compute_fixpoint props = + let new_decls = + List.map2 (fun (id, decl) prop -> + (id, property.update_decl decl prop)) + decls props in + let new_env = add_types_to_env new_decls env in + let new_props = + List.map2 + (fun (_id, decl) (prop, req) -> + let new_prop = property.compute new_env decl req in + property.merge ~prop ~new_prop) + new_decls (List.combine props required) in + if not (List.for_all2 property.eq props new_props) + then compute_fixpoint new_props + else begin + List.iter2 + (fun (id, decl) req -> property.check new_env id decl req) + new_decls required; + new_decls + end + in + compute_fixpoint props + +let compute_property_noreq property env decls = + let req = List.map (fun _ -> ()) decls in + compute_property property env decls req diff --git a/upstream/ocaml_503/typing/typedecl_properties.mli b/upstream/ocaml_503/typing/typedecl_properties.mli new file mode 100644 index 000000000..153c3f719 --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_properties.mli @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type decl = Types.type_declaration + +(** An abstract interface for properties of type definitions, such as + variance and immediacy, that are computed by a fixpoint on + mutually-recursive type declarations. This interface contains all + the operations needed to initialize and run the fixpoint + computation, and then (optionally) check that the result is + consistent with the declaration or user expectations. *) + +type ('prop, 'req) property = { + eq : 'prop -> 'prop -> bool; + merge : prop:'prop -> new_prop:'prop -> 'prop; + + default : decl -> 'prop; + compute : Env.t -> decl -> 'req -> 'prop; + update_decl : decl -> 'prop -> decl; + + check : Env.t -> Ident.t -> decl -> 'req -> unit; +} +(** ['prop] represents the type of property values + ({!Types.Variance.t}, just 'bool' for immediacy, etc). + + ['req] represents the property value required by the author of the + declaration, if they gave an expectation: [type +'a t = ...]. + + Some properties have no natural notion of user requirement, or + their requirement is global, or already stored in + [type_declaration]; they can just use [unit] as ['req] parameter. *) + + +(** [compute_property prop env decls req] performs a fixpoint computation + to determine the final values of a property on a set of mutually-recursive + type declarations. The [req] argument must be a list of the same size as + [decls], providing the user requirement for each declaration. *) +val compute_property : ('prop, 'req) property -> Env.t -> + (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list + +val compute_property_noreq : ('prop, unit) property -> Env.t -> + (Ident.t * decl) list -> (Ident.t * decl) list diff --git a/upstream/ocaml_503/typing/typedecl_separability.ml b/upstream/ocaml_503/typing/typedecl_separability.ml new file mode 100644 index 000000000..c8f2f3b17 --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_separability.ml @@ -0,0 +1,668 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +type type_definition = type_declaration +(* We should use 'declaration' for interfaces, and 'definition' for + implementations. The name type_declaration in types.ml is improper + for our usage -- although for OCaml types the declaration and + definition languages are the same. *) + +(** assuming that a datatype has a single constructor/label with + a single argument, [argument_to_unbox] represents the + information we need to check the argument for separability. *) +type argument_to_unbox = { + argument_type: type_expr; + result_type_parameter_instances: type_expr list; + (** result_type_parameter_instances represents the domain of the + constructor; usually it is just a list of the datatype parameter + ('a, 'b, ...), but when using GADTs or constraints it could + contain arbitrary type expressions. + + For example, [type 'a t = 'b constraint 'a = 'b * int] has + [['b * int]] as [result_type_parameter_instances], and so does + [type _ t = T : 'b -> ('b * int) t]. *) +} + +(** Summarize the right-hand-side of a type declaration, + for separability-checking purposes. See {!structure} below. *) +type type_structure = + | Synonym of type_expr + | Abstract + | Open + | Algebraic + | Unboxed of argument_to_unbox + +let structure : type_definition -> type_structure = fun def -> + match def.type_kind with + | Type_open -> Open + | Type_abstract _ -> + begin match def.type_manifest with + | None -> Abstract + | Some type_expr -> Synonym type_expr + end + + | ( Type_record ([{ld_type = ty; _}], Record_unboxed _) + | Type_variant ([{cd_args = Cstr_tuple [ty]; _}], Variant_unboxed) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty; _}]; _}], + Variant_unboxed)) -> + let params = + match def.type_kind with + | Type_variant ([{cd_res = Some ret_type}], _) -> + begin match get_desc ret_type with + | Tconstr (_, tyl, _) -> tyl + | _ -> assert false + end + | _ -> def.type_params + in + Unboxed { argument_type = ty; result_type_parameter_instances = params } + + | Type_record _ | Type_variant _ -> Algebraic + +type error = + | Non_separable_evar of string option + +exception Error of Location.t * error + +(* see the .mli file for explanations on the modes *) +module Sep = Types.Separability +type mode = Sep.t = Ind | Sep | Deepsep + +let rank = Sep.rank +let max_mode = Sep.max + +(** If the type context [e(_)] imposes the mode [m] on its hole [_], + and the type context [e'(_)] imposes the mode [m'] on its hole [_], + then the mode on [_] imposed by the context composition [e(e'(_))] + is [compose m m']. + + This operation differs from [max_mode]: [max_mode Ind Sep] is [Sep], + but [compose Ind Sep] is [Ind]. *) +let compose + : mode -> mode -> mode + = fun m1 m2 -> + match m1 with + | Deepsep -> Deepsep + | Sep -> m2 + | Ind -> Ind + +type type_var = { + text: string option; (** the user name of the type variable, None for '_' *) + id: int; (** the identifier of the type node (type_expr.id) of the variable *) +} + +module TVarMap = Map.Make(struct + type t = type_var + let compare v1 v2 = compare v1.id v2.id + end) +type context = mode TVarMap.t +let (++) = TVarMap.union (fun _ m1 m2 -> Some(max_mode m1 m2)) +let empty = TVarMap.empty + + +(** [immediate_subtypes ty] returns the list of all the + immediate sub-type-expressions of [ty]. They represent the biggest + sub-components that may be extracted using a constraint. For + example, the immediate sub-type-expressions of [int * (bool * 'a)] + are [int] and [bool * 'a]. + + Smaller components are extracted recursively in [check_type]. *) +let rec immediate_subtypes : type_expr -> type_expr list = fun ty -> + (* Note: Btype.fold_type_expr is not suitable here: + - it does not do the right thing on Tpoly, iterating on type + parameters as well as the subtype + - it performs a shallow traversal of object types, + while our implementation collects all method types *) + match get_desc ty with + (* these are the important cases, + on which immediate_subtypes is called from [check_type] *) + | Tarrow(_,ty1,ty2,_) -> + [ty1; ty2] + | Ttuple(tys) -> tys + | Tpackage(_, fl) -> (snd (List.split fl)) + | Tobject(row,class_ty) -> + let class_subtys = + match !class_ty with + | None -> [] + | Some(_,tys) -> tys + in + immediate_subtypes_object_row class_subtys row + | Tvariant(row) -> + immediate_subtypes_variant_row [] row + + (* the cases below are not called from [check_type], + they are here for completeness *) + | Tnil | Tfield _ -> + (* these should only occur under Tobject and not at the toplevel, + but "better safe than sorry" *) + immediate_subtypes_object_row [] ty + | Tlink _ | Tsubst _ -> assert false (* impossible due to Ctype.repr *) + | Tvar _ | Tunivar _ -> [] + | Tpoly (pty, _) -> [pty] + | Tconstr (_path, tys, _) -> tys + +and immediate_subtypes_object_row acc ty = match get_desc ty with + | Tnil -> acc + | Tfield (_label, _kind, ty, rest) -> + let acc = ty :: acc in + immediate_subtypes_object_row acc rest + | _ -> ty :: acc + +and immediate_subtypes_variant_row acc desc = + let add_subtypes acc = + let add_subtype acc (_l, rf) = + immediate_subtypes_variant_row_field acc rf in + List.fold_left add_subtype acc (row_fields desc) in + let add_row acc = + let row = row_more desc in + match get_desc row with + | Tvariant more -> immediate_subtypes_variant_row acc more + | _ -> row :: acc + in + add_row (add_subtypes acc) + +and immediate_subtypes_variant_row_field acc f = + match row_field_repr f with + | Rpresent(None) + | Rabsent -> acc + | Rpresent(Some(ty)) -> ty :: acc + | Reither(_,field_types,_) -> + List.rev_append field_types acc + +let free_variables ty = + Ctype.free_variables ty + |> List.map (fun ty -> + match get_desc ty with + Tvar text -> {text; id = get_id ty} + | _ -> + (* Ctype.free_variables only returns Tvar nodes *) + assert false) + +(** Coinductive hypotheses to handle equi-recursive types + + OCaml allows infinite/cyclic types, such as + (int * 'a) as 'a + whose infinite unfolding is (int * (int * (int * (int * ...)))). + + Remark: this specific type is only accepted if the -rectypes option + is passed, but such "equi-recursive types" are accepted by + default if the cycle goes through an object type or polymorphic + variant type: + [ `int | `other of 'a ] as 'a + < head : int; rest : 'a > as 'a + + We have to take those infinite types in account in our + separability-checking program: a naive implementation would loop + infinitely when trying to prove that one of them is Deepsep. + + After type-checking, the cycle-introducing form (... as 'a) does + not appear explicitly in the syntax of types: types are graphs/trees + with cycles in them, and we have to use the type_expr.id field, + an identifier for each node in the graph/tree, to detect cycles. + + We avoid looping by remembering the set of separability queries + that we have already asked ourselves (in the current + search branch). For example, if we are asked to check + + (int * 'a) : Deepsep + + our algorithm will check both (int : Deepsep) and ('a : Deepsep), + but it will remember in these sub-checks that it is in the process + of checking (int * 'a) : Deepsep, adding it to a list of "active + goals", or "coinductive hypotheses". + + Each new sub-query will start by checking whether the query + already appears as a coinductive hypothesis; in our example, this + can happen if 'a and (int * 'a) are in fact the same node in the + cyclic tree. In that case, we return immediately (instead of looping): + we reason that, assuming that 'a is indeed Deepsep, then it is + the case that (int * 'a) is also Deepsep. + + This kind of cyclic reasoning can be dangerous: it would be wrong + to argue that an arbitrary 'a type is Deepsep by saying: + "assuming that 'a is Deepsep, then it is the case that 'a is + also Deepsep". In the first case, we made an assumption on 'a, + and used it on a type (int * 'a) which has 'a as a strict sub-component; + in the second, we use it on the same type 'a directly, which is invalid. + + Now consider a type of the form (('a t) as 'a): while 'a is a sub-component + of ('a t), it may still be wrong to reason coinductively about it, + as ('a t) may be defined as (type 'a t = 'a). + + When moving from (int * 'a) to a subcomponent (int) or ('a), we + say that the coinductive hypothesis on (int * 'a : m) is "safe": + it can be used immediately to prove the subcomponents, because we + made progress moving to a strict subcomponent (we are guarded + under a computational type constructor). On the other hand, when + moving from ('a t) to ('a), we say that the coinductive hypothesis + ('a t : m) is "unsafe" for the subgoal, as we don't know whether + we have made strict progress. In the general case, we keep track + of a set of safe and unsafe hypotheses made in the past, and we + use them to terminate checking if we encounter them again, + ensuring termination. + + If we encounter a (ty : m) goal that is exactly a safe hypothesis, + we terminate with a success. In fact, we can use mode subtyping here: + if (ty : m') appears as a hypothesis with (m' >= m), then we would + succeed for (ty : m'), so (ty : m) should succeed as well. + + On the other hand, if we encounter a (ty : m) goal that is an + *unsafe* hypothesis, we terminate the check with a failure. In this case, + we cannot work modulo mode subtyping: if (ty : m') appears with + (m' >= m), then the check (ty : m') would have failed, but it is still + possible that the weaker current query (ty : m) would succeed. + + In usual coinductive-reasoning systems, unsafe hypotheses are turned + into safe hypotheses each time strict progress is made (for each + guarded sub-goal). Consider ((int * 'a) t as 'a : deepsep) for example: + the idea is that the ((int * 'a) t : deepsep) hypothesis would be + unsafe when checking ((int * 'a) : deepsep), but that the progress + step from (int * 'a : deepsep) to ('a : deepsep) would turn all + past unsafe hypotheses into safe hypotheses. There is a problem + with this, though, due to constraints: what if (_ t) is defined as + + type 'b t = 'a constraint 'b = (int * 'a) + + ? + + In that case, then 'a is precisely the one-step unfolding + of the ((int * 'a) t) definition, and it would be an invalid, + cyclic reasoning to prove ('a : deepsep) from the now-safe + hypothesis ((int * 'a) t : deepsep). + + Surprisingly-fortunately, we have exactly the information we need + to know whether (_ t) may or may not pull a constraint trick of + this nature: we can look at its mode signature, where constraints + are marked by a Deepsep mode. If we see Deepsep, we know that a + constraint exists, but we don't know what the constraint is: + we cannot tell at which point, when decomposing the parameter type, + a sub-component can be considered safe again. To model this, + we add a third category of co-inductive hypotheses: to "safe" and + "unsafe" we add the category of "poison" hypotheses, which remain + poisonous during the remaining of the type decomposition, + even in presence of safe, computational types constructors: + + - when going under a computational constructor, + "unsafe" hypotheses become "safe" + - when going under a constraining type (more precisely, under + a type parameter that is marked Deepsep in the mode signature), + "unsafe" hypotheses become "poison" + + The mode signature tells us even a bit more: if a parameter + is marked "Ind", we know that the type constructor cannot unfold + to this parameter (otherwise it would be Sep), so going under + this parameter can be considered a safe/guarded move: if + we have to check (foo t : m) with ((_ : Ind) t) in the signature, + we can recursively check (foo : Ind) with (foo t : m) marked + as "safe", rather than "unsafe". +*) +module TypeMap = Btype.TypeMap +module ModeSet = Set.Make(Types.Separability) + +type coinductive_hyps = { + safe: ModeSet.t TypeMap.t; + unsafe: ModeSet.t TypeMap.t; + poison: ModeSet.t TypeMap.t; +} + +module Hyps : sig + type t = coinductive_hyps + val empty : t + val add : type_expr -> mode -> t -> t + val guard : t -> t + val poison : t -> t + val safe : type_expr -> mode -> t -> bool + val unsafe : type_expr -> mode -> t -> bool +end = struct + type t = coinductive_hyps + + let empty = { + safe = TypeMap.empty; + unsafe = TypeMap.empty; + poison = TypeMap.empty; + } + + let of_opt = function + | Some ms -> ms + | None -> ModeSet.empty + + let merge map1 map2 = + TypeMap.merge (fun _k ms1 ms2 -> + Some (ModeSet.union (of_opt ms1) (of_opt ms2)) + ) map1 map2 + + let guard {safe; unsafe; poison;} = { + safe = merge safe unsafe; + unsafe = TypeMap.empty; + poison; + } + + let poison {safe; unsafe; poison;} = { + safe; + unsafe = TypeMap.empty; + poison = merge poison unsafe; + } + + let add ty m hyps = + let m_map = TypeMap.singleton ty (ModeSet.singleton m) in + { hyps with unsafe = merge m_map hyps.unsafe; } + + let find ty map = try TypeMap.find ty map with Not_found -> ModeSet.empty + + let safe ty m hyps = + match ModeSet.max_elt_opt (find ty hyps.safe) with + | None -> false + | Some best_safe -> rank best_safe >= rank m + + let unsafe ty m {safe = _; unsafe; poison} = + let in_map s = ModeSet.mem m (find ty s) in + List.exists in_map [unsafe; poison] +end + +(** For a type expression [ty] (without constraints and existentials), + any mode checking [ty : m] is satisfied in the "worse case" context + that maps all free variables of [ty] to the most demanding mode, + Deepsep. *) +let worst_case ty = + let add ctx tvar = TVarMap.add tvar Deepsep ctx in + List.fold_left add TVarMap.empty (free_variables ty) + + +(** [check_type env sigma ty m] returns the most permissive context [gamma] + such that [ty] is separable at mode [m] in [gamma], under + the signature [sigma]. *) +let check_type + : Env.t -> type_expr -> mode -> context + = fun env ty m -> + let rec check_type hyps ty m = + if Hyps.safe ty m hyps then empty + else if Hyps.unsafe ty m hyps then worst_case ty + else + let hyps = Hyps.add ty m hyps in + match (get_desc ty, m) with + (* Impossible case due to the call to [Ctype.repr]. *) + | (Tlink _ , _ ) -> assert false + (* Impossible case (according to comment in [typing/types.mli]. *) + | (Tsubst(_) , _ ) -> assert false + (* "Indifferent" case, the empty context is sufficient. *) + | (_ , Ind ) -> empty + (* Variable case, add constraint. *) + | (Tvar(alpha) , m ) -> + TVarMap.singleton {text = alpha; id = get_id ty} m + (* "Separable" case for constructors with known memory representation. *) + | (Tarrow _ , Sep ) + | (Ttuple _ , Sep ) + | (Tvariant(_) , Sep ) + | (Tobject(_,_) , Sep ) + | ((Tnil | Tfield _) , Sep ) + | (Tpackage(_,_) , Sep ) -> empty + (* "Deeply separable" case for these same constructors. *) + | (Tarrow _ , Deepsep) + | (Ttuple _ , Deepsep) + | (Tvariant(_) , Deepsep) + | (Tobject(_,_) , Deepsep) + | ((Tnil | Tfield _) , Deepsep) + | (Tpackage(_,_) , Deepsep) -> + let tys = immediate_subtypes ty in + let on_subtype context ty = + context ++ check_type (Hyps.guard hyps) ty Deepsep in + List.fold_left on_subtype empty tys + (* Polymorphic type, and corresponding polymorphic variable. + + In theory, [Tpoly] (forall alpha. tau) would add a new variable + (alpha) in scope, check its body (tau) recursively, and then + remove the new variable from the resulting context. Because the + rule accepts any mode for this variable, the removal never + fails. + + In practice the implementation is simplified by ignoring the + new variable, and always returning the [empty] context + (instead of (alpha : m) in the [Tunivar] case: the constraint + on the variable is removed/ignored at the variable occurrence + site, rather than at the variable-introduction site. *) + (* Note: that we are semantically incomplete in the Deepsep case + (following the syntactic typing rules): the semantics only + requires that *closed* sub-type-expressions be (deeply) + separable; sub-type-expressions containing the quantified + variable cannot be extracted by constraints (this would be + a scope violation), so they could be ignored if they occur + under a separating type constructor. *) + | (Tpoly(pty,_) , m ) -> + check_type hyps pty m + | (Tunivar(_) , _ ) -> empty + (* Type constructor case. *) + | (Tconstr(path,tys,_), m ) -> + let msig = (Env.find_type path env).type_separability in + let on_param context (ty, m_param) = + let hyps = match m_param with + | Ind -> Hyps.guard hyps + | Sep -> hyps + | Deepsep -> Hyps.poison hyps in + context ++ check_type hyps ty (compose m m_param) in + List.fold_left on_param empty (List.combine tys msig) + in + check_type Hyps.empty ty m + +let best_msig decl = List.map (fun _ -> Ind) decl.type_params +let worst_msig decl = List.map (fun _ -> Deepsep) decl.type_params + +(** [msig_of_external_type decl] infers the mode signature of an + abstract/external type. We must assume the worst, namely that this + type may be defined as an unboxed algebraic datatype imposing deep + separability of its parameters. + + One exception is when the type is marked "immediate", which + guarantees that its representation is only integers. Immediate + types are always separable, so [Ind] suffices for their + parameters. + + Note: this differs from {!Types.Separability.default_signature}, + which does not have access to the declaration and its immediacy. *) +let msig_of_external_type decl = + match decl.type_immediate with + | Always | Always_on_64bits -> best_msig decl + | Unknown -> worst_msig decl + +(** [msig_of_context ~decl_loc constructor context] returns the + separability signature of a single-constructor type whose + definition is valid in the mode context [context]. + + Note: A GADT constructor introduces existential type variables, and + may also introduce some equalities between its return type + parameters and type expressions containing universal and + existential variables. In other words, it introduces new type + variables in scope, and restricts existing variables by adding + equality constraints. + + [msig_of_context] performs the reverse transformation: the context + [ctx] computed from the argument of the constructor mentions + existential variables, and the function returns a context over the + (universal) type parameters only. (Type constraints do not + introduce existential variables, but they do introduce equalities; + they are handled as GADTs equalities by this function.) + + The transformation is separability-preserving in the following + sense: for any valid instance of the result mode signature + (replacing the universal type parameters with ground types + respecting the variable's separability mode), any possible + extension of this context instance with ground instances for the + existential variables of [parameter] that respects the equation + constraints will validate the separability requirements of the + modes in the input context [ctx]. + + Sometimes no such universal context exists, as an existential type + cannot be safely introduced, then this function raises an [Error] + exception with a [Non_separable_evar] payload. *) +let msig_of_context : decl_loc:Location.t -> parameters:type_expr list + -> context -> Sep.signature = + fun ~decl_loc ~parameters context -> + let handle_equation (acc, context) param_instance = + (* In the theory, GADT equations are of the form + ('a = ) + for each type parameter 'a of the type constructor. For each + such equation, we should "strengthen" the current context in + the following way: + - if is another variable 'b, + the mode of 'a is set to the mode of 'b, + and 'b is set to Ind + - if is a type expression whose variables are all Ind, + set 'a to Ind and discard the equation + - otherwise (one of the variable of 'b is not Ind), + set 'a to Deepsep and set all variables of to Ind + + In practice, type parameters are determined by their position + in a list, they do not necessarily have a corresponding type variable. + Instead of "setting 'a" in the context as in the description above, + we build a list of modes by repeated consing into + an accumulator variable [acc], setting existential variables + to Ind as we go. *) + let get context var = + try TVarMap.find var context with Not_found -> Ind in + let set_ind context var = + TVarMap.add var Ind context in + let is_ind context var = match get context var with + | Ind -> true + | Sep | Deepsep -> false in + match get_desc param_instance with + | Tvar text -> + let var = {text; id = get_id param_instance} in + (get context var) :: acc, (set_ind context var) + | _ -> + let instance_exis = free_variables param_instance in + if List.for_all (is_ind context) instance_exis then + Ind :: acc, context + else + Deepsep :: acc, List.fold_left set_ind context instance_exis + in + let mode_signature, context = + let (mode_signature_rev, ctx) = + List.fold_left handle_equation ([], context) parameters in + (* Note: our inference system is not principal, because the + inference result depends on the order in which those + equations are processed. (To our knowledge this is the only + source of non-principality.) If two parameters ('a, 'b) are + forced to be equal to each other, and also separable, then + either modes (Sep, Ind) and (Ind, Sep) are correct, allow + more declarations than (Sep, Sep), but (Ind, Ind) would be + unsound. + + Such a non-principal example is the following: + + type ('a, 'b) almost_eq = + | Almost_refl : 'c -> ('c, 'c) almost_eq + + (This example looks strange: GADT equations are typically + either on only one parameter, or on two parameters that are + not used to classify constructor arguments. Indeed, we have + not found non-principal declarations in real-world code.) + + In a non-principal system, it is important the our choice of + non-unique solution be at least predictable. We find it more + natural, when either ('a : Sep, 'b : Ind) and ('a : Ind, + 'b : Sep) are correct because 'a = 'b, to choose to make the + first/leftmost parameter more constrained. We read this as + saying that 'a must be Sep, and 'b = 'a so 'b can be + Ind. (We define the second parameter as equal of the first, + already-seen parameter; instead of saying that the first + parameter is equal to the not-yet-seen second one.) + + This is achieved by processing the equations from left to + right with List.fold_left, instead of using + List.fold_right. The code is slightly more awkward as it + needs a List.rev on the accumulated modes, but it gives + a more predictable/natural (non-principal) behavior. + *) + (List.rev mode_signature_rev, ctx) in + (* After all variables determined by the parameters have been set to Ind + by [handle_equation], all variables remaining in the context are + purely existential and should not require a stronger mode than Ind. *) + let check_existential evar mode = + if rank mode > rank Ind then + raise (Error (decl_loc, Non_separable_evar evar.text)) + in + TVarMap.iter check_existential context; + mode_signature + +(** [check_def env def] returns the signature required + for the type definition [def] in the typing environment [env]. + + The exception [Error] is raised if we discover that + no such signature exists -- the definition will always be invalid. + This only happens when the definition is marked to be unboxed. *) + +let check_def + : Env.t -> type_definition -> Sep.signature + = fun env def -> + match structure def with + | Abstract -> + msig_of_external_type def + | Synonym type_expr -> + check_type env type_expr Sep + |> msig_of_context ~decl_loc:def.type_loc ~parameters:def.type_params + | Open | Algebraic -> + best_msig def + | Unboxed constructor -> + check_type env constructor.argument_type Sep + |> msig_of_context ~decl_loc:def.type_loc + ~parameters:constructor.result_type_parameter_instances + +let compute_decl env decl = + if Config.flat_float_array then check_def env decl + else + (* Hack: in -no-flat-float-array mode, instead of always returning + [best_msig], we first compute the separability signature -- + falling back to [best_msig] if it fails. + + This discipline is conservative: it never + rejects -no-flat-float-array programs. At the same time it + guarantees that, for any program that is also accepted + in -flat-float-array mode, the same separability will be + inferred in the two modes. In particular, the same .cmi files + and digests will be produced. + + Before we introduced this hack, the production of different + .cmi files would break the build system of the compiler itself, + when trying to build a -no-flat-float-array system from + a bootstrap compiler itself using -flat-float-array. See #9291. + *) + try check_def env decl with + | Error _ -> + (* It could be nice to emit a warning here, so that users know + that their definition would be rejected in -flat-float-array mode *) + best_msig decl + +(** Separability as a generic property *) +type prop = Types.Separability.signature + +let property : (prop, unit) Typedecl_properties.property = + let open Typedecl_properties in + let eq ts1 ts2 = + List.length ts1 = List.length ts2 + && List.for_all2 Sep.eq ts1 ts2 in + let merge ~prop:_ ~new_prop = + (* the update function is monotonous: ~new_prop is always + more informative than ~prop, which can be ignored *) + new_prop in + let default decl = best_msig decl in + let compute env decl () = compute_decl env decl in + let update_decl decl type_separability = { decl with type_separability } in + let check _env _id _decl () = () in (* FIXME run final check? *) + { eq; merge; default; compute; update_decl; check; } + +(* Definition using the fixpoint infrastructure. *) +let update_decls env decls = + Typedecl_properties.compute_property_noreq property env decls diff --git a/upstream/ocaml_503/typing/typedecl_separability.mli b/upstream/ocaml_503/typing/typedecl_separability.mli new file mode 100644 index 000000000..079e64080 --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_separability.mli @@ -0,0 +1,132 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** The OCaml runtime assumes for type-directed optimizations that all types + are "separable". A type is "separable" if either all its inhabitants + (the values of this type) are floating-point numbers, or none of them are. + + (Note: This assumption is required for the dynamic float array optimization; + it is only made if Config.flat_float_array is set, + otherwise the code in this module becomes trivial + -- see {!compute_decl}.) + + This soundness requirement could be broken by type declarations mixing + existentials and the "[@@unboxed]" annotation. Consider the declaration + + {[ + type any = Any : 'a -> any [@@unboxed] + ]} + + which corresponds to the existential type "exists a. a". If this type is + allowed to be unboxed, then it is inhabited by both [float] values + and non-[float] values. On the contrary, if unboxing is disallowed, the + inhabitants are all blocks with the [Any] constructors pointing to its + parameter: they may point to a float, but they are not floats. + + The present module contains a static analysis ensuring that declarations + annotated with "[@@unboxed]" can be safely unboxed. The idea is to check + the "separability" (in the above sense) of the argument type that would + be unboxed, and reject the unboxed declaration if it would create a + non-separable type. + + Checking mutually-recursive type declarations is a bit subtle. + Consider, for example, the following declarations. + + {[ + type foo = Foo : 'a t -> foo [@@unboxed] + and 'a t = ... + ]} + + Deciding whether the type [foo] should be accepted requires inspecting + the declaration of ['a t], which may itself refer to [foo] in turn. + In general, the analysis performs a fixpoint computation. It is somewhat + similar to what is done for inferring the variance of type parameters. + + Our analysis is defined using inference rules for our judgment + [Def; Gamma |- t : m], in which a type expression [t] is checked + against a "mode" [m]. This "mode" describes the separability + requirement on the type expression (see below for + more details). The mode [Gamma] maps type variables to modes and + [Def] records the "mode signature" of the mutually-recursive type + declarations that are being checked. + + The "mode signature" of a type with parameters [('a, 'b) t] is of the + form [('a : m1, 'b : m2) t], where [m1] and [m2] are modes. Its meaning + is the following: a concrete instance [(foo, bar) t] of the type is + separable if [foo] has mode [m1] and [bar] has mode [m2]. *) + +type error = + | Non_separable_evar of string option +exception Error of Location.t * error +(** Exception raised when a type declaration is not separable, or when its + separability cannot be established. *) + +type mode = Types.Separability.t = Ind | Sep | Deepsep +(** The mode [Sep] ("separable") characterizes types that are indeed separable: + either they only contain floating-point values, or none of the values + at this type are floating-point values. + On a type parameter, it indicates that this parameter must be + separable for the whole type definition to be separable. For + example, the mode signature for the type declaration [type 'a + t = 'a] is [('a : Sep) t]. For the right-hand side to be + separable, the parameter ['a] must be separable. + + The mode [Ind] ("indifferent") characterizes any type -- separable + or not. + On a type parameter, it indicates that this parameter needs not be + separable for the whole type definition to be separable. For + example, [type 'a t = 'a * bool] does not require its parameter + ['a] to be separable as ['a * bool] can never contain [float] + values. Its mode signature is thus [('a : Ind) t]. + + Finally, the mode [Deepsep] ("deeply separable") characterizes + types that are separable, and whose type sub-expressions are also + separable. This advanced feature is only used in the presence of + constraints. + For example, [type 'a t = 'b constraint 'a = 'b * bool] + may not be separable even if ['a] is (its separately depends on 'b, + a fragment of 'a), so its mode signature is [('a : Deepsep) t]. + + The different modes are ordered as [Ind < Sep < Deepsep] (from the least + demanding to the most demanding). *) + +val compute_decl : Env.t -> Types.type_declaration -> mode list +(** [compute_decl env def] returns the signature required + for the type definition [def] in the typing environment [env] + -- including signatures for the current recursive block. + + The {!Error} exception is raised if no such signature exists + -- the definition will always be invalid. This only happens + when the definition is marked to be unboxed. + + Variant (or record) declarations that are not marked with the + "[@@unboxed]" annotation, including those that contain several variants + (or labels), are always separable. In particular, their mode signatures + do not require anything of their type parameters, which are marked [Ind]. + + Finally, if {!Config.flat_float_array} is not set, then separability + is not required anymore; we just use [Ind] as the mode of each parameter + without any check. +*) + +(** Property interface (see {!Typedecl_properties}). These functions + rely on {!compute_decl} and raise the {!Error} exception on error. *) +type prop = Types.Separability.signature +val property : (prop, unit) Typedecl_properties.property +val update_decls : + Env.t -> + (Ident.t * Typedecl_properties.decl) list -> + (Ident.t * Typedecl_properties.decl) list diff --git a/upstream/ocaml_503/typing/typedecl_unboxed.ml b/upstream/ocaml_503/typing/typedecl_unboxed.ml new file mode 100644 index 000000000..16290f0fb --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_unboxed.ml @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +(* We use the Ctype.expand_head_opt version of expand_head to get access + to the manifest type of private abbreviations. *) +let rec get_unboxed_type_representation env ty fuel = + if fuel < 0 then None else + let ty = Ctype.expand_head_opt env ty in + match get_desc ty with + | Tconstr (p, args, _) -> + begin match Env.find_type p env with + | exception Not_found -> Some ty + | {type_params; type_kind = + Type_record ([{ld_type = ty2; _}], Record_unboxed _) + | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], Variant_unboxed) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], + Variant_unboxed)} + -> + let ty2 = match get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in + get_unboxed_type_representation env + (Ctype.apply env type_params ty2 args) (fuel - 1) + | _ -> Some ty + end + | _ -> Some ty + +let get_unboxed_type_representation env ty = + (* Do not give too much fuel: PR#7424 *) + get_unboxed_type_representation env ty 100 diff --git a/upstream/ocaml_503/typing/typedecl_unboxed.mli b/upstream/ocaml_503/typing/typedecl_unboxed.mli new file mode 100644 index 000000000..9e860dc12 --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_unboxed.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +(* for typeopt.ml *) +val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option diff --git a/upstream/ocaml_503/typing/typedecl_variance.ml b/upstream/ocaml_503/typing/typedecl_variance.ml new file mode 100644 index 000000000..c384e8c46 --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_variance.ml @@ -0,0 +1,437 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Types + +module TypeSet = Btype.TypeSet +module TypeMap = Btype.TypeMap + +type surface_variance = bool * bool * bool + +type variance_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + +type variance_error = + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } + +type error = + | Bad_variance of variance_error * surface_variance * surface_variance + | Varying_anonymous + + +exception Error of Location.t * error + +(* Compute variance *) + +let get_variance ty visited = + try TypeMap.find ty !visited with Not_found -> Variance.null + +let compute_variance env visited vari ty = + let rec compute_variance_rec vari ty = + (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *) + let vari' = get_variance ty visited in + if Variance.subset vari vari' then () else + let vari = Variance.union vari vari' in + visited := TypeMap.add ty vari !visited; + let compute_same = compute_variance_rec vari in + match get_desc ty with + Tarrow (_, ty1, ty2, _) -> + compute_variance_rec (Variance.conjugate vari) ty1; + compute_same ty2 + | Ttuple tl -> + List.iter compute_same tl + | Tconstr (path, tl, _) -> + let open Variance in + if tl = [] then () else begin + try + let decl = Env.find_type path env in + List.iter2 + (fun ty v -> compute_variance_rec (compose vari v) ty) + tl decl.type_variance + with Not_found -> + List.iter (compute_variance_rec unknown) tl + end + | Tobject (ty, _) -> + compute_same ty + | Tfield (_, _, ty1, ty2) -> + compute_same ty1; + compute_same ty2 + | Tsubst _ -> + assert false + | Tvariant row -> + List.iter + (fun (_,f) -> + match row_field_repr f with + Rpresent (Some ty) -> + compute_same ty + | Reither (_, tyl, _) -> + let v = Variance.(inter vari unknown) in (* cf PR#7269 *) + List.iter (compute_variance_rec v) tyl + | _ -> ()) + (row_fields row); + compute_same (row_more row) + | Tpoly (ty, _) -> + compute_same ty + | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () + | Tpackage (_, fl) -> + let v = Variance.(compose vari full) in + List.iter (fun (_, ty) -> compute_variance_rec v ty) fl + in + compute_variance_rec vari ty + +let make p n i = + let open Variance in + set_if p May_pos (set_if n May_neg (set_if i Inj null)) + +let injective = Variance.(set Inj null) + +let compute_variance_type env ~check (required, loc) decl tyl = + (* Requirements *) + let check_injectivity = Btype.type_kind_is_abstract decl in + let required = + List.map + (fun (c,n,i) -> + let i = if check_injectivity then i else false in + if c || n then (c,n,i) else (true,true,i)) + required + in + (* Prepare *) + let params = decl.type_params in + let tvl = ref TypeMap.empty in + (* Compute occurrences in the body *) + let open Variance in + List.iter + (fun (cn,ty) -> + compute_variance env tvl (if cn then full else covariant) ty) + tyl; + (* Infer injectivity of constrained parameters *) + if check_injectivity then + List.iter + (fun ty -> + if Btype.is_Tvar ty || mem Inj (get_variance ty tvl) then () else + let visited = ref TypeSet.empty in + let rec check ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + if mem Inj (get_variance ty tvl) then () else + match get_desc ty with + | Tvar _ -> raise Exit + | Tconstr _ -> + let old = !visited in + begin try + Btype.iter_type_expr check ty + with Exit -> + visited := old; + let ty' = Ctype.expand_head_opt env ty in + if eq_type ty ty' then raise Exit else check ty' + end + | _ -> Btype.iter_type_expr check ty + end + in + try check ty; compute_variance env tvl injective ty + with Exit -> ()) + params; + begin match check with + | None -> () + | Some context -> + (* Check variance of parameters *) + let pos = ref 0 in + List.iter2 + (fun ty (c, n, i) -> + incr pos; + let var = get_variance ty tvl in + let (co,cn) = get_upper var and ij = mem Inj var in + if Btype.is_Tvar ty && (co && not c || cn && not n) || not ij && i + then raise (Error(loc, Bad_variance + (Variance_not_satisfied !pos, + (co,cn,ij), + (c,n,i))))) + params required; + (* Check propagation from constrained parameters *) + let args = Btype.newgenty (Ttuple params) in + let fvl = Ctype.free_variables args in + let fvl = + List.filter (fun v -> not (List.exists (eq_type v) params)) fvl in + (* If there are no extra variables there is nothing to do *) + if fvl = [] then () else + let tvl2 = ref TypeMap.empty in + List.iter2 + (fun ty (p,n,_) -> + if Btype.is_Tvar ty then () else + let v = + if p then if n then full else covariant else conjugate covariant in + compute_variance env tvl2 v ty) + params required; + let visited = ref TypeSet.empty in + let rec check ty = + if TypeSet.mem ty !visited then () else + let visited' = TypeSet.add ty !visited in + visited := visited'; + let v1 = get_variance ty tvl in + let snap = Btype.snapshot () in + let v2 = + TypeMap.fold + (fun t vt v -> + if Ctype.is_equal env false [ty] [t] then union vt v else v) + !tvl2 null in + Btype.backtrack snap; + let (c1,n1) = get_upper v1 and (c2,n2,i2) = get_lower v2 in + if c1 && not c2 || n1 && not n2 then begin + match List.find_opt (eq_type ty) fvl with + | Some variable -> + let error = + if not i2 then + No_variable + else if c2 || n2 then + Variance_not_reflected + else + Variance_not_deducible + in + let variance_error = + Variance_variable_error { error; context; variable } + in + raise + (Error (loc + , Bad_variance ( variance_error + , (c1,n1,false) + , (c2,n2,false)))) + | None -> + Btype.iter_type_expr check ty + end + in + List.iter (fun (_,ty) -> check ty) tyl; + end; + List.map2 + (fun ty (p, n, _i) -> + let v = get_variance ty tvl in + let tr = decl.type_private in + (* Use required variance where relevant *) + let concr = not (Btype.type_kind_is_abstract decl) in + let (p, n) = + if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *) + else (false, false) (* only check *) + and i = concr in + let v = union v (make p n i) in + if not concr || Btype.is_Tvar ty then v else + union v + (if p then if n then full else covariant else conjugate covariant)) + params required + +let add_false = List.map (fun ty -> false, ty) + +(* A parameter is constrained if it is either instantiated, + or it is a variable appearing in another parameter *) +let constrained vars ty = + match get_desc ty with + | Tvar _ -> List.exists (List.exists (eq_type ty)) vars + | _ -> true + +let for_constr = function + | Types.Cstr_tuple l -> add_false l + | Types.Cstr_record l -> + List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + l + +let compute_variance_gadt env ~check (required, loc as rloc) decl + (tl, ret_type_opt) = + match ret_type_opt with + | None -> + compute_variance_type env ~check rloc {decl with type_private = Private} + (for_constr tl) + | Some ret_type -> + match get_desc ret_type with + | Tconstr (_, tyl, _) -> + (* let tyl = List.map (Ctype.expand_head env) tyl in *) + let fvl = List.map (Ctype.free_variables ?env:None) tyl in + let _ = + List.fold_left2 + (fun (fv1,fv2) ty (c,n,_) -> + match fv2 with [] -> assert false + | fv :: fv2 -> + (* fv1 @ fv2 = free_variables of other parameters *) + if (c||n) && constrained (fv1 @ fv2) ty then + raise (Error(loc, Varying_anonymous)); + (fv :: fv1, fv2)) + ([], fvl) tyl required + in + compute_variance_type env ~check rloc + {decl with type_params = tyl; type_private = Private} + (for_constr tl) + | _ -> assert false + +let compute_variance_extension env decl ext rloc = + let check = + Some (Extension_constructor (ext.Typedtree.ext_id, ext.Typedtree.ext_type)) + in + let ext = ext.Typedtree.ext_type in + compute_variance_gadt env ~check rloc + {decl with type_params = ext.ext_type_params} + (ext.ext_args, ext.ext_ret_type) + +let compute_variance_gadt_constructor env ~check rloc decl tl = + let check = + match check with + | Some _ -> Some (Gadt_constructor tl) + | None -> None + in + compute_variance_gadt env ~check rloc decl + (tl.Types.cd_args, tl.Types.cd_res) + +let compute_variance_decl env ~check decl (required, _ as rloc) = + let check = + Option.map (fun id -> Type_declaration (id, decl)) check + in + let abstract = Btype.type_kind_is_abstract decl in + if (abstract || decl.type_kind = Type_open) && decl.type_manifest = None then + List.map + (fun (c, n, i) -> make (not n) (not c) (not abstract || i)) + required + else begin + let mn = + match decl.type_manifest with + None -> [] + | Some ty -> [ false, ty ] + in + let vari = + match decl.type_kind with + Type_abstract _ | Type_open -> + compute_variance_type env ~check rloc decl mn + | Type_variant (tll,_rep) -> + if List.for_all (fun c -> c.Types.cd_res = None) tll then + compute_variance_type env ~check rloc decl + (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) + tll)) + else begin + let vari = + List.map + (fun ty -> + compute_variance_type env ~check rloc + {decl with type_private = Private} + (add_false [ ty ]) + ) + (Option.to_list decl.type_manifest) + in + let constructor_variance = + List.map + (compute_variance_gadt_constructor env ~check rloc decl) + tll + in + match List.append vari constructor_variance with + | vari :: rem -> + List.fold_left (List.map2 Variance.union) vari rem + | _ -> assert false + end + | Type_record (ftl, _) -> + compute_variance_type env ~check rloc decl + (mn @ List.map (fun {Types.ld_mutable; ld_type} -> + (ld_mutable = Mutable, ld_type)) ftl) + in + if mn = [] || not abstract then + List.map Variance.strengthen vari + else vari + end + +let is_hash id = + let s = Ident.name id in + String.length s > 0 && s.[0] = '#' + +let check_variance_extension env decl ext rloc = + (* TODO: refactorize compute_variance_extension *) + ignore (compute_variance_extension env decl ext rloc) + +let compute_decl env ~check decl req = + compute_variance_decl env ~check decl (req, decl.type_loc) + +let check_decl env id decl req = + ignore (compute_variance_decl env ~check:(Some id) decl (req, decl.type_loc)) + +type prop = Variance.t list +type req = surface_variance list +let property : (prop, req) Typedecl_properties.property = + let open Typedecl_properties in + let eq li1 li2 = + try List.for_all2 Variance.eq li1 li2 with _ -> false in + let merge ~prop ~new_prop = + List.map2 Variance.union prop new_prop in + let default decl = + List.map (fun _ -> Variance.null) decl.type_params in + let compute env decl req = + compute_decl env ~check:None decl req in + let update_decl decl variance = + { decl with type_variance = variance } in + let check env id decl req = + if is_hash id then () else check_decl env id decl req in + { + eq; + merge; + default; + compute; + update_decl; + check; + } + +let transl_variance (v, i) = + let co, cn = + match v with + | Covariant -> (true, false) + | Contravariant -> (false, true) + | NoVariance -> (false, false) + in + (co, cn, match i with Injective -> true | NoInjectivity -> false) + +let variance_of_params ptype_params = + List.map transl_variance (List.map snd ptype_params) + +let variance_of_sdecl sdecl = + variance_of_params sdecl.Parsetree.ptype_params + +let update_decls env sdecls decls = + let required = List.map variance_of_sdecl sdecls in + Typedecl_properties.compute_property property env decls required + +let update_class_decls env cldecls = + let decls, required = + List.fold_right + (fun (obj_id, obj_abbr, _clty, _cltydef, ci) (decls, req) -> + (obj_id, obj_abbr) :: decls, + variance_of_params ci.Typedtree.ci_params :: req) + cldecls ([],[]) + in + let decls = + Typedecl_properties.compute_property property env decls required in + List.map2 + (fun (_,decl) (_, _, clty, cltydef, _) -> + let variance = decl.type_variance in + (decl, {clty with cty_variance = variance}, + {cltydef with + clty_variance = variance; + clty_hash_type = {cltydef.clty_hash_type with type_variance = variance} + })) + decls cldecls diff --git a/upstream/ocaml_503/typing/typedecl_variance.mli b/upstream/ocaml_503/typing/typedecl_variance.mli new file mode 100644 index 000000000..6392e61dd --- /dev/null +++ b/upstream/ocaml_503/typing/typedecl_variance.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types +open Typedecl_properties + +type surface_variance = bool * bool * bool + +val variance_of_params : + (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list -> + surface_variance list +val variance_of_sdecl : + Parsetree.type_declaration -> surface_variance list + +type prop = Variance.t list +type req = surface_variance list +val property : (Variance.t list, req) property + +type variance_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + +type variance_error = + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } + +type error = + | Bad_variance of variance_error * surface_variance * surface_variance + | Varying_anonymous + +exception Error of Location.t * error + +val check_variance_extension : + Env.t -> type_declaration -> + Typedtree.extension_constructor -> req * Location.t -> unit + +val compute_decl : + Env.t -> check:Ident.t option -> type_declaration -> req -> prop + +val update_decls : + Env.t -> Parsetree.type_declaration list -> + (Ident.t * type_declaration) list -> + (Ident.t * type_declaration) list + +val update_class_decls : + Env.t -> + (Ident.t * Typedecl_properties.decl * + Types.class_declaration * Types.class_type_declaration * + 'a Typedtree.class_infos) list -> + (Typedecl_properties.decl * + Types.class_declaration * Types.class_type_declaration) list +(* FIXME: improve this horrible interface *) diff --git a/upstream/ocaml_503/typing/typedtree.ml b/upstream/ocaml_503/typing/typedtree.ml new file mode 100644 index 000000000..ff0060e13 --- /dev/null +++ b/upstream/ocaml_503/typing/typedtree.ml @@ -0,0 +1,895 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Abstract syntax tree after typing *) + +open Asttypes +open Types + +module Uid = Shape.Uid + +(* Value expressions for the core language *) + +type partial = Partial | Total + +type attribute = Parsetree.attribute +type attributes = attribute list + +type value = Value_pattern +type computation = Computation_pattern + +type _ pattern_category = +| Value : value pattern_category +| Computation : computation pattern_category + +type pattern = value general_pattern +and 'k general_pattern = 'k pattern_desc pattern_data + +and 'a pattern_data = + { pat_desc: 'a; + pat_loc: Location.t; + pat_extra : (pat_extra * Location.t * attribute list) list; + pat_type: type_expr; + pat_env: Env.t; + pat_attributes: attribute list; + } + +and pat_extra = + | Tpat_constraint of core_type + | Tpat_type of Path.t * Longident.t loc + | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_unpack + +and 'k pattern_desc = + (* value patterns *) + | Tpat_any : value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc + | Tpat_alias : + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc + | Tpat_constant : constant -> value pattern_desc + | Tpat_tuple : value general_pattern list -> value pattern_desc + | Tpat_construct : + Longident.t loc * constructor_description * value general_pattern list + * (Ident.t loc list * core_type) option -> + value pattern_desc + | Tpat_variant : + label * value general_pattern option * row_desc ref -> + value pattern_desc + | Tpat_record : + (Longident.t loc * label_description * value general_pattern) list * + closed_flag -> + value pattern_desc + | Tpat_array : value general_pattern list -> value pattern_desc + | Tpat_lazy : value general_pattern -> value pattern_desc + (* computation patterns *) + | Tpat_value : tpat_value_argument -> computation pattern_desc + | Tpat_exception : value general_pattern -> computation pattern_desc + (* generic constructions *) + | Tpat_or : + 'k general_pattern * 'k general_pattern * row_desc option -> + 'k pattern_desc + +and tpat_value_argument = value general_pattern + +and expression = + { exp_desc: expression_desc; + exp_loc: Location.t; + exp_extra: (exp_extra * Location.t * attribute list) list; + exp_type: type_expr; + exp_env: Env.t; + exp_attributes: attribute list; + } + +and exp_extra = + | Texp_constraint of core_type + | Texp_coerce of core_type option * core_type + | Texp_poly of core_type option + | Texp_newtype of string + +and expression_desc = + Texp_ident of Path.t * Longident.t loc * Types.value_description + | Texp_constant of constant + | Texp_let of rec_flag * value_binding list * expression + | Texp_function of function_param list * function_body + | Texp_apply of expression * (arg_label * expression option) list + | Texp_match of expression * computation case list * value case list * partial + | Texp_try of expression * value case list * value case list + | Texp_tuple of expression list + | Texp_construct of + Longident.t loc * constructor_description * expression list + | Texp_variant of label * expression option + | Texp_record of { + fields : ( Types.label_description * record_label_definition ) array; + representation : Types.record_representation; + extended_expression : expression option; + } + | Texp_field of expression * Longident.t loc * label_description + | Texp_setfield of + expression * Longident.t loc * label_description * expression + | Texp_array of expression list + | Texp_ifthenelse of expression * expression * expression option + | Texp_sequence of expression * expression + | Texp_while of expression * expression + | Texp_for of + Ident.t * Parsetree.pattern * expression * expression * direction_flag * + expression + | Texp_send of expression * meth + | Texp_new of Path.t * Longident.t loc * Types.class_declaration + | Texp_instvar of Path.t * Path.t * string loc + | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_override of Path.t * (Ident.t * string loc * expression) list + | Texp_letmodule of + Ident.t option * string option loc * Types.module_presence * module_expr * + expression + | Texp_letexception of extension_constructor * expression + | Texp_assert of expression * Location.t + | Texp_lazy of expression + | Texp_object of class_structure * string list + | Texp_pack of module_expr + | Texp_letop of { + let_ : binding_op; + ands : binding_op list; + param : Ident.t; + body : value case; + partial : partial; + } + | Texp_unreachable + | Texp_extension_constructor of Longident.t loc * Path.t + | Texp_open of open_declaration * expression + +and meth = + | Tmeth_name of string + | Tmeth_val of Ident.t + | Tmeth_ancestor of Ident.t * Path.t + +and 'k case = + { + c_lhs: 'k general_pattern; + c_cont: Ident.t option; + c_guard: expression option; + c_rhs: expression; + } + +and function_param = + { + fp_arg_label: arg_label; + fp_param: Ident.t; + fp_partial: partial; + fp_kind: function_param_kind; + fp_newtypes: string loc list; + fp_loc : Location.t; + } + +and function_param_kind = + | Tparam_pat of pattern + | Tparam_optional_default of pattern * expression + +and function_body = + | Tfunction_body of expression + | Tfunction_cases of + { cases: value case list; + partial: partial; + param: Ident.t; + loc: Location.t; + exp_extra: exp_extra option; + attributes: attributes; + } + +and record_label_definition = + | Kept of Types.type_expr * mutable_flag + | Overridden of Longident.t loc * expression + +and binding_op = + { + bop_op_path : Path.t; + bop_op_name : string loc; + bop_op_val : Types.value_description; + bop_op_type : Types.type_expr; + bop_exp : expression; + bop_loc : Location.t; + } + +(* Value expressions for the class language *) + +and class_expr = + { + cl_desc: class_expr_desc; + cl_loc: Location.t; + cl_type: Types.class_type; + cl_env: Env.t; + cl_attributes: attribute list; + } + +and class_expr_desc = + Tcl_ident of Path.t * Longident.t loc * core_type list + | Tcl_structure of class_structure + | Tcl_fun of + arg_label * pattern * (Ident.t * expression) list + * class_expr * partial + | Tcl_apply of class_expr * (arg_label * expression option) list + | Tcl_let of rec_flag * value_binding list * + (Ident.t * expression) list * class_expr + | Tcl_constraint of + class_expr * class_type option * string list * string list * MethSet.t + (* Visible instance variables, methods and concrete methods *) + | Tcl_open of open_description * class_expr + +and class_structure = + { + cstr_self: pattern; + cstr_fields: class_field list; + cstr_type: Types.class_signature; + cstr_meths: Ident.t Meths.t; + } + +and class_field = + { + cf_desc: class_field_desc; + cf_loc: Location.t; + cf_attributes: attribute list; + } + +and class_field_kind = + | Tcfk_virtual of core_type + | Tcfk_concrete of override_flag * expression + +and class_field_desc = + Tcf_inherit of + override_flag * class_expr * string option * (string * Ident.t) list * + (string * Ident.t) list + (* Inherited instance variables and concrete methods *) + | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool + | Tcf_method of string loc * private_flag * class_field_kind + | Tcf_constraint of core_type * core_type + | Tcf_initializer of expression + | Tcf_attribute of attribute + +(* Value expressions for the module language *) + +and module_expr = + { mod_desc: module_expr_desc; + mod_loc: Location.t; + mod_type: Types.module_type; + mod_env: Env.t; + mod_attributes: attribute list; + } + +and module_type_constraint = + Tmodtype_implicit +| Tmodtype_explicit of module_type + +and functor_parameter = + | Unit + | Named of Ident.t option * string option loc * module_type + +and module_expr_desc = + Tmod_ident of Path.t * Longident.t loc + | Tmod_structure of structure + | Tmod_functor of functor_parameter * module_expr + | Tmod_apply of module_expr * module_expr * module_coercion + | Tmod_apply_unit of module_expr + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + | Tmod_unpack of expression * Types.module_type + +and structure = { + str_items : structure_item list; + str_type : Types.signature; + str_final_env : Env.t; +} + +and structure_item = + { str_desc : structure_item_desc; + str_loc : Location.t; + str_env : Env.t + } + +and structure_item_desc = + Tstr_eval of expression * attributes + | Tstr_value of rec_flag * value_binding list + | Tstr_primitive of value_description + | Tstr_type of rec_flag * type_declaration list + | Tstr_typext of type_extension + | Tstr_exception of type_exception + | Tstr_module of module_binding + | Tstr_recmodule of module_binding list + | Tstr_modtype of module_type_declaration + | Tstr_open of open_declaration + | Tstr_class of (class_declaration * string list) list + | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list + | Tstr_include of include_declaration + | Tstr_attribute of attribute + +and module_binding = + { + mb_id: Ident.t option; + mb_name: string option loc; + mb_uid: Uid.t; + mb_presence: module_presence; + mb_expr: module_expr; + mb_attributes: attribute list; + mb_loc: Location.t; + } + +and value_binding = + { + vb_pat: pattern; + vb_expr: expression; + vb_rec_kind: Value_rec_types.recursive_binding_kind; + vb_attributes: attributes; + vb_loc: Location.t; + } + +and module_coercion = + Tcoerce_none + | Tcoerce_structure of (int * module_coercion) list * + (Ident.t * int * module_coercion) list + | Tcoerce_functor of module_coercion * module_coercion + | Tcoerce_primitive of primitive_coercion + | Tcoerce_alias of Env.t * Path.t * module_coercion + +and module_type = + { mty_desc: module_type_desc; + mty_type : Types.module_type; + mty_env : Env.t; + mty_loc: Location.t; + mty_attributes: attribute list; + } + +and module_type_desc = + Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of functor_parameter * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + | Tmty_alias of Path.t * Longident.t loc + +(* Keep primitive type information for type-based lambda-code specialization *) +and primitive_coercion = + { + pc_desc: Primitive.description; + pc_type: type_expr; + pc_env: Env.t; + pc_loc : Location.t; + } + +and signature = { + sig_items : signature_item list; + sig_type : Types.signature; + sig_final_env : Env.t; +} + +and signature_item = + { sig_desc: signature_item_desc; + sig_env : Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t } + +and signature_item_desc = + Tsig_value of value_description + | Tsig_type of rec_flag * type_declaration list + | Tsig_typesubst of type_declaration list + | Tsig_typext of type_extension + | Tsig_exception of type_exception + | Tsig_module of module_declaration + | Tsig_modsubst of module_substitution + | Tsig_recmodule of module_declaration list + | Tsig_modtype of module_type_declaration + | Tsig_modtypesubst of module_type_declaration + | Tsig_open of open_description + | Tsig_include of include_description + | Tsig_class of class_description list + | Tsig_class_type of class_type_declaration list + | Tsig_attribute of attribute + +and module_declaration = + { + md_id: Ident.t option; + md_name: string option loc; + md_uid: Uid.t; + md_presence: module_presence; + md_type: module_type; + md_attributes: attribute list; + md_loc: Location.t; + } + +and module_substitution = + { + ms_id: Ident.t; + ms_name: string loc; + ms_uid: Uid.t; + ms_manifest: Path.t; + ms_txt: Longident.t loc; + ms_attributes: attributes; + ms_loc: Location.t; + } + +and module_type_declaration = + { + mtd_id: Ident.t; + mtd_name: string loc; + mtd_uid: Uid.t; + mtd_type: module_type option; + mtd_attributes: attribute list; + mtd_loc: Location.t; + } + +and 'a open_infos = + { + open_expr: 'a; + open_bound_items: Types.signature; + open_override: override_flag; + open_env: Env.t; + open_loc: Location.t; + open_attributes: attribute list; + } + +and open_description = (Path.t * Longident.t loc) open_infos + +and open_declaration = module_expr open_infos + +and 'a include_infos = + { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; + } + +and include_description = module_type include_infos + +and include_declaration = module_expr include_infos + +and with_constraint = + Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_modtype of module_type + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + | Twith_modtypesubst of module_type + + +and core_type = +(* mutable because of [Typeclass.declare_method] *) + { mutable ctyp_desc : core_type_desc; + mutable ctyp_type : type_expr; + ctyp_env : Env.t; (* BINANNOT ADDED *) + ctyp_loc : Location.t; + ctyp_attributes: attribute list; + } + +and core_type_desc = + Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of arg_label * core_type * core_type + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of object_field list * closed_flag + | Ttyp_class of Path.t * Longident.t loc * core_type list + | Ttyp_alias of core_type * string loc + | Ttyp_variant of row_field list * closed_flag * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + | Ttyp_open of Path.t * Longident.t loc * core_type + +and package_type = { + pack_path : Path.t; + pack_fields : (Longident.t loc * core_type) list; + pack_type : Types.module_type; + pack_txt : Longident.t loc; +} + +and row_field = { + rf_desc : row_field_desc; + rf_loc : Location.t; + rf_attributes : attributes; +} + +and row_field_desc = + Ttag of string loc * bool * core_type list + | Tinherit of core_type + +and object_field = { + of_desc : object_field_desc; + of_loc : Location.t; + of_attributes : attributes; +} + +and object_field_desc = + | OTtag of string loc * core_type + | OTinherit of core_type + +and value_description = + { val_id: Ident.t; + val_name: string loc; + val_desc: core_type; + val_val: Types.value_description; + val_prim: string list; + val_loc: Location.t; + val_attributes: attribute list; + } + +and type_declaration = + { typ_id: Ident.t; + typ_name: string loc; + typ_params: (core_type * (variance * injectivity)) list; + typ_type: Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_loc: Location.t; + typ_attributes: attribute list; + } + +and type_kind = + Ttype_abstract + | Ttype_variant of constructor_declaration list + | Ttype_record of label_declaration list + | Ttype_open + +and label_declaration = + { + ld_id: Ident.t; + ld_name: string loc; + ld_uid: Uid.t; + ld_mutable: mutable_flag; + ld_type: core_type; + ld_loc: Location.t; + ld_attributes: attribute list; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_name: string loc; + cd_uid: Uid.t; + cd_vars: string loc list; + cd_args: constructor_arguments; + cd_res: core_type option; + cd_loc: Location.t; + cd_attributes: attribute list; + } + +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + +and type_extension = + { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * (variance * injectivity)) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_loc: Location.t; + tyext_attributes: attribute list; + } + +and type_exception = + { + tyexn_constructor: extension_constructor; + tyexn_loc: Location.t; + tyexn_attributes: attribute list; + } + +and extension_constructor = + { + ext_id: Ident.t; + ext_name: string loc; + ext_type: Types.extension_constructor; + ext_kind: extension_constructor_kind; + ext_loc: Location.t; + ext_attributes: attribute list; + } + +and extension_constructor_kind = + Text_decl of string loc list * constructor_arguments * core_type option + | Text_rebind of Path.t * Longident.t loc + +and class_type = + { + cltyp_desc: class_type_desc; + cltyp_type: Types.class_type; + cltyp_env: Env.t; + cltyp_loc: Location.t; + cltyp_attributes: attribute list; + } + +and class_type_desc = + Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_signature of class_signature + | Tcty_arrow of arg_label * core_type * class_type + | Tcty_open of open_description * class_type + +and class_signature = { + csig_self: core_type; + csig_fields: class_type_field list; + csig_type: Types.class_signature; + } + +and class_type_field = { + ctf_desc: class_type_field_desc; + ctf_loc: Location.t; + ctf_attributes: attribute list; + } + +and class_type_field_desc = + | Tctf_inherit of class_type + | Tctf_val of (string * mutable_flag * virtual_flag * core_type) + | Tctf_method of (string * private_flag * virtual_flag * core_type) + | Tctf_constraint of (core_type * core_type) + | Tctf_attribute of attribute + +and class_declaration = + class_expr class_infos + +and class_description = + class_type class_infos + +and class_type_declaration = + class_type class_infos + +and 'a class_infos = + { ci_virt: virtual_flag; + ci_params: (core_type * (variance * injectivity)) list; + ci_id_name: string loc; + ci_id_class: Ident.t; + ci_id_class_type: Ident.t; + ci_id_object: Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl: Types.class_type_declaration; + ci_loc: Location.t; + ci_attributes: attribute list; + } + +type implementation = { + structure: structure; + coercion: module_coercion; + signature: Types.signature; + shape: Shape.t; +} + +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration + +(* Auxiliary functions over the a.s.t. *) + +let as_computation_pattern (p : pattern) : computation general_pattern = + { + pat_desc = Tpat_value p; + pat_loc = p.pat_loc; + pat_extra = []; + pat_type = p.pat_type; + pat_env = p.pat_env; + pat_attributes = []; + } + +let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category = + function + | Tpat_alias _ -> Value + | Tpat_tuple _ -> Value + | Tpat_construct _ -> Value + | Tpat_variant _ -> Value + | Tpat_record _ -> Value + | Tpat_array _ -> Value + | Tpat_lazy _ -> Value + | Tpat_any -> Value + | Tpat_var _ -> Value + | Tpat_constant _ -> Value + + | Tpat_value _ -> Computation + | Tpat_exception _ -> Computation + + | Tpat_or(p1, p2, _) -> + begin match classify_pattern p1, classify_pattern p2 with + | Value, Value -> Value + | Computation, Computation -> Computation + end + +and classify_pattern + : type k . k general_pattern -> k pattern_category + = fun pat -> + classify_pattern_desc pat.pat_desc + +type pattern_action = + { f : 'k . 'k general_pattern -> unit } +let shallow_iter_pattern_desc + : type k . pattern_action -> k pattern_desc -> unit + = fun f -> function + | Tpat_alias(p, _, _, _) -> f.f p + | Tpat_tuple patl -> List.iter f.f patl + | Tpat_construct(_, _, patl, _) -> List.iter f.f patl + | Tpat_variant(_, pat, _) -> Option.iter f.f pat + | Tpat_record (lbl_pat_list, _) -> + List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list + | Tpat_array patl -> List.iter f.f patl + | Tpat_lazy p -> f.f p + | Tpat_any + | Tpat_var _ + | Tpat_constant _ -> () + | Tpat_value p -> f.f p + | Tpat_exception p -> f.f p + | Tpat_or(p1, p2, _) -> f.f p1; f.f p2 + +type pattern_transformation = + { f : 'k . 'k general_pattern -> 'k general_pattern } +let shallow_map_pattern_desc + : type k . pattern_transformation -> k pattern_desc -> k pattern_desc + = fun f d -> match d with + | Tpat_alias (p1, id, s, uid) -> + Tpat_alias (f.f p1, id, s, uid) + | Tpat_tuple pats -> + Tpat_tuple (List.map f.f pats) + | Tpat_record (lpats, closed) -> + Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed) + | Tpat_construct (lid, c, pats, ty) -> + Tpat_construct (lid, c, List.map f.f pats, ty) + | Tpat_array pats -> + Tpat_array (List.map f.f pats) + | Tpat_lazy p1 -> Tpat_lazy (f.f p1) + | Tpat_variant (x1, Some p1, x2) -> + Tpat_variant (x1, Some (f.f p1), x2) + | Tpat_var _ + | Tpat_constant _ + | Tpat_any + | Tpat_variant (_,None,_) -> d + | Tpat_value p -> Tpat_value (f.f p) + | Tpat_exception p -> Tpat_exception (f.f p) + | Tpat_or (p1,p2,path) -> + Tpat_or (f.f p1, f.f p2, path) + +let rec iter_general_pattern + : type k . pattern_action -> k general_pattern -> unit + = fun f p -> + f.f p; + shallow_iter_pattern_desc + { f = fun p -> iter_general_pattern f p } + p.pat_desc + +let iter_pattern (f : pattern -> unit) = + iter_general_pattern + { f = fun (type k) (p : k general_pattern) -> + match classify_pattern p with + | Value -> f p + | Computation -> () } + +type pattern_predicate = { f : 'k . 'k general_pattern -> bool } +let exists_general_pattern (f : pattern_predicate) p = + let exception Found in + match + iter_general_pattern + { f = fun p -> if f.f p then raise Found else () } + p + with + | exception Found -> true + | () -> false + +let exists_pattern (f : pattern -> bool) = + exists_general_pattern + { f = fun (type k) (p : k general_pattern) -> + match classify_pattern p with + | Value -> f p + | Computation -> false } + + +(* List the identifiers bound by a pattern or a let *) + +let rec iter_bound_idents + : type k . _ -> k general_pattern -> _ + = fun f pat -> + match pat.pat_desc with + | Tpat_var (id, s, uid) -> + f (id,s,pat.pat_type, uid) + | Tpat_alias(p, id, s, uid) -> + iter_bound_idents f p; + f (id,s,pat.pat_type, uid) + | Tpat_or(p1, _, _) -> + (* Invariant : both arguments bind the same variables *) + iter_bound_idents f p1 + | d -> + shallow_iter_pattern_desc + { f = fun p -> iter_bound_idents f p } + d + +let rev_pat_bound_idents_full pat = + let idents_full = ref [] in + let add id_full = idents_full := id_full :: !idents_full in + iter_bound_idents add pat; + !idents_full + +let rev_only_idents idents_full = + List.rev_map (fun (id,_,_,_) -> id) idents_full + +let pat_bound_idents_full pat = + List.rev (rev_pat_bound_idents_full pat) +let pat_bound_idents pat = + rev_only_idents (rev_pat_bound_idents_full pat) + +let rev_let_bound_idents_full bindings = + let idents_full = ref [] in + let add id_full = idents_full := id_full :: !idents_full in + List.iter (fun vb -> iter_bound_idents add vb.vb_pat) bindings; + !idents_full + +let let_bound_idents_full bindings = + List.rev (rev_let_bound_idents_full bindings) +let let_bound_idents pat = + rev_only_idents (rev_let_bound_idents_full pat) + +let alpha_var env id = List.assoc id env + +let rec alpha_pat + : type k . _ -> k general_pattern -> k general_pattern + = fun env p -> match p.pat_desc with + | Tpat_var (id, s, uid) -> (* note the ``Not_found'' case *) + {p with pat_desc = + try Tpat_var (alpha_var env id, s, uid) with + | Not_found -> Tpat_any} + | Tpat_alias (p1, id, s, uid) -> + let new_p = alpha_pat env p1 in + begin try + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid)} + with + | Not_found -> new_p + end + | d -> + let pat_desc = + shallow_map_pattern_desc { f = fun p -> alpha_pat env p } d in + {p with pat_desc} + +let mkloc = Location.mkloc +let mknoloc = Location.mknoloc + +let split_pattern pat = + let combine_opts merge p1 p2 = + match p1, p2 with + | None, None -> None + | Some p, None + | None, Some p -> + Some p + | Some p1, Some p2 -> + Some (merge p1 p2) + in + let into pat p1 p2 = + (* The third parameter of [Tpat_or] is [Some _] only for "#typ" + patterns, which we do *not* expand. Hence we can put [None] here. *) + { pat with pat_desc = Tpat_or (p1, p2, None) } in + let rec split_pattern cpat = + match cpat.pat_desc with + | Tpat_value p -> + Some p, None + | Tpat_exception p -> + None, Some p + | Tpat_or (cp1, cp2, _) -> + let vals1, exns1 = split_pattern cp1 in + let vals2, exns2 = split_pattern cp2 in + combine_opts (into cpat) vals1 vals2, + (* We could change the pattern type for exception patterns to + [Predef.exn], but it doesn't really matter. *) + combine_opts (into cpat) exns1 exns2 + in + split_pattern pat diff --git a/upstream/ocaml_503/typing/typedtree.mli b/upstream/ocaml_503/typing/typedtree.mli new file mode 100644 index 000000000..7dd2ed7a8 --- /dev/null +++ b/upstream/ocaml_503/typing/typedtree.mli @@ -0,0 +1,921 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree after typing *) + + +(** By comparison with {!Parsetree}: + - Every {!Longindent.t} is accompanied by a resolved {!Path.t}. + +*) + +open Asttypes +module Uid = Shape.Uid + +(* Value expressions for the core language *) + +type partial = Partial | Total + +(** {1 Extension points} *) + +type attribute = Parsetree.attribute +type attributes = attribute list + +(** {1 Core language} *) + +type value = Value_pattern +type computation = Computation_pattern + +type _ pattern_category = +| Value : value pattern_category +| Computation : computation pattern_category + +type pattern = value general_pattern +and 'k general_pattern = 'k pattern_desc pattern_data + +and 'a pattern_data = + { pat_desc: 'a; + pat_loc: Location.t; + pat_extra : (pat_extra * Location.t * attributes) list; + pat_type: Types.type_expr; + pat_env: Env.t; + pat_attributes: attributes; + } + +and pat_extra = + | Tpat_constraint of core_type + (** P : T { pat_desc = P + ; pat_extra = (Tpat_constraint T, _, _) :: ... } + *) + | Tpat_type of Path.t * Longident.t loc + (** #tconst { pat_desc = disjunction + ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...} + + where [disjunction] is a [Tpat_or _] representing the + branches of [tconst]. + *) + | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_unpack + (** (module P) { pat_desc = Tpat_var "P" + ; pat_extra = (Tpat_unpack, _, _) :: ... } + (module _) { pat_desc = Tpat_any + ; pat_extra = (Tpat_unpack, _, _) :: ... } + *) + +and 'k pattern_desc = + (* value patterns *) + | Tpat_any : value pattern_desc + (** _ *) + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc + (** x *) + | Tpat_alias : + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc + (** P as a *) + | Tpat_constant : constant -> value pattern_desc + (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Tpat_tuple : value general_pattern list -> value pattern_desc + (** (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Tpat_construct : + Longident.t loc * Types.constructor_description * + value general_pattern list * (Ident.t loc list * core_type) option -> + value pattern_desc + (** C ([], None) + C P ([P], None) + C (P1, ..., Pn) ([P1; ...; Pn], None) + C (P : t) ([P], Some ([], t)) + C (P1, ..., Pn : t) ([P1; ...; Pn], Some ([], t)) + C (type a) (P : t) ([P], Some ([a], t)) + C (type a) (P1, ..., Pn : t) ([P1; ...; Pn], Some ([a], t)) + *) + | Tpat_variant : + label * value general_pattern option * Types.row_desc ref -> + value pattern_desc + (** `A (None) + `A P (Some P) + + See {!Types.row_desc} for an explanation of the last parameter. + *) + | Tpat_record : + (Longident.t loc * Types.label_description * value general_pattern) list * + closed_flag -> + value pattern_desc + (** { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Tpat_array : value general_pattern list -> value pattern_desc + (** [| P1; ...; Pn |] *) + | Tpat_lazy : value general_pattern -> value pattern_desc + (** lazy P *) + (* computation patterns *) + | Tpat_value : tpat_value_argument -> computation pattern_desc + (** P + + Invariant: Tpat_value pattern should not carry + pat_attributes or pat_extra metadata coming from user + syntax, which must be on the inner pattern node -- to + facilitate searching for a certain value pattern + constructor with a specific attributed. + + To enforce this restriction, we made the argument of + the Tpat_value constructor a private synonym of [pattern], + requiring you to use the [as_computation_pattern] function + below instead of using the [Tpat_value] constructor directly. + *) + | Tpat_exception : value general_pattern -> computation pattern_desc + (** exception P *) + (* generic constructions *) + | Tpat_or : + 'k general_pattern * 'k general_pattern * Types.row_desc option -> + 'k pattern_desc + (** P1 | P2 + + [row_desc] = [Some _] when translating [Ppat_type _], + [None] otherwise. + *) + +and tpat_value_argument = private value general_pattern + +and expression = + { exp_desc: expression_desc; + exp_loc: Location.t; + exp_extra: (exp_extra * Location.t * attributes) list; + exp_type: Types.type_expr; + exp_env: Env.t; + exp_attributes: attributes; + } + +and exp_extra = + | Texp_constraint of core_type + (** E : T *) + | Texp_coerce of core_type option * core_type + (** E :> T [Texp_coerce (None, T)] + E : T0 :> T [Texp_coerce (Some T0, T)] + *) + | Texp_poly of core_type option + (** Used for method bodies. *) + | Texp_newtype of string + (** fun (type t) -> *) + +and expression_desc = + Texp_ident of Path.t * Longident.t loc * Types.value_description + (** x + M.x + *) + | Texp_constant of constant + (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Texp_let of rec_flag * value_binding list * expression + (** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Texp_function of function_param list * function_body + (** fun P0 P1 -> function p1 -> e1 | p2 -> e2 (body = Tfunction_cases _) + fun P0 P1 -> E (body = Tfunction_body _) + + This construct has the same arity as the originating + {{!Parsetree.expression_desc.Pexp_function}[Pexp_function]}. + Arity determines when side-effects for effectful parameters are run + (e.g. optional argument defaults, matching against lazy patterns). + Parameters' effects are run left-to-right when an n-ary function is + saturated with n arguments. + *) + | Texp_apply of expression * (arg_label * expression option) list + (** E0 ~l1:E1 ... ~ln:En + + The expression can be None if the expression is abstracted over + this argument. It currently appears when a label is applied. + + For example: + let f x ~y = x + y in + f ~y:3 + + The resulting typedtree for the application is: + Texp_apply (Texp_ident "f/1037", + [(Nolabel, None); + (Labelled "y", Some (Texp_constant Const_int 3)) + ]) + *) + | Texp_match of expression * computation case list * value case list * partial + (** match E0 with + | P1 -> E1 + | P2 | exception P3 -> E2 + | exception P4 -> E3 + | effect P4 k -> E4 + + [Texp_match (E0, [(P1, E1); (P2 | exception P3, E2); + (exception P4, E3)], [(P4, E4)], _)] + *) + | Texp_try of expression * value case list * value case list + (** try E with + | P1 -> E1 + | effect P2 k -> E2 + [Texp_try (E, [(P1, E1)], [(P2, E2)])] + *) + | Texp_tuple of expression list + (** (E1, ..., EN) *) + | Texp_construct of + Longident.t loc * Types.constructor_description * expression list + (** C [] + C E [E] + C (E1, ..., En) [E1;...;En] + *) + | Texp_variant of label * expression option + | Texp_record of { + fields : ( Types.label_description * record_label_definition ) array; + representation : Types.record_representation; + extended_expression : expression option; + } + (** { l1=P1; ...; ln=Pn } (extended_expression = None) + { E0 with l1=P1; ...; ln=Pn } (extended_expression = Some E0) + + Invariant: n > 0 + + If the type is { l1: t1; l2: t2 }, the expression + { E0 with t2=P2 } is represented as + Texp_record + { fields = [| l1, Kept t1; l2 Override P2 |]; representation; + extended_expression = Some E0 } + *) + | Texp_field of expression * Longident.t loc * Types.label_description + | Texp_setfield of + expression * Longident.t loc * Types.label_description * expression + | Texp_array of expression list + | Texp_ifthenelse of expression * expression * expression option + | Texp_sequence of expression * expression + | Texp_while of expression * expression + | Texp_for of + Ident.t * Parsetree.pattern * expression * expression * direction_flag * + expression + | Texp_send of expression * meth + | Texp_new of Path.t * Longident.t loc * Types.class_declaration + | Texp_instvar of Path.t * Path.t * string loc + | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_override of Path.t * (Ident.t * string loc * expression) list + | Texp_letmodule of + Ident.t option * string option loc * Types.module_presence * module_expr * + expression + | Texp_letexception of extension_constructor * expression + | Texp_assert of expression * Location.t + | Texp_lazy of expression + | Texp_object of class_structure * string list + | Texp_pack of module_expr + | Texp_letop of { + let_ : binding_op; + ands : binding_op list; + param : Ident.t; + body : value case; + partial : partial; + } + | Texp_unreachable + | Texp_extension_constructor of Longident.t loc * Path.t + | Texp_open of open_declaration * expression + (** let open[!] M in e *) + +and meth = + Tmeth_name of string + | Tmeth_val of Ident.t + | Tmeth_ancestor of Ident.t * Path.t + +and 'k case = + { + c_lhs: 'k general_pattern; + c_cont: Ident.t option; + c_guard: expression option; + c_rhs: expression; + } + +and function_param = + { + fp_arg_label: arg_label; + fp_param: Ident.t; + (** [fp_param] is the identifier that is to be used to name the + parameter of the function. + *) + fp_partial: partial; + (** + [fp_partial] = + [Partial] if the pattern match is partial + [Total] otherwise. + *) + fp_kind: function_param_kind; + fp_newtypes: string loc list; + (** [fp_newtypes] are the new type declarations that come *after* that + parameter. The newtypes that come before the first parameter are + placed as exp_extras on the Texp_function node. This is just used in + {!Untypeast}. *) + fp_loc: Location.t; + (** [fp_loc] is the location of the entire value parameter, not including + the [fp_newtypes]. + *) + } + +and function_param_kind = + | Tparam_pat of pattern + (** [Tparam_pat p] is a non-optional argument with pattern [p]. *) + | Tparam_optional_default of pattern * expression + (** [Tparam_optional_default (p, e)] is an optional argument [p] with default + value [e], i.e. [?x:(p = e)]. If the parameter is of type [a option], the + pattern and expression are of type [a]. *) + +and function_body = + | Tfunction_body of expression + | Tfunction_cases of + { cases: value case list; + partial: partial; + param: Ident.t; + loc: Location.t; + exp_extra: exp_extra option; + attributes: attributes; + (** [attributes] is just used in untypeast. *) + } +(** The function body binds a final argument in [Tfunction_cases], + and this argument is pattern-matched against the cases. +*) + +and record_label_definition = + | Kept of Types.type_expr * mutable_flag + | Overridden of Longident.t loc * expression + +and binding_op = + { + bop_op_path : Path.t; + bop_op_name : string loc; + bop_op_val : Types.value_description; + bop_op_type : Types.type_expr; + (* This is the type at which the operator was used. + It is always an instance of [bop_op_val.val_type] *) + bop_exp : expression; + bop_loc : Location.t; + } + +(* Value expressions for the class language *) + +and class_expr = + { + cl_desc: class_expr_desc; + cl_loc: Location.t; + cl_type: Types.class_type; + cl_env: Env.t; + cl_attributes: attributes; + } + +and class_expr_desc = + Tcl_ident of Path.t * Longident.t loc * core_type list + | Tcl_structure of class_structure + | Tcl_fun of + arg_label * pattern * (Ident.t * expression) list + * class_expr * partial + | Tcl_apply of class_expr * (arg_label * expression option) list + | Tcl_let of rec_flag * value_binding list * + (Ident.t * expression) list * class_expr + | Tcl_constraint of + class_expr * class_type option * string list * string list + * Types.MethSet.t + (* Visible instance variables, methods and concrete methods *) + | Tcl_open of open_description * class_expr + +and class_structure = + { + cstr_self: pattern; + cstr_fields: class_field list; + cstr_type: Types.class_signature; + cstr_meths: Ident.t Types.Meths.t; + } + +and class_field = + { + cf_desc: class_field_desc; + cf_loc: Location.t; + cf_attributes: attributes; + } + +and class_field_kind = + | Tcfk_virtual of core_type + | Tcfk_concrete of override_flag * expression + +and class_field_desc = + Tcf_inherit of + override_flag * class_expr * string option * (string * Ident.t) list * + (string * Ident.t) list + (* Inherited instance variables and concrete methods *) + | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool + | Tcf_method of string loc * private_flag * class_field_kind + | Tcf_constraint of core_type * core_type + | Tcf_initializer of expression + | Tcf_attribute of attribute + +(* Value expressions for the module language *) + +and module_expr = + { mod_desc: module_expr_desc; + mod_loc: Location.t; + mod_type: Types.module_type; + mod_env: Env.t; + mod_attributes: attributes; + } + +(** Annotations for [Tmod_constraint]. *) +and module_type_constraint = + | Tmodtype_implicit + (** The module type constraint has been synthesized during typechecking. *) + | Tmodtype_explicit of module_type + (** The module type was in the source file. *) + +and functor_parameter = + | Unit + | Named of Ident.t option * string option loc * module_type + +and module_expr_desc = + Tmod_ident of Path.t * Longident.t loc + | Tmod_structure of structure + | Tmod_functor of functor_parameter * module_expr + | Tmod_apply of module_expr * module_expr * module_coercion + | Tmod_apply_unit of module_expr + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + (** ME (constraint = Tmodtype_implicit) + (ME : MT) (constraint = Tmodtype_explicit MT) + *) + | Tmod_unpack of expression * Types.module_type + +and structure = { + str_items : structure_item list; + str_type : Types.signature; + str_final_env : Env.t; +} + +and structure_item = + { str_desc : structure_item_desc; + str_loc : Location.t; + str_env : Env.t + } + +and structure_item_desc = + Tstr_eval of expression * attributes + | Tstr_value of rec_flag * value_binding list + | Tstr_primitive of value_description + | Tstr_type of rec_flag * type_declaration list + | Tstr_typext of type_extension + | Tstr_exception of type_exception + | Tstr_module of module_binding + | Tstr_recmodule of module_binding list + | Tstr_modtype of module_type_declaration + | Tstr_open of open_declaration + | Tstr_class of (class_declaration * string list) list + | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list + | Tstr_include of include_declaration + | Tstr_attribute of attribute + +and module_binding = + { + mb_id: Ident.t option; (** [None] for [module _ = struct ... end] *) + mb_name: string option loc; + mb_uid: Uid.t; + mb_presence: Types.module_presence; + mb_expr: module_expr; + mb_attributes: attributes; + mb_loc: Location.t; + } + +and value_binding = + { + vb_pat: pattern; + vb_expr: expression; + vb_rec_kind: Value_rec_types.recursive_binding_kind; + vb_attributes: attributes; + vb_loc: Location.t; + } + +and module_coercion = + Tcoerce_none + | Tcoerce_structure of (int * module_coercion) list * + (Ident.t * int * module_coercion) list + | Tcoerce_functor of module_coercion * module_coercion + | Tcoerce_primitive of primitive_coercion + (** External declaration coerced to a regular value. + {[ + module M : sig val ext : a -> b end = + struct external ext : a -> b = "my_c_function" end + ]} + Only occurs inside a [Tcoerce_structure] coercion. *) + | Tcoerce_alias of Env.t * Path.t * module_coercion + (** Module alias coerced to a regular module. + {[ + module M : sig module Sub : T end = + struct module Sub = Some_alias end + ]} + Only occurs inside a [Tcoerce_structure] coercion. *) + +and module_type = + { mty_desc: module_type_desc; + mty_type : Types.module_type; + mty_env : Env.t; + mty_loc: Location.t; + mty_attributes: attributes; + } + +and module_type_desc = + Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of functor_parameter * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + | Tmty_alias of Path.t * Longident.t loc + +and primitive_coercion = + { + pc_desc: Primitive.description; + pc_type: Types.type_expr; + pc_env: Env.t; + pc_loc : Location.t; + } + +and signature = { + sig_items : signature_item list; + sig_type : Types.signature; + sig_final_env : Env.t; +} + +and signature_item = + { sig_desc: signature_item_desc; + sig_env : Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t } + +and signature_item_desc = + Tsig_value of value_description + | Tsig_type of rec_flag * type_declaration list + | Tsig_typesubst of type_declaration list + | Tsig_typext of type_extension + | Tsig_exception of type_exception + | Tsig_module of module_declaration + | Tsig_modsubst of module_substitution + | Tsig_recmodule of module_declaration list + | Tsig_modtype of module_type_declaration + | Tsig_modtypesubst of module_type_declaration + | Tsig_open of open_description + | Tsig_include of include_description + | Tsig_class of class_description list + | Tsig_class_type of class_type_declaration list + | Tsig_attribute of attribute + +and module_declaration = + { + md_id: Ident.t option; + md_name: string option loc; + md_uid: Uid.t; + md_presence: Types.module_presence; + md_type: module_type; + md_attributes: attributes; + md_loc: Location.t; + } + +and module_substitution = + { + ms_id: Ident.t; + ms_name: string loc; + ms_uid: Uid.t; + ms_manifest: Path.t; + ms_txt: Longident.t loc; + ms_attributes: attributes; + ms_loc: Location.t; + } + +and module_type_declaration = + { + mtd_id: Ident.t; + mtd_name: string loc; + mtd_uid: Uid.t; + mtd_type: module_type option; + mtd_attributes: attributes; + mtd_loc: Location.t; + } + +and 'a open_infos = + { + open_expr: 'a; + open_bound_items: Types.signature; + open_override: override_flag; + open_env: Env.t; + open_loc: Location.t; + open_attributes: attribute list; + } + +and open_description = (Path.t * Longident.t loc) open_infos + +and open_declaration = module_expr open_infos + + +and 'a include_infos = + { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; + } + +and include_description = module_type include_infos + +and include_declaration = module_expr include_infos + +and with_constraint = + Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_modtype of module_type + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + | Twith_modtypesubst of module_type + +and core_type = + { mutable ctyp_desc : core_type_desc; + (** mutable because of [Typeclass.declare_method] *) + mutable ctyp_type : Types.type_expr; + (** mutable because of [Typeclass.declare_method] *) + ctyp_env : Env.t; (* BINANNOT ADDED *) + ctyp_loc : Location.t; + ctyp_attributes: attributes; + } + +and core_type_desc = + Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of arg_label * core_type * core_type + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of object_field list * closed_flag + | Ttyp_class of Path.t * Longident.t loc * core_type list + | Ttyp_alias of core_type * string loc + | Ttyp_variant of row_field list * closed_flag * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + | Ttyp_open of Path.t * Longident.t loc * core_type + +and package_type = { + pack_path : Path.t; + pack_fields : (Longident.t loc * core_type) list; + pack_type : Types.module_type; + pack_txt : Longident.t loc; +} + +and row_field = { + rf_desc : row_field_desc; + rf_loc : Location.t; + rf_attributes : attributes; +} + +and row_field_desc = + Ttag of string loc * bool * core_type list + | Tinherit of core_type + +and object_field = { + of_desc : object_field_desc; + of_loc : Location.t; + of_attributes : attributes; +} + +and object_field_desc = + | OTtag of string loc * core_type + | OTinherit of core_type + +and value_description = + { val_id: Ident.t; + val_name: string loc; + val_desc: core_type; + val_val: Types.value_description; + val_prim: string list; + val_loc: Location.t; + val_attributes: attributes; + } + +and type_declaration = + { + typ_id: Ident.t; + typ_name: string loc; + typ_params: (core_type * (variance * injectivity)) list; + typ_type: Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_loc: Location.t; + typ_attributes: attributes; + } + +and type_kind = + Ttype_abstract + | Ttype_variant of constructor_declaration list + | Ttype_record of label_declaration list + | Ttype_open + +and label_declaration = + { + ld_id: Ident.t; + ld_name: string loc; + ld_uid: Uid.t; + ld_mutable: mutable_flag; + ld_type: core_type; + ld_loc: Location.t; + ld_attributes: attributes; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_name: string loc; + cd_uid: Uid.t; + cd_vars: string loc list; + cd_args: constructor_arguments; + cd_res: core_type option; + cd_loc: Location.t; + cd_attributes: attributes; + } + +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + +and type_extension = + { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * (variance * injectivity)) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_loc: Location.t; + tyext_attributes: attributes; + } + +and type_exception = + { + tyexn_constructor: extension_constructor; + tyexn_loc: Location.t; + tyexn_attributes: attribute list; + } + +and extension_constructor = + { + ext_id: Ident.t; + ext_name: string loc; + ext_type : Types.extension_constructor; + ext_kind : extension_constructor_kind; + ext_loc : Location.t; + ext_attributes: attributes; + } + +and extension_constructor_kind = + Text_decl of string loc list * constructor_arguments * core_type option + | Text_rebind of Path.t * Longident.t loc + +and class_type = + { + cltyp_desc: class_type_desc; + cltyp_type: Types.class_type; + cltyp_env: Env.t; + cltyp_loc: Location.t; + cltyp_attributes: attributes; + } + +and class_type_desc = + Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_signature of class_signature + | Tcty_arrow of arg_label * core_type * class_type + | Tcty_open of open_description * class_type + +and class_signature = { + csig_self : core_type; + csig_fields : class_type_field list; + csig_type : Types.class_signature; + } + +and class_type_field = { + ctf_desc: class_type_field_desc; + ctf_loc: Location.t; + ctf_attributes: attributes; + } + +and class_type_field_desc = + | Tctf_inherit of class_type + | Tctf_val of (string * mutable_flag * virtual_flag * core_type) + | Tctf_method of (string * private_flag * virtual_flag * core_type) + | Tctf_constraint of (core_type * core_type) + | Tctf_attribute of attribute + +and class_declaration = + class_expr class_infos + +and class_description = + class_type class_infos + +and class_type_declaration = + class_type class_infos + +and 'a class_infos = + { ci_virt: virtual_flag; + ci_params: (core_type * (variance * injectivity)) list; + ci_id_name : string loc; + ci_id_class: Ident.t; + ci_id_class_type : Ident.t; + ci_id_object : Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl : Types.class_type_declaration; + ci_loc: Location.t; + ci_attributes: attributes; + } + +type implementation = { + structure: structure; + coercion: module_coercion; + signature: Types.signature; + shape: Shape.t; +} +(** A typechecked implementation including its module structure, its exported + signature, and a coercion of the module against that signature. + + If an .mli file is present, the signature will come from that file and be + the exported signature of the module. + + If there isn't one, the signature will be inferred from the module + structure. +*) + +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration +(** [item_declaration] groups together items that correspond to the syntactic + category of "declarations" which include types, values, modules, etc. + declarations in signatures and their definitions in implementations. *) + +(* Auxiliary functions over the a.s.t. *) + +(** [as_computation_pattern p] is a computation pattern with description + [Tpat_value p], which enforces a correct placement of pat_attributes + and pat_extra metadata (on the inner value pattern, rather than on + the computation pattern). *) +val as_computation_pattern: pattern -> computation general_pattern + +val classify_pattern_desc: 'k pattern_desc -> 'k pattern_category +val classify_pattern: 'k general_pattern -> 'k pattern_category + +type pattern_action = + { f : 'k . 'k general_pattern -> unit } +val shallow_iter_pattern_desc: + pattern_action -> 'k pattern_desc -> unit + +type pattern_transformation = + { f : 'k . 'k general_pattern -> 'k general_pattern } +val shallow_map_pattern_desc: + pattern_transformation -> 'k pattern_desc -> 'k pattern_desc + +val iter_general_pattern: pattern_action -> 'k general_pattern -> unit +val iter_pattern: (pattern -> unit) -> pattern -> unit + +type pattern_predicate = { f : 'k . 'k general_pattern -> bool } +val exists_general_pattern: pattern_predicate -> 'k general_pattern -> bool +val exists_pattern: (pattern -> bool) -> pattern -> bool + +val let_bound_idents: value_binding list -> Ident.t list +val let_bound_idents_full: + value_binding list -> + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list + +(** Alpha conversion of patterns *) +val alpha_pat: + (Ident.t * Ident.t) list -> 'k general_pattern -> 'k general_pattern + +val mknoloc: 'a -> 'a Asttypes.loc +val mkloc: 'a -> Location.t -> 'a Asttypes.loc + +val pat_bound_idents: 'k general_pattern -> Ident.t list +val pat_bound_idents_full: + 'k general_pattern -> + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list + +(** Splits an or pattern into its value (left) and exception (right) parts. *) +val split_pattern: + computation general_pattern -> pattern option * pattern option diff --git a/upstream/ocaml_503/typing/typemod.ml b/upstream/ocaml_503/typing/typemod.ml new file mode 100644 index 000000000..887ac22a4 --- /dev/null +++ b/upstream/ocaml_503/typing/typemod.ml @@ -0,0 +1,3521 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc +open Longident +open Path +open Asttypes +open Parsetree +open Types +open Format_doc + +module Style = Misc.Style + +let () = Includemod_errorprinter.register () + +module Sig_component_kind = Shape.Sig_component_kind +module String = Misc.Stdlib.String + +type hiding_error = + | Illegal_shadowing of { + shadowed_item_id: Ident.t; + shadowed_item_kind: Sig_component_kind.t; + shadowed_item_loc: Location.t; + shadower_id: Ident.t; + user_id: Ident.t; + user_kind: Sig_component_kind.t; + user_loc: Location.t; + } + | Appears_in_signature of { + opened_item_id: Ident.t; + opened_item_kind: Sig_component_kind.t; + user_id: Ident.t; + user_kind: Sig_component_kind.t; + user_loc: Location.t; + } + +type error = + Cannot_apply of module_type + | Not_included of Includemod.explanation + | Cannot_eliminate_dependency of module_type + | Signature_expected + | Structure_expected of module_type + | With_no_component of Longident.t + | With_mismatch of Longident.t * Includemod.explanation + | With_makes_applicative_functor_ill_typed of + Longident.t * Path.t * Includemod.explanation + | With_changes_module_alias of Longident.t * Ident.t * Path.t + | With_cannot_remove_constrained_type + | With_package_manifest of Longident.t * type_expr + | Repeated_name of Sig_component_kind.t * string + | Non_generalizable of { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : module_type } + | Implementation_is_required of string + | Interface_not_compiled of string + | Not_allowed_in_functor_body + | Not_a_packed_module of type_expr + | Incomplete_packed_module of type_expr + | Scoping_pack of Longident.t * type_expr + | Recursive_module_require_explicit_type + | Apply_generative + | Cannot_scrape_alias of Path.t + | Cannot_scrape_package_type of Path.t + | Badly_formed_signature of string * Typedecl.error + | Cannot_hide_id of hiding_error + | Invalid_type_subst_rhs + | Unpackable_local_modtype_subst of Path.t + | With_cannot_remove_packed_modtype of Path.t * module_type + | Cannot_alias of Path.t + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +open Typedtree + +let rec path_concat head p = + match p with + Pident tail -> Pdot (Pident head, Ident.name tail) + | Pdot (pre, s) -> Pdot (path_concat head pre, s) + | Papply _ -> assert false + | Pextra_ty (p, extra) -> Pextra_ty (path_concat head p, extra) + +(* Extract a signature from a module type *) + +let extract_sig env loc mty = + match Env.scrape_alias env mty with + Mty_signature sg -> sg + | Mty_alias path -> + raise(Error(loc, env, Cannot_scrape_alias path)) + | _ -> raise(Error(loc, env, Signature_expected)) + +let extract_sig_open env loc mty = + match Env.scrape_alias env mty with + Mty_signature sg -> sg + | Mty_alias path -> + raise(Error(loc, env, Cannot_scrape_alias path)) + | mty -> raise(Error(loc, env, Structure_expected mty)) + +(* Compute the environment after opening a module *) + +let type_open_ ?used_slot ?toplevel ovf env loc lid = + let path = Env.lookup_module_path ~load:true ~loc:lid.loc lid.txt env in + match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with + | Ok env -> path, env + | Error _ -> + let md = Env.find_module path env in + ignore (extract_sig_open env lid.loc md.md_type); + assert false + +let initial_env ~loc ~initially_opened_module + ~open_implicit_modules = + let env = Env.initial in + let open_module env m = + let open Asttypes in + let lexbuf = Lexing.from_string m in + let txt = + Location.init lexbuf (Printf.sprintf "command line argument: -open %S" m); + Parse.simple_module_path lexbuf in + snd (type_open_ Override env loc {txt;loc}) + in + let add_units env units = + String.Set.fold + (fun name env -> + Env.add_persistent_structure (Ident.create_persistent name) env) + units + env + in + let units = + List.map Env.persistent_structures_of_dir (Load_path.get_visible ()) + in + let env, units = + match initially_opened_module with + | None -> (env, units) + | Some m -> + (* Locate the directory that contains [m], adds the units it + contains to the environment and open [m] in the resulting + environment. *) + let rec loop before after = + match after with + | [] -> None + | units :: after -> + if String.Set.mem m units then + Some (units, List.rev_append before after) + else + loop (units :: before) after + in + let env, units = + match loop [] units with + | None -> + (env, units) + | Some (units_containing_m, other_units) -> + (add_units env units_containing_m, other_units) + in + (open_module env m, units) + in + let env = List.fold_left add_units env units in + List.fold_left open_module env open_implicit_modules + +let type_open_descr ?used_slot ?toplevel env sod = + let (path, newenv) = + Builtin_attributes.warning_scope sod.popen_attributes + (fun () -> + type_open_ ?used_slot ?toplevel sod.popen_override env sod.popen_loc + sod.popen_expr + ) + in + let od = + { + open_expr = (path, sod.popen_expr); + open_bound_items = []; + open_override = sod.popen_override; + open_env = newenv; + open_attributes = sod.popen_attributes; + open_loc = sod.popen_loc; + } + in + (od, newenv) + +(* Forward declaration, to be filled in by type_module_type_of *) +let type_module_type_of_fwd : + (Env.t -> Parsetree.module_expr -> + Typedtree.module_expr * Types.module_type) ref + = ref (fun _env _m -> assert false) + +(* Additional validity checks on type definitions arising from + recursive modules *) + +let check_recmod_typedecls env decls = + let recmod_ids = List.map fst decls in + List.iter + (fun (id, md) -> + List.iter + (fun path -> + Typedecl.check_recmod_typedecl env md.Types.md_loc recmod_ids + path (Env.find_type path env)) + (Mtype.type_paths env (Pident id) md.Types.md_type)) + decls + +(* Merge one "with" constraint in a signature *) + +let check_type_decl env sg loc id row_id newdecl decl = + let fresh_id = Ident.rename id in + let path = Pident fresh_id in + let sub = Subst.add_type id path Subst.identity in + let fresh_row_id, sub = + match row_id with + | None -> None, sub + | Some id -> + let fresh_row_id = Some (Ident.rename id) in + let sub = Subst.add_type id (Pident fresh_id) sub in + fresh_row_id, sub + in + let newdecl = Subst.type_declaration sub newdecl in + let decl = Subst.type_declaration sub decl in + let sg = List.map (Subst.signature_item Keep sub) sg in + let env = Env.add_type ~check:false fresh_id newdecl env in + let env = + match fresh_row_id with + | None -> env + | Some fresh_row_id -> Env.add_type ~check:false fresh_row_id newdecl env + in + let env = Env.add_signature sg env in + Includemod.type_declarations ~mark:Mark_both ~loc env fresh_id newdecl decl; + Typedecl.check_coherence env loc path newdecl + +let make_variance p n i = + let open Variance in + set_if p May_pos (set_if n May_neg (set_if i Inj null)) + +let rec iter_path_apply p ~f = + match p with + | Pident _ -> () + | Pdot (p, _) -> iter_path_apply p ~f + | Papply (p1, p2) -> + iter_path_apply p1 ~f; + iter_path_apply p2 ~f; + f p1 p2 (* after recursing, so we know both paths are well typed *) + | Pextra_ty _ -> assert false + +let path_is_strict_prefix = + let rec list_is_strict_prefix l ~prefix = + match l, prefix with + | [], [] -> false + | _ :: _, [] -> true + | [], _ :: _ -> false + | s1 :: t1, s2 :: t2 -> + String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2 + in + fun path ~prefix -> + match Path.flatten path, Path.flatten prefix with + | `Contains_apply, _ | _, `Contains_apply -> false + | `Ok (ident1, l1), `Ok (ident2, l2) -> + Ident.same ident1 ident2 + && list_is_strict_prefix l1 ~prefix:l2 + +let iterator_with_env super env = + let env = ref (lazy env) in + env, { super with + Btype.it_signature = (fun self sg -> + (* add all items to the env before recursing down, to handle recursive + definitions *) + let env_before = !env in + env := lazy (Env.add_signature sg (Lazy.force env_before)); + super.Btype.it_signature self sg; + env := env_before + ); + Btype.it_module_type = (fun self -> function + | Mty_functor (param, mty_body) -> + let env_before = !env in + begin match param with + | Unit -> () + | Named (param, mty_arg) -> + self.Btype.it_module_type self mty_arg; + match param with + | None -> () + | Some id -> + env := lazy (Env.add_module ~arg:true id Mp_present + mty_arg (Lazy.force env_before)) + end; + self.Btype.it_module_type self mty_body; + env := env_before; + | mty -> + super.Btype.it_module_type self mty + ) + } + +let retype_applicative_functor_type ~loc env funct arg = + let mty_functor = (Env.find_module funct env).md_type in + let mty_arg = (Env.find_module arg env).md_type in + let mty_param = + match Env.scrape_alias env mty_functor with + | Mty_functor (Named (_, mty_param), _) -> mty_param + | _ -> assert false (* could trigger due to MPR#7611 *) + in + Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param + +(* When doing a deep destructive substitution with type M.N.t := .., we change M + and M.N and so we have to check that uses of the modules other than just + extracting components from them still make sense. There are only two such + kinds of uses: + - applicative functor types: F(M).t might not be well typed anymore + - aliases: module A = M still makes sense but it doesn't mean the same thing + anymore, so it's forbidden until it's clear what we should do with it. + This function would be called with M.N.t and N.t to check for these uses. *) +let check_usage_of_path_of_substituted_item paths ~loc ~lid env super = + { super with + Btype.it_signature_item = (fun self -> function + | Sig_module (id, _, { md_type = Mty_alias aliased_path; _ }, _, _) + when List.exists + (fun path -> path_is_strict_prefix path ~prefix:aliased_path) + paths + -> + let e = With_changes_module_alias (lid.txt, id, aliased_path) in + raise(Error(loc, Lazy.force !env, e)) + | sig_item -> + super.Btype.it_signature_item self sig_item + ); + Btype.it_path = (fun referenced_path -> + iter_path_apply referenced_path ~f:(fun funct arg -> + if List.exists + (fun path -> path_is_strict_prefix path ~prefix:arg) + paths + then + let env = Lazy.force !env in + match retype_applicative_functor_type ~loc env funct arg with + | None -> () + | Some explanation -> + raise(Error(loc, env, + With_makes_applicative_functor_ill_typed + (lid.txt, referenced_path, explanation))) + ) + ); + } + +(* When doing a module type destructive substitution [with module type T = RHS] + where RHS is not a module type path, we need to check that the module type + T was not used as a path for a packed module +*) +let check_usage_of_module_types ~error ~paths ~loc env super = + let it_do_type_expr it ty = match get_desc ty with + | Tpackage (p, _) -> + begin match List.find_opt (Path.same p) paths with + | Some p -> raise (Error(loc,Lazy.force !env,error p)) + | _ -> super.Btype.it_do_type_expr it ty + end + | _ -> super.Btype.it_do_type_expr it ty in + { super with Btype.it_do_type_expr } + +let do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg = + with_type_mark begin fun mark -> + let env, iterator = iterator_with_env (Btype.type_iterators mark) env in + let last, rest = match List.rev paths with + | [] -> assert false + | last :: rest -> last, rest + in + (* The last item is the one that's removed. We don't need to check how + it's used since it's replaced by a more specific type/module. *) + assert (match last with Pident _ -> true | _ -> false); + let iterator = match rest with + | [] -> iterator + | _ :: _ -> + check_usage_of_path_of_substituted_item rest ~loc ~lid env iterator + in + let iterator = match unpackable_modtype with + | None -> iterator + | Some mty -> + let error p = With_cannot_remove_packed_modtype(p,mty) in + check_usage_of_module_types ~error ~paths ~loc env iterator + in + iterator.Btype.it_signature iterator sg + end + +let check_usage_after_substitution env ~loc ~lid paths unpackable_modtype sg = + match paths, unpackable_modtype with + | [_], None -> () + | _ -> do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg + +(* After substitution one also needs to re-check the well-foundedness + of type declarations in recursive modules *) +let rec extract_next_modules = function + | Sig_module (id, _, mty, Trec_next, _) :: rem -> + let (id_mty_l, rem) = extract_next_modules rem in + ((id, mty) :: id_mty_l, rem) + | sg -> ([], sg) + +let check_well_formed_module env loc context mty = + (* Format.eprintf "@[check_well_formed_module@ %a@]@." + Printtyp.modtype mty; *) + let open Btype in + let iterator = + let rec check_signature env = function + | [] -> () + | Sig_module (id, _, mty, Trec_first, _) :: rem -> + let (id_mty_l, rem) = extract_next_modules rem in + begin try + check_recmod_typedecls (Lazy.force env) ((id, mty) :: id_mty_l) + with Typedecl.Error (_, err) -> + raise (Error (loc, Lazy.force env, + Badly_formed_signature(context, err))) + end; + check_signature env rem + | _ :: rem -> + check_signature env rem + in + let env, super = + iterator_with_env Btype.type_iterators_without_type_expr env in + { super with + it_signature = (fun self sg -> + let env_before = !env in + let env = lazy (Env.add_signature sg (Lazy.force env_before)) in + check_signature env sg; + super.it_signature self sg); + } + in + iterator.it_module_type iterator mty + +let () = Env.check_well_formed_module := check_well_formed_module + +let type_decl_is_alias sdecl = (* assuming no explicit constraint *) + match sdecl.ptype_manifest with + | Some {ptyp_desc = Ptyp_constr (lid, stl)} + when List.length stl = List.length sdecl.ptype_params -> + begin + match + List.iter2 (fun x (y, _) -> + match x, y with + {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy} + when sx = sy -> () + | _, _ -> raise Exit) + stl sdecl.ptype_params; + with + | exception Exit -> None + | () -> Some lid + end + | _ -> None + +let params_are_constrained = + let rec loop = function + | [] -> false + | hd :: tl -> + match get_desc hd with + | Tvar _ -> List.memq hd tl || loop tl + | _ -> true + in + loop + +type with_info = + | With_type of Parsetree.type_declaration + | With_typesubst of Parsetree.type_declaration + | With_module of { + lid:Longident.t loc; + path:Path.t; + md:Types.module_declaration; + remove_aliases:bool + } + | With_modsubst of Longident.t loc * Path.t * Types.module_declaration + | With_modtype of Typedtree.module_type + | With_modtypesubst of Typedtree.module_type + | With_type_package of Typedtree.core_type + (* Package with type constraints only use this last case. Normal module + with constraints never use it. *) + +let merge_constraint initial_env loc sg lid constr = + let destructive_substitution = + match constr with + | With_type _ | With_module _ | With_modtype _ + | With_type_package _ -> false + | With_typesubst _ | With_modsubst _ | With_modtypesubst _ -> true + in + let real_ids = ref [] in + let unpackable_modtype = ref None in + let split_row_id s ghosts = + let srow = s ^ "#row" in + let rec split before = function + | Sig_type(id,_,_,_) :: rest when Ident.name id = srow -> + before, Some id, rest + | a :: rest -> split (a::before) rest + | [] -> before, None, [] + in + split [] ghosts + in + let rec patch_item constr namelist outer_sig_env sg_for_env ~ghosts item = + let return ?(ghosts=ghosts) ~replace_by info = + Some (info, {Signature_group.ghosts; replace_by}) + in + match item, namelist, constr with + | Sig_type(id, decl, rs, priv), [s], + With_type ({ptype_kind = Ptype_abstract} as sdecl) + when Ident.name id = s && Typedecl.is_fixed_type sdecl -> + let decl_row = + let arity = List.length sdecl.ptype_params in + { + type_params = + List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; + type_arity = arity; + type_kind = Type_abstract Definition; + type_private = Private; + type_manifest = None; + type_variance = + List.map + (fun (_, (v, i)) -> + let (c, n) = + match v with + | Covariant -> true, false + | Contravariant -> false, true + | NoVariance -> false, false + in + make_variance (not n) (not c) (i = Injective) + ) + sdecl.ptype_params; + type_separability = + Types.Separability.default_signature ~arity; + type_loc = sdecl.ptype_loc; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + and id_row = Ident.create_local (s^"#row") in + let initial_env = + Env.add_type ~check:false id_row decl_row initial_env + in + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let tdecl = + Typedecl.transl_with_constraint id ~fixed_row_path:(Pident id_row) + ~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in + let newdecl = tdecl.typ_type in + let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in + check_type_decl outer_sig_env sg_for_env sdecl.ptype_loc + id row_id newdecl decl; + let decl_row = {decl_row with type_params = newdecl.type_params} in + let rs' = if rs = Trec_first then Trec_not else rs in + let ghosts = + List.rev_append before_ghosts + (Sig_type(id_row, decl_row, rs', priv)::after_ghosts) + in + return ~ghosts + ~replace_by:(Some (Sig_type(id, newdecl, rs, priv))) + (Pident id, lid, Some (Twith_type tdecl)) + | Sig_type(id, sig_decl, rs, priv) , [s], + (With_type sdecl | With_typesubst sdecl as constr) + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let tdecl = + Typedecl.transl_with_constraint id + ~sig_env ~sig_decl ~outer_env:initial_env sdecl in + let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in + let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in + let ghosts = List.rev_append before_ghosts after_ghosts in + check_type_decl outer_sig_env sg_for_env loc + id row_id newdecl sig_decl; + begin match constr with + With_type _ -> + return ~ghosts + ~replace_by:(Some(Sig_type(id, newdecl, rs, priv))) + (Pident id, lid, Some (Twith_type tdecl)) + | (* With_typesubst *) _ -> + real_ids := [Pident id]; + return ~ghosts ~replace_by:None + (Pident id, lid, Some (Twith_typesubst tdecl)) + end + | Sig_type(id, sig_decl, rs, priv), [s], With_type_package cty + when Ident.name id = s -> + begin match sig_decl.type_manifest with + | None -> () + | Some ty -> + raise (Error(loc, outer_sig_env, With_package_manifest (lid.txt, ty))) + end; + let tdecl = + Typedecl.transl_package_constraint ~loc outer_sig_env cty.ctyp_type + in + check_type_decl outer_sig_env sg_for_env loc id None tdecl sig_decl; + let tdecl = { tdecl with type_manifest = None } in + return ~ghosts ~replace_by:(Some(Sig_type(id, tdecl, rs, priv))) + (Pident id, lid, None) + | Sig_modtype(id, mtd, priv), [s], + (With_modtype mty | With_modtypesubst mty) + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let () = match mtd.mtd_type with + | None -> () + | Some previous_mty -> + Includemod.check_modtype_equiv ~loc sig_env + id previous_mty mty.mty_type + in + if not destructive_substitution then + let mtd': modtype_declaration = + { + mtd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + mtd_type = Some mty.mty_type; + mtd_attributes = []; + mtd_loc = loc; + } + in + return + ~replace_by:(Some(Sig_modtype(id, mtd', priv))) + (Pident id, lid, Some (Twith_modtype mty)) + else begin + let path = Pident id in + real_ids := [path]; + begin match mty.mty_type with + | Mty_ident _ -> () + | mty -> unpackable_modtype := Some mty + end; + return ~replace_by:None + (Pident id, lid, Some (Twith_modtypesubst mty)) + end + | Sig_module(id, pres, md, rs, priv), [s], + With_module {lid=lid'; md=md'; path; remove_aliases} + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let mty = md'.md_type in + let mty = Mtype.scrape_for_type_of ~remove_aliases sig_env mty in + let md'' = { md' with md_type = mty } in + let newmd = Mtype.strengthen_decl ~aliasable:false sig_env md'' path in + ignore(Includemod.modtypes ~mark:Mark_both ~loc sig_env + newmd.md_type md.md_type); + return + ~replace_by:(Some(Sig_module(id, pres, newmd, rs, priv))) + (Pident id, lid, Some (Twith_module (path, lid'))) + | Sig_module(id, _, md, _rs, _), [s], With_modsubst (lid',path,md') + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let aliasable = not (Env.is_functor_arg path sig_env) in + ignore + (Includemod.strengthened_module_decl ~loc ~mark:Mark_both + ~aliasable sig_env md' path md); + real_ids := [Pident id]; + return ~replace_by:None + (Pident id, lid, Some (Twith_modsubst (path, lid'))) + | Sig_module(id, _, md, rs, priv) as item, s :: namelist, constr + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let sg = extract_sig sig_env loc md.md_type in + let ((path, _, tcstr), newsg) = merge_signature sig_env sg namelist in + let path = path_concat id path in + real_ids := path :: !real_ids; + let item = + match md.md_type, constr with + Mty_alias _, (With_module _ | With_type _) -> + (* A module alias cannot be refined, so keep it + and just check that the constraint is correct *) + item + | _ -> + let newmd = {md with md_type = Mty_signature newsg} in + Sig_module(id, Mp_present, newmd, rs, priv) + in + return ~replace_by:(Some item) (path, lid, tcstr) + | _ -> None + and merge_signature env sg namelist = + match + Signature_group.replace_in_place (patch_item constr namelist env sg) sg + with + | Some (x,sg) -> x, sg + | None -> raise(Error(loc, env, With_no_component lid.txt)) + in + try + let names = Longident.flatten lid.txt in + let (tcstr, sg) = merge_signature initial_env sg names in + if destructive_substitution then + check_usage_after_substitution ~loc ~lid initial_env !real_ids + !unpackable_modtype sg; + let sg = + match tcstr with + | (_, _, Some (Twith_typesubst tdecl)) -> + let how_to_extend_subst = + let sdecl = + match constr with + | With_typesubst sdecl -> sdecl + | _ -> assert false + in + match type_decl_is_alias sdecl with + | Some lid -> + let replacement, _ = + try Env.find_type_by_name lid.txt initial_env + with Not_found -> assert false + in + fun s path -> Subst.add_type_path path replacement s + | None -> + let body = Option.get tdecl.typ_type.type_manifest in + let params = tdecl.typ_type.type_params in + if params_are_constrained params + then raise(Error(loc, initial_env, + With_cannot_remove_constrained_type)); + fun s path -> Subst.add_type_function path ~params ~body s + in + let sub = Subst.change_locs Subst.identity loc in + let sub = List.fold_left how_to_extend_subst sub !real_ids in + (* This signature will not be used directly, it will always be freshened + by the caller. So what we do with the scope doesn't really matter. But + making it local makes it unlikely that we will ever use the result of + this function unfreshened without issue. *) + Subst.signature Make_local sub sg + | (_, _, Some (Twith_modsubst (real_path, _))) -> + let sub = Subst.change_locs Subst.identity loc in + let sub = + List.fold_left + (fun s path -> Subst.add_module_path path real_path s) + sub + !real_ids + in + (* See explanation in the [Twith_typesubst] case above. *) + Subst.signature Make_local sub sg + | (_, _, Some (Twith_modtypesubst tmty)) -> + let add s p = Subst.add_modtype_path p tmty.mty_type s in + let sub = Subst.change_locs Subst.identity loc in + let sub = List.fold_left add sub !real_ids in + Subst.signature Make_local sub sg + | _ -> + sg + in + check_well_formed_module initial_env loc "this instantiated signature" + (Mty_signature sg); + (tcstr, sg) + with Includemod.Error explanation -> + raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation))) + +let merge_package_constraint initial_env loc sg lid cty = + let _, s = merge_constraint initial_env loc sg lid (With_type_package cty) in + s + +let check_package_with_type_constraints loc env mty constraints = + let sg = extract_sig env loc mty in + let sg = + List.fold_left + (fun sg (lid, cty) -> + merge_package_constraint env loc sg lid cty) + sg constraints + in + let scope = Ctype.create_scope () in + Mtype.freshen ~scope (Mty_signature sg) + +let () = + Typetexp.check_package_with_type_constraints := + check_package_with_type_constraints + +(* Add recursion flags on declarations arising from a mutually recursive + block. *) + +let map_rec fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem + +let map_rec_type ~rec_flag fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> + let first = + match rec_flag with + | Recursive -> Trec_first + | Nonrecursive -> Trec_not + in + fn first d1 :: map_end (fn Trec_next) dl rem + +let rec map_rec_type_with_row_types ~rec_flag fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> + if Btype.is_row_name (Ident.name d1.typ_id) then + fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem + else + map_rec_type ~rec_flag fn decls rem + +(* Add type extension flags to extension constructors *) +let map_ext fn exts rem = + match exts with + | [] -> rem + | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem + +(* Auxiliary for translating recursively-defined module types. + Return a module type that approximates the shape of the given module + type AST. Retain only module, type, and module type + components of signatures. For types, retain only their arity, + making them abstract otherwise. *) + +let rec approx_modtype env smty = + match smty.pmty_desc with + Pmty_ident lid -> + let path = + Env.lookup_modtype_path ~use:false ~loc:smty.pmty_loc lid.txt env + in + Mty_ident path + | Pmty_alias lid -> + let path = + Env.lookup_module_path ~use:false ~load:false + ~loc:smty.pmty_loc lid.txt env + in + Mty_alias(path) + | Pmty_signature ssg -> + Mty_signature(approx_sig env ssg) + | Pmty_functor(param, sres) -> + let (param, newenv) = + match param with + | Unit -> Types.Unit, env + | Named (param, sarg) -> + let arg = approx_modtype env sarg in + match param.txt with + | None -> Types.Named (None, arg), env + | Some name -> + let rarg = Mtype.scrape_for_functor_arg env arg in + let scope = Ctype.create_scope () in + let (id, newenv) = + Env.enter_module ~scope ~arg:true name Mp_present rarg env + in + Types.Named (Some id, arg), newenv + in + let res = approx_modtype newenv sres in + Mty_functor(param, res) + | Pmty_with(sbody, constraints) -> + let body = approx_modtype env sbody in + List.iter + (fun sdecl -> + match sdecl with + | Pwith_type _ + | Pwith_typesubst _ + | Pwith_modtype _ + | Pwith_modtypesubst _ -> () + | Pwith_module (_, lid') -> + (* Lookup the module to make sure that it is not recursive. + (GPR#1626) *) + ignore (Env.lookup_module_path ~use:false ~load:false + ~loc:lid'.loc lid'.txt env) + | Pwith_modsubst (_, lid') -> + ignore (Env.lookup_module_path ~use:false ~load:false + ~loc:lid'.loc lid'.txt env)) + constraints; + body + | Pmty_typeof smod -> + let (_, mty) = !type_module_type_of_fwd env smod in + mty + | Pmty_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and approx_module_declaration env pmd = + { + Types.md_type = approx_modtype env pmd.pmd_type; + md_attributes = pmd.pmd_attributes; + md_loc = pmd.pmd_loc; + md_uid = Uid.internal_not_actually_unique; + } + +and approx_sig env ssg = + match ssg with + [] -> [] + | item :: srem -> + match item.psig_desc with + | Psig_type (rec_flag, sdecls) -> + let decls = Typedecl.approx_type_decl sdecls in + let rem = approx_sig env srem in + map_rec_type ~rec_flag + (fun rs (id, info) -> Sig_type(id, info, rs, Exported)) decls rem + | Psig_typesubst _ -> approx_sig env srem + | Psig_module { pmd_name = { txt = None; _ }; _ } -> + approx_sig env srem + | Psig_module pmd -> + let scope = Ctype.create_scope () in + let md = approx_module_declaration env pmd in + let pres = + match md.Types.md_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let id, newenv = + Env.enter_module_declaration ~scope (Option.get pmd.pmd_name.txt) + pres md env + in + Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem + | Psig_modsubst pms -> + let scope = Ctype.create_scope () in + let _, md = + Env.lookup_module ~use:false ~loc:pms.pms_manifest.loc + pms.pms_manifest.txt env + in + let pres = + match md.Types.md_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let _, newenv = + Env.enter_module_declaration ~scope pms.pms_name.txt pres md env + in + approx_sig newenv srem + | Psig_recmodule sdecls -> + let scope = Ctype.create_scope () in + let decls = + List.filter_map + (fun pmd -> + Option.map (fun name -> + Ident.create_scoped ~scope name, + approx_module_declaration env pmd + ) pmd.pmd_name.txt + ) + sdecls + in + let newenv = + List.fold_left + (fun env (id, md) -> Env.add_module_declaration ~check:false + id Mp_present md env) + env decls + in + map_rec + (fun rs (id, md) -> Sig_module(id, Mp_present, md, rs, Exported)) + decls + (approx_sig newenv srem) + | Psig_modtype d -> + let info = approx_modtype_info env d in + let scope = Ctype.create_scope () in + let (id, newenv) = + Env.enter_modtype ~scope d.pmtd_name.txt info env + in + Sig_modtype(id, info, Exported) :: approx_sig newenv srem + | Psig_modtypesubst d -> + let info = approx_modtype_info env d in + let scope = Ctype.create_scope () in + let (_id, newenv) = + Env.enter_modtype ~scope d.pmtd_name.txt info env + in + approx_sig newenv srem + | Psig_open sod -> + let _, env = type_open_descr env sod in + approx_sig env srem + | Psig_include sincl -> + let smty = sincl.pincl_mod in + let mty = approx_modtype env smty in + let scope = Ctype.create_scope () in + let sg, newenv = Env.enter_signature ~scope + (extract_sig env smty.pmty_loc mty) env in + sg @ approx_sig newenv srem + | Psig_class sdecls | Psig_class_type sdecls -> + let decls, env = Typeclass.approx_class_declarations env sdecls in + let rem = approx_sig env srem in + map_rec (fun rs decl -> + let open Typeclass in [ + Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs, + Exported); + Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported); + ] + ) decls [rem] + |> List.flatten + | _ -> + approx_sig env srem + +and approx_modtype_info env sinfo = + { + mtd_type = Option.map (approx_modtype env) sinfo.pmtd_type; + mtd_attributes = sinfo.pmtd_attributes; + mtd_loc = sinfo.pmtd_loc; + mtd_uid = Uid.internal_not_actually_unique; + } + +let approx_modtype env smty = + Warnings.without_warnings + (fun () -> approx_modtype env smty) + +(* Auxiliaries for checking the validity of name shadowing in signatures and + structures. + If a shadowing is valid, we also record some information (its ident, + location where it first appears, etc) about the item that gets shadowed. *) +module Signature_names : sig + type t + + type shadowable = + { + self: Ident.t; + group: Ident.t list; + (** group includes the element itself and all elements + that should be removed at the same time + *) + loc:Location.t; + } + + type info = [ + | `Exported + | `From_open + | `Shadowable of shadowable + | `Substituted_away of Subst.t + | `Unpackable_modtype_substituted_away of Ident.t * Subst.t + ] + + val create : unit -> t + + val check_value : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_type : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_typext : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_module : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_modtype : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_class : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_class_type: ?info:info -> t -> Location.t -> Ident.t -> unit + + val check_sig_item: + ?info:info -> t -> Location.t -> Signature_group.rec_group -> unit + + val simplify: Env.t -> t -> Types.signature -> Types.signature +end = struct + + type shadowable = + { + self: Ident.t; + group: Ident.t list; + (** group includes the element itself and all elements + that should be removed at the same time + *) + loc:Location.t; + } + + type bound_info = [ + | `Exported + | `Shadowable of shadowable + ] + + type info = [ + | `From_open + | `Substituted_away of Subst.t + | `Unpackable_modtype_substituted_away of Ident.t * Subst.t + | bound_info + ] + + type hide_reason = + | From_open + | Shadowed_by of Ident.t * Location.t + + type to_be_removed = { + mutable subst: Subst.t; + mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t; + mutable unpackable_modtypes: Ident.Set.t; + } + + type names_infos = (string, bound_info) Hashtbl.t + + type names = { + values: names_infos; + types: names_infos; + modules: names_infos; + modtypes: names_infos; + typexts: names_infos; + classes: names_infos; + class_types: names_infos; + } + + let new_names () = { + values = Hashtbl.create 16; + types = Hashtbl.create 16; + modules = Hashtbl.create 16; + modtypes = Hashtbl.create 16; + typexts = Hashtbl.create 16; + classes = Hashtbl.create 16; + class_types = Hashtbl.create 16; + } + + type t = { + bound: names; + to_be_removed: to_be_removed; + } + + let create () = { + bound = new_names (); + to_be_removed = { + subst = Subst.identity; + hide = Ident.Map.empty; + unpackable_modtypes = Ident.Set.empty; + }; + } + + let table_for component names = + let open Sig_component_kind in + match component with + | Value -> names.values + | Type | Label | Constructor -> names.types + | Module -> names.modules + | Module_type -> names.modtypes + | Extension_constructor -> names.typexts + | Class -> names.classes + | Class_type -> names.class_types + + let check cl t loc id (info : info) = + let to_be_removed = t.to_be_removed in + match info with + | `Substituted_away s -> + to_be_removed.subst <- Subst.compose s to_be_removed.subst; + | `Unpackable_modtype_substituted_away (id,s) -> + to_be_removed.subst <- Subst.compose s to_be_removed.subst; + to_be_removed.unpackable_modtypes <- + Ident.Set.add id to_be_removed.unpackable_modtypes + | `From_open -> + to_be_removed.hide <- + Ident.Map.add id (cl, loc, From_open) to_be_removed.hide + | #bound_info as bound_info -> + let tbl = table_for cl t.bound in + let name = Ident.name id in + match Hashtbl.find_opt tbl name with + | None -> Hashtbl.add tbl name bound_info + | Some (`Shadowable s) -> + Hashtbl.replace tbl name bound_info; + let reason = Shadowed_by (id, loc) in + List.iter (fun shadowed_id -> + to_be_removed.hide <- + Ident.Map.add shadowed_id (cl, s.loc, reason) + to_be_removed.hide + ) s.group + | Some `Exported -> + raise(Error(loc, Env.empty, Repeated_name(cl, name))) + + let check_value ?info t loc id = + let info = + match info with + | Some i -> i + | None -> `Shadowable {self=id; group=[id]; loc} + in + check Sig_component_kind.Value t loc id info + let check_type ?(info=`Exported) t loc id = + check Sig_component_kind.Type t loc id info + let check_module ?(info=`Exported) t loc id = + check Sig_component_kind.Module t loc id info + let check_modtype ?(info=`Exported) t loc id = + check Sig_component_kind.Module_type t loc id info + let check_typext ?(info=`Exported) t loc id = + check Sig_component_kind.Extension_constructor t loc id info + let check_class ?(info=`Exported) t loc id = + check Sig_component_kind.Class t loc id info + let check_class_type ?(info=`Exported) t loc id = + check Sig_component_kind.Class_type t loc id info + + let classify = + let open Sig_component_kind in + function + | Sig_type(id, _, _, _) -> Type, id + | Sig_module(id, _, _, _, _) -> Module, id + | Sig_modtype(id, _, _) -> Module_type, id + | Sig_typext(id, _, _, _) -> Extension_constructor, id + | Sig_value (id, _, _) -> Value, id + | Sig_class (id, _, _, _) -> Class, id + | Sig_class_type (id, _, _, _) -> Class_type, id + + let check_item ?info names loc kind id ids = + let info = + match info with + | None -> `Shadowable {self=id; group=ids; loc} + | Some i -> i + in + check kind names loc id info + + let check_sig_item ?info names loc (item:Signature_group.rec_group) = + let check ?info names loc item = + let all = List.map classify (Signature_group.flatten item) in + let group = List.map snd all in + List.iter (fun (kind,id) -> check_item ?info names loc kind id group) + all + in + (* we can ignore x.pre_ghosts: they are eliminated by strengthening, and + thus never appear in includes *) + List.iter (check ?info names loc) (Signature_group.rec_items item.group) + + (* + Before applying local module type substitutions where the + right-hand side is not a path, we need to check that those module types + where never used to pack modules. For instance + {[ + module type T := sig end + val x: (module T) + ]} + should raise an error. + *) + let check_unpackable_modtypes ~loc ~env to_remove component = + if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then + with_type_mark begin fun mark -> + let iterator = + let error p = Unpackable_local_modtype_subst p in + let paths = + List.map (fun id -> Pident id) + (Ident.Set.elements to_remove.unpackable_modtypes) + in + check_usage_of_module_types ~loc ~error ~paths + (ref (lazy env)) (Btype.type_iterators mark) + in + iterator.Btype.it_signature_item iterator component + end + + (* We usually require name uniqueness of signature components (e.g. types, + modules, etc), however in some situation reusing the name is allowed: if + the component is a value or an extension, or if the name is introduced by + an include. + When there are multiple specifications of a component with the same name, + we try to keep only the last (rightmost) one, removing all references to + the previous ones from the signature. + If some reference cannot be removed, then we error out with + [Cannot_hide_id]. + *) + + let simplify env t sg = + let to_remove = t.to_be_removed in + let ids_to_remove = + Ident.Map.fold (fun id (kind, _, _) lst -> + if Sig_component_kind.can_appear_in_types kind then + id :: lst + else + lst + ) to_remove.hide [] + in + let simplify_item (component: Types.signature_item) = + let user_kind, user_id, user_loc = + let open Sig_component_kind in + match component with + | Sig_value(id, v, _) -> Value, id, v.val_loc + | Sig_type (id, td, _, _) -> Type, id, td.type_loc + | Sig_typext (id, te, _, _) -> Extension_constructor, id, te.ext_loc + | Sig_module (id, _, md, _, _) -> Module, id, md.md_loc + | Sig_modtype (id, mtd, _) -> Module_type, id, mtd.mtd_loc + | Sig_class (id, c, _, _) -> Class, id, c.cty_loc + | Sig_class_type (id, ct, _, _) -> Class_type, id, ct.clty_loc + in + if Ident.Map.mem user_id to_remove.hide then + None + else begin + let component = + if to_remove.subst == Subst.identity then + component + else + begin + check_unpackable_modtypes ~loc:user_loc ~env to_remove component; + Subst.signature_item Keep to_remove.subst component + end + in + let component = + match ids_to_remove with + | [] -> component + | ids -> + try Mtype.nondep_sig_item env ids component with + | Ctype.Nondep_cannot_erase removed_item_id -> + let (removed_item_kind, removed_item_loc, reason) = + Ident.Map.find removed_item_id to_remove.hide + in + let err_loc, hiding_error = + match reason with + | From_open -> + removed_item_loc, + Appears_in_signature { + opened_item_kind = removed_item_kind; + opened_item_id = removed_item_id; + user_id; + user_kind; + user_loc; + } + | Shadowed_by (shadower_id, shadower_loc) -> + shadower_loc, + Illegal_shadowing { + shadowed_item_kind = removed_item_kind; + shadowed_item_id = removed_item_id; + shadowed_item_loc = removed_item_loc; + shadower_id; + user_id; + user_kind; + user_loc; + } + in + raise (Error(err_loc, env, Cannot_hide_id hiding_error)) + in + Some component + end + in + List.filter_map simplify_item sg +end + +let has_remove_aliases_attribute attr = + let remove_aliases = + Attr_helper.get_no_payload_attribute "remove_aliases" attr + in + match remove_aliases with + | None -> false + | Some _ -> true + +(* Check and translate a module type expression *) + +let transl_modtype_longident loc env lid = + Env.lookup_modtype_path ~loc lid env + +let transl_module_alias loc env lid = + Env.lookup_module_path ~load:false ~loc lid env + +let mkmty desc typ env loc attrs = + let mty = { + mty_desc = desc; + mty_type = typ; + mty_loc = loc; + mty_env = env; + mty_attributes = attrs; + } in + Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); + mty + +let mksig desc env loc = + let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in + Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); + sg + +(* let signature sg = List.map (fun item -> item.sig_type) sg *) + +let rec transl_modtype env smty = + Builtin_attributes.warning_scope smty.pmty_attributes + (fun () -> transl_modtype_aux env smty) + +and transl_modtype_functor_arg env sarg = + let mty = transl_modtype env sarg in + {mty with mty_type = Mtype.scrape_for_functor_arg env mty.mty_type} + +and transl_modtype_aux env smty = + let loc = smty.pmty_loc in + match smty.pmty_desc with + Pmty_ident lid -> + let path = transl_modtype_longident loc env lid.txt in + mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc + smty.pmty_attributes + | Pmty_alias lid -> + let path = transl_module_alias loc env lid.txt in + mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc + smty.pmty_attributes + | Pmty_signature ssg -> + let sg = transl_signature env ssg in + mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc + smty.pmty_attributes + | Pmty_functor(sarg_opt, sres) -> + let t_arg, ty_arg, newenv = + match sarg_opt with + | Unit -> Unit, Types.Unit, env + | Named (param, sarg) -> + let arg = transl_modtype_functor_arg env sarg in + let (id, newenv) = + match param.txt with + | None -> None, env + | Some name -> + let scope = Ctype.create_scope () in + let id, newenv = + let arg_md = + { md_type = arg.mty_type; + md_attributes = []; + md_loc = param.loc; + md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + Env.enter_module_declaration ~scope ~arg:true name Mp_present + arg_md env + in + Some id, newenv + in + Named (id, param, arg), Types.Named (id, arg.mty_type), newenv + in + let res = transl_modtype newenv sres in + mkmty (Tmty_functor (t_arg, res)) + (Mty_functor(ty_arg, res.mty_type)) env loc + smty.pmty_attributes + | Pmty_with(sbody, constraints) -> + let body = transl_modtype env sbody in + let init_sg = extract_sig env sbody.pmty_loc body.mty_type in + let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in + let (rev_tcstrs, final_sg) = + List.fold_left (transl_with ~loc:smty.pmty_loc env remove_aliases) + ([],init_sg) constraints in + let scope = Ctype.create_scope () in + mkmty (Tmty_with ( body, List.rev rev_tcstrs)) + (Mtype.freshen ~scope (Mty_signature final_sg)) env loc + smty.pmty_attributes + | Pmty_typeof smod -> + let env = Env.in_signature false env in + let tmty, mty = !type_module_type_of_fwd env smod in + mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes + | Pmty_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr = + let lid, with_info = match constr with + | Pwith_type (l,decl) ->l , With_type decl + | Pwith_typesubst (l,decl) ->l , With_typesubst decl + | Pwith_module (l,l') -> + let path, md = Env.lookup_module ~loc l'.txt env in + l , With_module {lid=l';path;md; remove_aliases} + | Pwith_modsubst (l,l') -> + let path, md' = Env.lookup_module ~loc l'.txt env in + l , With_modsubst (l',path,md') + | Pwith_modtype (l,smty) -> + let mty = transl_modtype env smty in + l, With_modtype mty + | Pwith_modtypesubst (l,smty) -> + let mty = transl_modtype env smty in + l, With_modtypesubst mty + in + let ((path, lid, tcstr), sg) = merge_constraint env loc sg lid with_info in + (* Only package with constraints result in None here. *) + let tcstr = Option.get tcstr in + ((path, lid, tcstr) :: rev_tcstrs, sg) + + + +and transl_signature env sg = + let names = Signature_names.create () in + let rec transl_sig env sg = + match sg with + [] -> [], [], env + | item :: srem -> + let loc = item.psig_loc in + match item.psig_desc with + | Psig_value sdesc -> + let (tdesc, newenv) = + Typedecl.transl_value_decl env item.psig_loc sdesc + in + Signature_names.check_value names tdesc.val_loc tdesc.val_id; + let (trem,rem, final_env) = transl_sig newenv srem in + mksig (Tsig_value tdesc) env loc :: trem, + Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem, + final_env + | Psig_type (rec_flag, sdecls) -> + let (decls, newenv, _) = + Typedecl.transl_type_decl env rec_flag sdecls + in + List.iter (fun td -> + Signature_names.check_type names td.typ_loc td.typ_id; + ) decls; + let (trem, rem, final_env) = transl_sig newenv srem in + let sg = + map_rec_type_with_row_types ~rec_flag + (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs, Exported)) + decls rem + in + mksig (Tsig_type (rec_flag, decls)) env loc :: trem, + sg, + final_env + | Psig_typesubst sdecls -> + let (decls, newenv, _) = + Typedecl.transl_type_decl env Nonrecursive sdecls + in + List.iter (fun td -> + if td.typ_kind <> Ttype_abstract || td.typ_manifest = None || + td.typ_private = Private + then + raise (Error (td.typ_loc, env, Invalid_type_subst_rhs)); + let params = td.typ_type.type_params in + if params_are_constrained params + then raise(Error(loc, env, With_cannot_remove_constrained_type)); + let info = + let subst = + Subst.add_type_function (Pident td.typ_id) + ~params + ~body:(Option.get td.typ_type.type_manifest) + Subst.identity + in + Some (`Substituted_away subst) + in + Signature_names.check_type ?info names td.typ_loc td.typ_id + ) decls; + let (trem, rem, final_env) = transl_sig newenv srem in + let sg = rem + in + mksig (Tsig_typesubst decls) env loc :: trem, + sg, + final_env + | Psig_typext styext -> + let (tyext, newenv, _shapes) = + Typedecl.transl_type_extension false env item.psig_loc styext + in + let constructors = tyext.tyext_constructors in + List.iter (fun ext -> + Signature_names.check_typext names ext.ext_loc ext.ext_id + ) constructors; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_typext tyext) env loc :: trem, + map_ext (fun es ext -> + Sig_typext(ext.ext_id, ext.ext_type, es, Exported) + ) constructors rem, + final_env + | Psig_exception sext -> + let (ext, newenv, _s) = Typedecl.transl_type_exception env sext in + let constructor = ext.tyexn_constructor in + Signature_names.check_typext names constructor.ext_loc + constructor.ext_id; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_exception ext) env loc :: trem, + Sig_typext(constructor.ext_id, + constructor.ext_type, + Text_exception, + Exported) :: rem, + final_env + | Psig_module pmd -> + let scope = Ctype.create_scope () in + let tmty = + Builtin_attributes.warning_scope pmd.pmd_attributes + (fun () -> transl_modtype env pmd.pmd_type) + in + let pres = + match tmty.mty_type with + | Mty_alias p -> + if Env.is_functor_arg p env then + raise (Error (pmd.pmd_loc, env, Cannot_alias p)); + Mp_absent + | _ -> Mp_present + in + let md = { + md_type=tmty.mty_type; + md_attributes=pmd.pmd_attributes; + md_loc=pmd.pmd_loc; + md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let id, newenv = + match pmd.pmd_name.txt with + | None -> None, env + | Some name -> + let id, newenv = + Env.enter_module_declaration ~scope name pres md env + in + Signature_names.check_module names pmd.pmd_name.loc id; + Some id, newenv + in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; + md_uid=md.md_uid; md_presence=pres; + md_type=tmty; md_loc=pmd.pmd_loc; + md_attributes=pmd.pmd_attributes}) + env loc :: trem, + (match id with + | None -> rem + | Some id -> Sig_module(id, pres, md, Trec_not, Exported) :: rem), + final_env + | Psig_modsubst pms -> + let scope = Ctype.create_scope () in + let path, md = + Env.lookup_module ~loc:pms.pms_manifest.loc + pms.pms_manifest.txt env + in + let aliasable = not (Env.is_functor_arg path env) in + let md = + if not aliasable then + md + else + { md_type = Mty_alias path; + md_attributes = pms.pms_attributes; + md_loc = pms.pms_loc; + md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let pres = + match md.md_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let id, newenv = + Env.enter_module_declaration ~scope pms.pms_name.txt pres md env + in + let info = + `Substituted_away (Subst.add_module id path Subst.identity) + in + Signature_names.check_module ~info names pms.pms_name.loc id; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; + ms_uid=md.md_uid; ms_manifest=path; + ms_txt=pms.pms_manifest; ms_loc=pms.pms_loc; + ms_attributes=pms.pms_attributes}) + env loc :: trem, + rem, + final_env + | Psig_recmodule sdecls -> + let (tdecls, newenv) = + transl_recmodule_modtypes env sdecls in + let decls = + List.filter_map (fun (md, uid, _) -> + match md.md_id with + | None -> None + | Some id -> Some (id, md, uid) + ) tdecls + in + List.iter (fun (id, md, _uid) -> + Signature_names.check_module names md.md_loc id; + ) decls; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_recmodule (List.map (fun (md, _, _) -> md) tdecls)) + env loc :: trem, + map_rec (fun rs (id, md, uid) -> + let d = {Types.md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + md_uid = uid; + } in + Sig_module(id, Mp_present, d, rs, Exported)) + decls rem, + final_env + | Psig_modtype pmtd -> + let newenv, mtd, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtype mtd) env loc :: trem, + Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, + final_env + | Psig_modtypesubst pmtd -> + let newenv, mtd, _decl = transl_modtype_decl env pmtd in + let info = + let mty = match mtd.mtd_type with + | Some tmty -> tmty.mty_type + | None -> + (* parsetree invariant, see Ast_invariants *) + assert false + in + let subst = Subst.add_modtype mtd.mtd_id mty Subst.identity in + match mty with + | Mty_ident _ -> `Substituted_away subst + | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst) + in + Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtypesubst mtd) env loc :: trem, + rem, + final_env + | Psig_open sod -> + let (od, newenv) = type_open_descr env sod in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_open od) env loc :: trem, + rem, final_env + | Psig_include sincl -> + let smty = sincl.pincl_mod in + let tmty = + Builtin_attributes.warning_scope sincl.pincl_attributes + (fun () -> transl_modtype env smty) + in + let mty = tmty.mty_type in + let scope = Ctype.create_scope () in + let sg, newenv = Env.enter_signature ~scope + (extract_sig env smty.pmty_loc mty) env in + Signature_group.iter + (Signature_names.check_sig_item names item.psig_loc) + sg; + let incl = + { incl_mod = tmty; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_include incl) env loc :: trem, + sg @ rem, + final_env + | Psig_class cl -> + let (classes, newenv) = Typeclass.class_descriptions env cl in + List.iter (fun cls -> + let open Typeclass in + let loc = cls.cls_id_loc.Location.loc in + Signature_names.check_type names loc cls.cls_obj_id; + Signature_names.check_class names loc cls.cls_id; + Signature_names.check_class_type names loc cls.cls_ty_id; + ) classes; + let (trem, rem, final_env) = transl_sig newenv srem in + let sg = + map_rec (fun rs cls -> + let open Typeclass in + [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported); + Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported); + Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported) + ] + ) classes [rem] + |> List.flatten + in + let typedtree = + mksig (Tsig_class + (List.map (fun decr -> + decr.Typeclass.cls_info) classes)) env loc + :: trem + in + typedtree, sg, final_env + | Psig_class_type cl -> + let (classes, newenv) = Typeclass.class_type_declarations env cl in + List.iter (fun decl -> + let open Typeclass in + let loc = decl.clsty_id_loc.Location.loc in + Signature_names.check_class_type names loc decl.clsty_ty_id; + Signature_names.check_type names loc decl.clsty_obj_id; + ) classes; + let (trem,rem, final_env) = transl_sig newenv srem in + let sg = + map_rec (fun rs decl -> + let open Typeclass in + [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs, + Exported); + Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported); + ] + ) classes [rem] + |> List.flatten + in + let typedtree = + mksig + (Tsig_class_type + (List.map (fun decl -> decl.Typeclass.clsty_info) classes)) + env loc + :: trem + in + typedtree, sg, final_env + | Psig_attribute x -> + Builtin_attributes.warning_attribute x; + let (trem,rem, final_env) = transl_sig env srem in + mksig (Tsig_attribute x) env loc :: trem, rem, final_env + | Psig_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + in + let previous_saved_types = Cmt_format.get_saved_types () in + Builtin_attributes.warning_scope [] + (fun () -> + let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in + let rem = Signature_names.simplify final_env names rem in + let sg = + { sig_items = trem; sig_type = rem; sig_final_env = final_env } + in + Cmt_format.set_saved_types + ((Cmt_format.Partial_signature sg) :: previous_saved_types); + sg + ) + +and transl_modtype_decl env pmtd = + Builtin_attributes.warning_scope pmtd.pmtd_attributes + (fun () -> transl_modtype_decl_aux env pmtd) + +and transl_modtype_decl_aux env + {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = + let tmty = + Option.map (transl_modtype (Env.in_signature true env)) pmtd_type + in + let decl = + { + Types.mtd_type=Option.map (fun t -> t.mty_type) tmty; + mtd_attributes=pmtd_attributes; + mtd_loc=pmtd_loc; + mtd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let scope = Ctype.create_scope () in + let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in + let mtd = + { + mtd_id=id; + mtd_name=pmtd_name; + mtd_uid=decl.mtd_uid; + mtd_type=tmty; + mtd_attributes=pmtd_attributes; + mtd_loc=pmtd_loc; + } + in + newenv, mtd, decl + +and transl_recmodule_modtypes env sdecls = + let make_env curr = + List.fold_left (fun env (id_shape, _, md, _) -> + Option.fold ~none:env ~some:(fun (id, shape) -> + Env.add_module_declaration ~check:true ~shape ~arg:true + id Mp_present md env + ) id_shape + ) env curr + in + let transition env_c curr = + List.map2 + (fun pmd (id_shape, id_loc, md, _) -> + let tmty = + Builtin_attributes.warning_scope pmd.pmd_attributes + (fun () -> transl_modtype env_c pmd.pmd_type) + in + let md = { md with Types.md_type = tmty.mty_type } in + (id_shape, id_loc, md, tmty)) + sdecls curr in + let map_mtys curr = + List.filter_map + (fun (id_shape, _, md, _) -> + Option.map (fun (id, _) -> (id, md)) id_shape) + curr + in + let scope = Ctype.create_scope () in + let ids = + List.map (fun x -> Option.map (Ident.create_scoped ~scope) x.pmd_name.txt) + sdecls + in + let approx_env = + List.fold_left + (fun env -> + Option.fold ~none:env ~some:(fun id -> (* cf #5965 *) + Env.enter_unbound_module (Ident.name id) + Mod_unbound_illegal_recursion env + )) + env ids + in + let init = + List.map2 + (fun id pmd -> + let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let md = + { md_type = approx_modtype approx_env pmd.pmd_type; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + md_uid } + in + let id_shape = + Option.map (fun id -> id, Shape.var md_uid id) id + in + (id_shape, pmd.pmd_name, md, ())) + ids sdecls + in + let env0 = make_env init in + let dcl1 = + Warnings.without_warnings + (fun () -> transition env0 init) + in + let env1 = make_env dcl1 in + check_recmod_typedecls env1 (map_mtys dcl1); + let dcl2 = transition env1 dcl1 in +(* + List.iter + (fun (id, mty) -> + Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) + dcl2; +*) + let env2 = make_env dcl2 in + check_recmod_typedecls env2 (map_mtys dcl2); + let dcl2 = + List.map2 (fun pmd (id_shape, id_loc, md, mty) -> + let tmd = + {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty; + md_uid=md.Types.md_uid; md_presence=Mp_present; + md_loc=pmd.pmd_loc; + md_attributes=pmd.pmd_attributes} + in + tmd, md.Types.md_uid, Option.map snd id_shape + ) sdecls dcl2 + in + (dcl2, env2) + +(* Try to convert a module expression to a module path. *) + +exception Not_a_path + +let rec path_of_module mexp = + match mexp.mod_desc with + | Tmod_ident (p,_) -> p + | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors -> + Papply(path_of_module funct, path_of_module arg) + | Tmod_constraint (mexp, _, _, _) -> + path_of_module mexp + | (Tmod_structure _ | Tmod_functor _ | Tmod_apply_unit _ | Tmod_unpack _ | + Tmod_apply _) -> + raise Not_a_path + +let path_of_module mexp = + try Some (path_of_module mexp) with Not_a_path -> None + +(* Check that all core type schemes in a structure + do not contain non-generalized type variable *) + +let rec nongen_modtype env = function + Mty_ident _ -> None + | Mty_alias _ -> None + | Mty_signature sg -> + let env = Env.add_signature sg env in + List.find_map (nongen_signature_item env) sg + | Mty_functor(arg_opt, body) -> + let env = + match arg_opt with + | Unit + | Named (None, _) -> env + | Named (Some id, param) -> + Env.add_module ~arg:true id Mp_present param env + in + nongen_modtype env body + +and nongen_signature_item env = function + | Sig_value(_id, desc, _) -> + Ctype.nongen_vars_in_schema env desc.val_type + |> Option.map (fun vars -> (vars, desc)) + | Sig_module(_id, _, md, _, _) -> nongen_modtype env md.md_type + | _ -> None + +let check_nongen_modtype env loc mty = + nongen_modtype env mty + |> Option.iter (fun (vars, item) -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable_module { vars; item; mty } + in + raise(Error(loc, env, error)) + ) + +let check_nongen_signature_item env sig_item = + match sig_item with + Sig_value(_id, vd, _) -> + Ctype.nongen_vars_in_schema env vd.val_type + |> Option.iter (fun vars -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable { vars; expression = vd.val_type } + in + raise (Error (vd.val_loc, env, error)) + ) + | Sig_module (_id, _, md, _, _) -> + check_nongen_modtype env md.md_loc md.md_type + | _ -> () + +let check_nongen_signature env sg = + List.iter (check_nongen_signature_item env) sg + +(* Helpers for typing recursive modules *) + +let anchor_submodule name anchor = + match anchor, name with + | None, _ + | _, None -> + None + | Some p, Some name -> + Some(Pdot(p, name)) + +let anchor_recmodule = Option.map (fun id -> Pident id) + +let enrich_type_decls anchor decls oldenv newenv = + match anchor with + None -> newenv + | Some p -> + List.fold_left + (fun e info -> + let id = info.typ_id in + let info' = + Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id)) + id info.typ_type + in + Env.add_type ~check:true id info' e) + oldenv decls + +let enrich_module_type anchor name mty env = + match anchor, name with + | None, _ + | _, None -> + mty + | Some p, Some name -> + Mtype.enrich_modtype env (Pdot(p, name)) mty + +let check_recmodule_inclusion env bindings = + (* PR#4450, PR#4470: consider + module rec X : DECL = MOD where MOD has inferred type ACTUAL + The "natural" typing condition + E, X: ACTUAL |- ACTUAL <: DECL + leads to circularities through manifest types. + Instead, we "unroll away" the potential circularities a finite number + of times. The (weaker) condition we implement is: + E, X: DECL, + X1: ACTUAL, + X2: ACTUAL{X <- X1}/X1 + ... + Xn: ACTUAL{X <- X(n-1)}/X(n-1) + |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn} + so that manifest types rooted at X(n+1) are expanded in terms of X(n), + avoiding circularities. The strengthenings ensure that + Xn.t = X(n-1).t = ... = X2.t = X1.t. + N can be chosen arbitrarily; larger values of N result in more + recursive definitions being accepted. A good choice appears to be + the number of mutually recursive declarations. *) + + let subst_and_strengthen env scope s id mty = + let mty = Subst.modtype (Rescope scope) s mty in + match id with + | None -> mty + | Some id -> + Mtype.strengthen ~aliasable:false env mty + (Subst.module_path s (Pident id)) + in + + let rec check_incl first_time n env s = + let scope = Ctype.create_scope () in + if n > 0 then begin + (* Generate fresh names Y_i for the rec. bound module idents X_i *) + let bindings1 = + List.map + (fun (id, _name, _mty_decl, _modl, + mty_actual, _attrs, _loc, shape, _uid) -> + let ids = + Option.map + (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id + in + (ids, mty_actual, shape)) + bindings in + (* Enter the Y_i in the environment with their actual types substituted + by the input substitution s *) + let env' = + List.fold_left + (fun env (ids, mty_actual, shape) -> + match ids with + | None -> env + | Some (id, id') -> + let mty_actual' = + if first_time + then mty_actual + else subst_and_strengthen env scope s (Some id) mty_actual + in + Env.add_module ~arg:false ~shape id' Mp_present mty_actual' env) + env bindings1 in + (* Build the output substitution Y_i <- X_i *) + let s' = + List.fold_left + (fun s (ids, _mty_actual, _shape) -> + match ids with + | None -> s + | Some (id, id') -> Subst.add_module id (Pident id') s) + Subst.identity bindings1 in + (* Recurse with env' and s' *) + check_incl false (n-1) env' s' + end else begin + (* Base case: check inclusion of s(mty_actual) in s(mty_decl) + and insert coercion if needed *) + let check_inclusion + (id, name, mty_decl, modl, mty_actual, attrs, loc, shape, uid) = + let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type + and mty_actual' = subst_and_strengthen env scope s id mty_actual in + let coercion, shape = + try + Includemod.modtypes_with_shape ~shape + ~loc:modl.mod_loc ~mark:Mark_both + env mty_actual' mty_decl' + with Includemod.Error msg -> + raise(Error(modl.mod_loc, env, Not_included msg)) in + let modl' = + { mod_desc = Tmod_constraint(modl, mty_decl.mty_type, + Tmodtype_explicit mty_decl, coercion); + mod_type = mty_decl.mty_type; + mod_env = env; + mod_loc = modl.mod_loc; + mod_attributes = []; + } in + let mb = + { + mb_id = id; + mb_name = name; + mb_uid = uid; + mb_presence = Mp_present; + mb_expr = modl'; + mb_attributes = attrs; + mb_loc = loc; + } + in + mb, shape, uid + in + List.map check_inclusion bindings + end + in check_incl true (List.length bindings) env Subst.identity + +(* Helper for unpack *) + +let rec package_constraints_sig env loc sg constrs = + List.map + (function + | Sig_type (id, ({type_params=[]} as td), rs, priv) + when List.mem_assoc [Ident.name id] constrs -> + let ty = List.assoc [Ident.name id] constrs in + let td = {td with type_manifest = Some ty} in + let type_immediate = Typedecl_immediacy.compute_decl env td in + Sig_type (id, {td with type_immediate}, rs, priv) + | Sig_module (id, pres, md, rs, priv) -> + let rec aux = function + | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> + (l, t) :: aux rest + | _ :: rest -> aux rest + | [] -> [] + in + let md = + {md with + md_type = package_constraints env loc md.md_type (aux constrs) + } + in + Sig_module (id, pres, md, rs, priv) + | item -> item + ) + sg + +and package_constraints env loc mty constrs = + if constrs = [] then mty + else begin + match Mtype.scrape env mty with + | Mty_signature sg -> + Mty_signature (package_constraints_sig env loc sg constrs) + | Mty_functor _ | Mty_alias _ -> assert false + | Mty_ident p -> raise(Error(loc, env, Cannot_scrape_package_type p)) + end + +let modtype_of_package env loc p fl = + (* We call Ctype.duplicate_type to ensure that the types being added to the + module type are at generic_level. *) + let mty = + package_constraints env loc (Mty_ident p) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.duplicate_type t) fl) + in + Subst.modtype Keep Subst.identity mty + +let package_subtype env p1 fl1 p2 fl2 = + let mkmty p fl = + let fl = + List.filter (fun (_n,t) -> Ctype.free_variables t = []) fl in + modtype_of_package env Location.none p fl + in + match mkmty p1 fl1, mkmty p2 fl2 with + | exception Error(_, _, Cannot_scrape_package_type r) -> + Result.Error (Errortrace.Package_cannot_scrape r) + | mty1, mty2 -> + let loc = Location.none in + match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with + | Tcoerce_none -> Ok () + | c -> + let msg = + Includemod_errorprinter.coercion_in_package_subtype env mty1 c + in + Result.Error (Errortrace.Package_coercion msg) + | exception Includemod.Error e -> + let msg = doc_printf "%a" Includemod_errorprinter.err_msgs e in + Result.Error (Errortrace.Package_inclusion msg) + +let () = Ctype.package_subtype := package_subtype + +let wrap_constraint_package env mark arg mty explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in + let mty2 = Subst.modtype Keep Subst.identity mty in + let coercion = + try + Includemod.modtypes ~loc:arg.mod_loc env ~mark mty1 mty2 + with Includemod.Error msg -> + raise(Error(arg.mod_loc, env, Not_included msg)) in + { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); + mod_type = mty; + mod_env = env; + mod_attributes = []; + mod_loc = arg.mod_loc } + +let wrap_constraint_with_shape env mark arg mty + shape explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let coercion, shape = + try + Includemod.modtypes_with_shape ~shape ~loc:arg.mod_loc env ~mark + arg.mod_type mty + with Includemod.Error msg -> + raise(Error(arg.mod_loc, env, Not_included msg)) in + { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); + mod_type = mty; + mod_env = env; + mod_attributes = []; + mod_loc = arg.mod_loc }, shape + +(* Type a module value expression *) + + +(* These describe the X in [F(X)] (which might be missing, for [F ()]) *) +type argument_summary = { + is_syntactic_unit: bool; + arg: Typedtree.module_expr; + path: Path.t option; + shape: Shape.t +} + +type application_summary = { + loc: Location.t; + attributes: attributes; + f_loc: Location.t; (* loc for F *) + arg: argument_summary option (* None for () *) +} + +let simplify_app_summary app_view = match app_view.arg with + | None -> + Includemod.Error.Unit, Mty_signature [] + | Some arg -> + let mty = arg.arg.mod_type in + match arg.is_syntactic_unit , arg.path with + | true , _ -> Includemod.Error.Empty_struct, mty + | false, Some p -> Includemod.Error.Named p, mty + | false, None -> Includemod.Error.Anonymous, mty + +let not_principal msg = Warnings.Not_principal (Format_doc.Doc.msg msg) + +let rec type_module ?(alias=false) sttn funct_body anchor env smod = + Builtin_attributes.warning_scope smod.pmod_attributes + (fun () -> type_module_aux ~alias sttn funct_body anchor env smod) + +and type_module_aux ~alias sttn funct_body anchor env smod = + match smod.pmod_desc with + Pmod_ident lid -> + let path = + Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env + in + let md = { mod_desc = Tmod_ident (path, lid); + mod_type = Mty_alias path; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } in + let aliasable = not (Env.is_functor_arg path env) in + let shape = + Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path + in + let shape = if alias && aliasable then Shape.alias shape else shape in + let md = + if alias && aliasable then + (Env.add_required_global (Path.head path); md) + else begin + let mty = + if sttn then + Env.find_strengthened_module ~aliasable path env + else + (Env.find_module path env).md_type + in + match mty with + | Mty_alias p1 when not alias -> + let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in + let mty = Includemod.expand_module_alias + ~strengthen:sttn env p1 in + { md with + mod_desc = + Tmod_constraint (md, mty, Tmodtype_implicit, + Tcoerce_alias (env, path, Tcoerce_none)); + mod_type = mty } + | mty -> + { md with mod_type = mty } + end + in + md, shape + | Pmod_structure sstr -> + let (str, sg, names, shape, _finalenv) = + type_structure funct_body anchor env sstr in + let md = + { mod_desc = Tmod_structure str; + mod_type = Mty_signature sg; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } + in + let sg' = Signature_names.simplify _finalenv names sg in + if List.length sg' = List.length sg then md, shape else + wrap_constraint_with_shape env false md + (Mty_signature sg') shape Tmodtype_implicit + | Pmod_functor(arg_opt, sbody) -> + let t_arg, ty_arg, newenv, funct_shape_param, funct_body = + match arg_opt with + | Unit -> + Unit, Types.Unit, env, Shape.for_unnamed_functor_param, false + | Named (param, smty) -> + let mty = transl_modtype_functor_arg env smty in + let scope = Ctype.create_scope () in + let (id, newenv, var) = + match param.txt with + | None -> None, env, Shape.for_unnamed_functor_param + | Some name -> + let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let arg_md = + { md_type = mty.mty_type; + md_attributes = []; + md_loc = param.loc; + md_uid; + } + in + let id = Ident.create_scoped ~scope name in + let shape = Shape.var md_uid id in + let newenv = Env.add_module_declaration + ~shape ~arg:true ~check:true id Mp_present arg_md env + in + Some id, newenv, id + in + Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, + var, true + in + let body, body_shape = type_module true funct_body None newenv sbody in + { mod_desc = Tmod_functor(t_arg, body); + mod_type = Mty_functor(ty_arg, body.mod_type); + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc }, + Shape.abs funct_shape_param body_shape + | Pmod_apply _ | Pmod_apply_unit _ -> + type_application smod.pmod_loc sttn funct_body env smod + | Pmod_constraint(sarg, smty) -> + let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in + let mty = transl_modtype env smty in + let md, final_shape = + wrap_constraint_with_shape env true arg mty.mty_type arg_shape + (Tmodtype_explicit mty) + in + { md with + mod_loc = smod.pmod_loc; + mod_attributes = smod.pmod_attributes; + }, + final_shape + | Pmod_unpack sexp -> + let exp = + Ctype.with_local_level_generalize_structure_if_principal + (fun () -> Typecore.type_exp env sexp) + in + let mty = + match get_desc (Ctype.expand_head env exp.exp_type) with + Tpackage (p, fl) -> + if List.exists (fun (_n, t) -> Ctype.free_variables t <> []) fl then + raise (Error (smod.pmod_loc, env, + Incomplete_packed_module exp.exp_type)); + if !Clflags.principal && + not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type) + then + Location.prerr_warning smod.pmod_loc + (not_principal "this module unpacking"); + modtype_of_package env smod.pmod_loc p fl + | Tvar _ -> + raise (Typecore.Error + (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) + | _ -> + raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type)) + in + if funct_body && Mtype.contains_type env mty then + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); + { mod_desc = Tmod_unpack(exp, mty); + mod_type = mty; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc }, + Shape.leaf_for_unpack + | Pmod_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and type_application loc strengthen funct_body env smod = + let rec extract_application funct_body env sargs smod = + match smod.pmod_desc with + | Pmod_apply (f, sarg) -> + let arg, shape = type_module true funct_body None env sarg in + let summary = { + loc = smod.pmod_loc; + attributes = smod.pmod_attributes; + f_loc = f.pmod_loc; + arg = Some { + is_syntactic_unit = sarg.pmod_desc = Pmod_structure []; + arg; + path = path_of_module arg; + shape; + } + } in + extract_application funct_body env (summary::sargs) f + | Pmod_apply_unit f -> + let summary = { + loc = smod.pmod_loc; + attributes = smod.pmod_attributes; + f_loc = f.pmod_loc; + arg = None + } in + extract_application funct_body env (summary::sargs) f + | _ -> smod, sargs + in + let sfunct, args = extract_application funct_body env [] smod in + let funct, funct_shape = + let has_path { arg } = match arg with + | None | Some { path = None } -> false + | Some { path = Some _ } -> true + in + let strengthen = strengthen && List.for_all has_path args in + type_module strengthen funct_body None env sfunct + in + List.fold_left + (type_one_application ~ctx:(loc, sfunct, funct, args) funct_body env) + (funct, funct_shape) args + +and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) + funct_body env (funct, funct_shape) app_view = + match Env.scrape_alias env funct.mod_type with + | Mty_functor (Unit, mty_res) -> + begin match app_view.arg with + | None -> () + | Some arg -> + if arg.is_syntactic_unit then + (* this call to warning_scope allows e.g. + [ F (struct end [@warning "-73"]) ] + not to warn; useful when generating code that must + work over multiple versions of OCaml *) + Builtin_attributes.warning_scope arg.arg.mod_attributes @@ fun () -> + Location.prerr_warning arg.arg.mod_loc + Warnings.Generative_application_expects_unit + else + raise (Error (app_view.f_loc, env, Apply_generative)); + end; + if funct_body && Mtype.contains_type env funct.mod_type then + raise (Error (apply_loc, env, Not_allowed_in_functor_body)); + { mod_desc = Tmod_apply_unit funct; + mod_type = mty_res; + mod_env = env; + mod_attributes = app_view.attributes; + mod_loc = funct.mod_loc }, + Shape.app funct_shape ~arg:Shape.dummy_mod + | Mty_functor (Named (param, mty_param), mty_res) as mty_functor -> + let apply_error () = + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let app_name = match sfunct.pmod_desc with + | Pmod_ident l -> Includemod.Named_leftmost_functor l.txt + | _ -> Includemod.Anonymous_functor + in + raise(Includemod.Apply_error {loc=apply_loc;env;app_name;mty_f;args}) + in + begin match app_view with + | { arg = None; _ } -> apply_error () + | { loc = app_loc; attributes = app_attributes; + arg = Some { shape = arg_shape; path = arg_path; arg } } -> + let coercion = + try Includemod.modtypes + ~loc:arg.mod_loc ~mark:Mark_both env arg.mod_type mty_param + with Includemod.Error _ -> apply_error () + in + let mty_appl = + match arg_path with + | Some path -> + let scope = Ctype.create_scope () in + let subst = + match param with + | None -> Subst.identity + | Some p -> Subst.add_module p path Subst.identity + in + Subst.modtype (Rescope scope) subst mty_res + | None -> + let env, nondep_mty = + match param with + | None -> env, mty_res + | Some param -> + let env = + Env.add_module ~arg:true param Mp_present arg.mod_type env + in + check_well_formed_module env app_loc + "the signature of this functor application" mty_res; + try env, Mtype.nondep_supertype env [param] mty_res + with Ctype.Nondep_cannot_erase _ -> + let error = Cannot_eliminate_dependency mty_functor in + raise (Error(app_loc, env, error)) + in + begin match + Includemod.modtypes + ~loc:app_loc ~mark:Mark_neither env mty_res nondep_mty + with + | Tcoerce_none -> () + | _ -> + fatal_error + "unexpected coercion from original module type to \ + nondep_supertype one" + | exception Includemod.Error _ -> + fatal_error + "nondep_supertype not included in original module type" + end; + nondep_mty + in + check_well_formed_module env apply_loc + "the signature of this functor application" mty_appl; + { mod_desc = Tmod_apply(funct, arg, coercion); + mod_type = mty_appl; + mod_env = env; + mod_attributes = app_attributes; + mod_loc = app_loc }, + Shape.app ~arg:arg_shape funct_shape + end + | Mty_alias path -> + raise(Error(app_view.f_loc, env, Cannot_scrape_alias path)) + | Mty_ident _ | Mty_signature _ -> + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let app_name = match sfunct.pmod_desc with + | Pmod_ident l -> Includemod.Named_leftmost_functor l.txt + | _ -> Includemod.Anonymous_functor + in + raise(Includemod.Apply_error {loc=apply_loc;env;app_name;mty_f;args}) + +and type_open_decl ?used_slot ?toplevel funct_body names env sod = + Builtin_attributes.warning_scope sod.popen_attributes + (fun () -> + type_open_decl_aux ?used_slot ?toplevel funct_body names env sod + ) + +and type_open_decl_aux ?used_slot ?toplevel funct_body names env od = + let loc = od.popen_loc in + match od.popen_expr.pmod_desc with + | Pmod_ident lid -> + let path, newenv = + type_open_ ?used_slot ?toplevel od.popen_override env loc lid + in + let md = { mod_desc = Tmod_ident (path, lid); + mod_type = Mty_alias path; + mod_env = env; + mod_attributes = od.popen_expr.pmod_attributes; + mod_loc = od.popen_expr.pmod_loc } + in + let open_descr = { + open_expr = md; + open_bound_items = []; + open_override = od.popen_override; + open_env = newenv; + open_loc = loc; + open_attributes = od.popen_attributes + } in + open_descr, [], newenv + | _ -> + let md, mod_shape = type_module true funct_body None env od.popen_expr in + let scope = Ctype.create_scope () in + let sg, newenv = + Env.enter_signature ~scope ~mod_shape + (extract_sig_open env md.mod_loc md.mod_type) env + in + let info, visibility = + match toplevel with + | Some false | None -> Some `From_open, Hidden + | Some true -> None, Exported + in + Signature_group.iter (Signature_names.check_sig_item ?info names loc) sg; + let sg = + List.map (function + | Sig_value(id, vd, _) -> Sig_value(id, vd, visibility) + | Sig_type(id, td, rs, _) -> Sig_type(id, td, rs, visibility) + | Sig_typext(id, ec, et, _) -> Sig_typext(id, ec, et, visibility) + | Sig_module(id, mp, md, rs, _) -> + Sig_module(id, mp, md, rs, visibility) + | Sig_modtype(id, mtd, _) -> Sig_modtype(id, mtd, visibility) + | Sig_class(id, cd, rs, _) -> Sig_class(id, cd, rs, visibility) + | Sig_class_type(id, ctd, rs, _) -> + Sig_class_type(id, ctd, rs, visibility) + ) sg + in + let open_descr = { + open_expr = md; + open_bound_items = sg; + open_override = od.popen_override; + open_env = newenv; + open_loc = loc; + open_attributes = od.popen_attributes + } in + open_descr, sg, newenv + +and type_structure ?(toplevel = false) funct_body anchor env sstr = + let names = Signature_names.create () in + + let type_str_item env shape_map {pstr_loc = loc; pstr_desc = desc} = + match desc with + | Pstr_eval (sexpr, attrs) -> + let expr = + Builtin_attributes.warning_scope attrs + (fun () -> Typecore.type_expression env sexpr) + in + Tstr_eval (expr, attrs), [], shape_map, env + | Pstr_value(rec_flag, sdefs) -> + let (defs, newenv) = + Typecore.type_binding env rec_flag sdefs in + let defs = match rec_flag with + | Recursive -> Typecore.annotate_recursive_bindings env defs + | Nonrecursive -> defs + in + (* Note: Env.find_value does not trigger the value_used event. Values + will be marked as being used during the signature inclusion test. *) + let items, shape_map = + List.fold_left + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ, _uid)-> + Signature_names.check_value names loc id; + let vd = Env.find_value (Pident id) newenv in + Sig_value(id, vd, Exported) :: acc, + Shape.Map.add_value shape_map id vd.val_uid + ) + ([], shape_map) + (let_bound_idents_full defs) + in + Tstr_value(rec_flag, defs), + List.rev items, + shape_map, + newenv + | Pstr_primitive sdesc -> + let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in + Signature_names.check_value names desc.val_loc desc.val_id; + Tstr_primitive desc, + [Sig_value(desc.val_id, desc.val_val, Exported)], + Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, + newenv + | Pstr_type (rec_flag, sdecls) -> + let (decls, newenv, shapes) = + Typedecl.transl_type_decl env rec_flag sdecls + in + List.iter + Signature_names.(fun td -> check_type names td.typ_loc td.typ_id) + decls; + let items = map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) + decls [] + in + let shape_map = List.fold_left2 + (fun map { typ_id; _} shape -> + Shape.Map.add_type map typ_id shape) + shape_map + decls + shapes + in + Tstr_type (rec_flag, decls), + items, + shape_map, + enrich_type_decls anchor decls env newenv + | Pstr_typext styext -> + let (tyext, newenv, shapes) = + Typedecl.transl_type_extension true env loc styext + in + let constructors = tyext.tyext_constructors in + let shape_map = List.fold_left2 (fun shape_map ext shape -> + Signature_names.check_typext names ext.ext_loc ext.ext_id; + Shape.Map.add_extcons shape_map ext.ext_id shape + ) shape_map constructors shapes + in + (Tstr_typext tyext, + map_ext + (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported)) + constructors [], + shape_map, + newenv) + | Pstr_exception sext -> + let (ext, newenv, shape) = Typedecl.transl_type_exception env sext in + let constructor = ext.tyexn_constructor in + Signature_names.check_typext names constructor.ext_loc + constructor.ext_id; + Tstr_exception ext, + [Sig_typext(constructor.ext_id, + constructor.ext_type, + Text_exception, + Exported)], + Shape.Map.add_extcons shape_map + constructor.ext_id + shape, + newenv + | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; + pmb_loc; + } -> + let outer_scope = Ctype.get_current_level () in + let scope = Ctype.create_scope () in + let modl, md_shape = + Builtin_attributes.warning_scope attrs + (fun () -> + type_module ~alias:true true funct_body + (anchor_submodule name.txt anchor) env smodl + ) + in + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let md = + { md_type = enrich_module_type anchor name.txt modl.mod_type env; + md_attributes = attrs; + md_loc = pmb_loc; + md_uid; + } + in + let md_shape = Shape.set_uid_if_none md_shape md_uid in + (*prerr_endline (Ident.unique_toplevel_name id);*) + Mtype.lower_nongen outer_scope md.md_type; + let id, newenv, sg = + match name.txt with + | None -> None, env, [] + | Some name -> + let id, e = Env.enter_module_declaration + ~scope ~shape:md_shape name pres md env + in + Signature_names.check_module names pmb_loc id; + Some id, e, + [Sig_module(id, pres, + {md_type = modl.mod_type; + md_attributes = attrs; + md_loc = pmb_loc; + md_uid; + }, Trec_not, Exported)] + in + let shape_map = match id with + | Some id -> Shape.Map.add_module shape_map id md_shape + | None -> shape_map + in + Tstr_module {mb_id=id; mb_name=name; mb_uid = md.md_uid; + mb_expr=modl; mb_presence=pres; mb_attributes=attrs; + mb_loc=pmb_loc; }, + sg, + shape_map, + newenv + | Pstr_recmodule sbind -> + let sbind = + List.map + (function + | {pmb_name = name; + pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; + pmb_attributes = attrs; + pmb_loc = loc; + } -> + name, typ, expr, attrs, loc + | mb -> + raise (Error (mb.pmb_expr.pmod_loc, env, + Recursive_module_require_explicit_type)) + ) + sbind + in + let (decls, newenv) = + transl_recmodule_modtypes env + (List.map (fun (name, smty, _smodl, attrs, loc) -> + {pmd_name=name; pmd_type=smty; + pmd_attributes=attrs; pmd_loc=loc}) sbind + ) in + List.iter + (fun (md, _, _) -> + Option.iter Signature_names.(check_module names md.md_loc) md.md_id + ) decls; + let bindings1 = + List.map2 + (fun ({md_id=id; md_type=mty}, uid, _prev_shape) + (name, _, smodl, attrs, loc) -> + let modl, shape = + Builtin_attributes.warning_scope attrs + (fun () -> + type_module true funct_body (anchor_recmodule id) + newenv smodl + ) + in + let mty' = + enrich_module_type anchor name.txt modl.mod_type newenv + in + Includemod.modtypes_consistency ~loc:modl.mod_loc newenv + mty' mty.mty_type; + (id, name, mty, modl, mty', attrs, loc, shape, uid)) + decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env (id_opt, _, mty, _, _, attrs, loc, shape, uid) -> + match id_opt with + | None -> env + | Some id -> + let mdecl = + { + md_type = mty.mty_type; + md_attributes = attrs; + md_loc = loc; + md_uid = uid; + } + in + Env.add_module_declaration ~check:true ~shape + id Mp_present mdecl env + ) + env bindings1 + in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in + let mbs = + List.filter_map (fun (mb, shape, uid) -> + Option.map (fun id -> id, mb, uid, shape) mb.mb_id + ) bindings2 + in + let shape_map = + List.fold_left (fun map (id, _mb, _uid, shape) -> + Shape.Map.add_module map id shape + ) shape_map mbs + in + Tstr_recmodule (List.map (fun (mb, _, _) -> mb) bindings2), + map_rec (fun rs (id, mb, uid, _shape) -> + Sig_module(id, Mp_present, { + md_type=mb.mb_expr.mod_type; + md_attributes=mb.mb_attributes; + md_loc=mb.mb_loc; + md_uid = uid; + }, rs, Exported)) + mbs [], + shape_map, + newenv + | Pstr_modtype pmtd -> + (* check that it is non-abstract *) + let newenv, mtd, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + let id = mtd.mtd_id in + let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in + Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv + | Pstr_open sod -> + let (od, sg, newenv) = + type_open_decl ~toplevel funct_body names env sod + in + Tstr_open od, sg, shape_map, newenv + | Pstr_class cl -> + let (classes, new_env) = Typeclass.class_declarations env cl in + let shape_map = List.fold_left (fun acc cls -> + let open Typeclass in + let loc = cls.cls_id_loc.Location.loc in + Signature_names.check_class names loc cls.cls_id; + Signature_names.check_class_type names loc cls.cls_ty_id; + Signature_names.check_type names loc cls.cls_obj_id; + let uid = cls.cls_decl.cty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class cls.cls_id uid acc + |> map Shape.Map.add_class_type cls.cls_ty_id uid + |> map Shape.Map.add_type cls.cls_obj_id (Shape.leaf uid) + ) shape_map classes + in + Tstr_class + (List.map (fun cls -> + (cls.Typeclass.cls_info, + cls.Typeclass.cls_pub_methods)) classes), + List.flatten + (map_rec + (fun rs cls -> + let open Typeclass in + [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported); + Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported); + Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported) + ]) + classes []), + shape_map, + new_env + | Pstr_class_type cl -> + let (classes, new_env) = Typeclass.class_type_declarations env cl in + let shape_map = List.fold_left (fun acc decl -> + let open Typeclass in + let loc = decl.clsty_id_loc.Location.loc in + Signature_names.check_class_type names loc decl.clsty_ty_id; + Signature_names.check_type names loc decl.clsty_obj_id; + let uid = decl.clsty_ty_decl.clty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class_type decl.clsty_ty_id uid acc + |> map Shape.Map.add_type decl.clsty_obj_id (Shape.leaf uid) + ) shape_map classes + in + Tstr_class_type + (List.map (fun cl -> + (cl.Typeclass.clsty_ty_id, + cl.Typeclass.clsty_id_loc, + cl.Typeclass.clsty_info)) classes), + List.flatten + (map_rec + (fun rs decl -> + let open Typeclass in + [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs, + Exported); + Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported); + ]) + classes []), + shape_map, + new_env + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in + let modl, modl_shape = + Builtin_attributes.warning_scope sincl.pincl_attributes + (fun () -> type_module true funct_body None env smodl) + in + let scope = Ctype.create_scope () in + (* Rename all identifiers bound by this signature to avoid clashes *) + let sg, shape, new_env = + Env.enter_signature_and_shape ~scope ~parent_shape:shape_map + modl_shape (extract_sig_open env smodl.pmod_loc modl.mod_type) env + in + Signature_group.iter (Signature_names.check_sig_item names loc) sg; + let incl = + { incl_mod = modl; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + Tstr_include incl, sg, shape, new_env + | Pstr_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | Pstr_attribute x -> + Builtin_attributes.warning_attribute x; + Tstr_attribute x, [], shape_map, env + in + let rec type_struct env shape_map sstr = + match sstr with + | [] -> ([], [], shape_map, env) + | pstr :: srem -> + let previous_saved_types = Cmt_format.get_saved_types () in + let desc, sg, shape_map, new_env = type_str_item env shape_map pstr in + let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in + Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str + :: previous_saved_types); + let (str_rem, sig_rem, shape_map, final_env) = + type_struct new_env shape_map srem + in + (str :: str_rem, sg @ sig_rem, shape_map, final_env) + in + let previous_saved_types = Cmt_format.get_saved_types () in + let run () = + let (items, sg, shape_map, final_env) = + type_struct env Shape.Map.empty sstr + in + let str = { str_items = items; str_type = sg; str_final_env = final_env } in + Cmt_format.set_saved_types + (Cmt_format.Partial_structure str :: previous_saved_types); + str, sg, names, Shape.str shape_map, final_env + in + if toplevel then run () + else Builtin_attributes.warning_scope [] run + +let type_toplevel_phrase env s = + Env.reset_required_globals (); + type_structure ~toplevel:true false None env s + +let type_module_alias = type_module ~alias:true true false None +let type_module = type_module true false None +let type_structure = type_structure false None + +(* Normalize types in a signature *) + +let rec normalize_modtype = function + Mty_ident _ + | Mty_alias _ -> () + | Mty_signature sg -> normalize_signature sg + | Mty_functor(_param, body) -> normalize_modtype body + +and normalize_signature sg = List.iter normalize_signature_item sg + +and normalize_signature_item = function + Sig_value(_id, desc, _) -> Ctype.normalize_type desc.val_type + | Sig_module(_id, _, md, _, _) -> normalize_modtype md.md_type + | _ -> () + +(* Extract the module type of a module expression *) + +let type_module_type_of env smod = + let remove_aliases = has_remove_aliases_attribute smod.pmod_attributes in + let tmty = + match smod.pmod_desc with + | Pmod_ident lid -> (* turn off strengthening in this case *) + let path, md = Env.lookup_module ~loc:smod.pmod_loc lid.txt env in + { mod_desc = Tmod_ident (path, lid); + mod_type = md.md_type; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } + | _ -> + let me, _shape = type_module env smod in + me + in + let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in + (* PR#5036: must not contain non-generalized type variables *) + check_nongen_modtype env smod.pmod_loc mty; + tmty, mty + +(* For Typecore *) + +(* Graft a longident onto a path *) +let rec extend_path path = + fun lid -> + match lid with + | Lident name -> Pdot(path, name) + | Ldot(m, name) -> Pdot(extend_path path m, name) + | Lapply _ -> assert false + +(* Lookup a type's longident within a signature *) +let lookup_type_in_sig sg = + let types, modules = + List.fold_left + (fun acc item -> + match item with + | Sig_type(id, _, _, _) -> + let types, modules = acc in + let types = String.Map.add (Ident.name id) id types in + types, modules + | Sig_module(id, _, _, _, _) -> + let types, modules = acc in + let modules = String.Map.add (Ident.name id) id modules in + types, modules + | _ -> acc) + (String.Map.empty, String.Map.empty) sg + in + let rec module_path = function + | Lident name -> Pident (String.Map.find name modules) + | Ldot(m, name) -> Pdot(module_path m, name) + | Lapply _ -> assert false + in + fun lid -> + match lid with + | Lident name -> Pident (String.Map.find name types) + | Ldot(m, name) -> Pdot(module_path m, name) + | Lapply _ -> assert false + +let type_package env m p fl = + (* Same as Pexp_letmodule *) + let modl, scope = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* type the module and create a scope in a raised level *) + Ctype.with_local_level begin fun () -> + let modl, _mod_shape = type_module env m in + let scope = Ctype.create_scope () in + modl, scope + end + end + in + let fl', env = + match fl with + | [] -> [], env + | fl -> + let type_path, env = + match modl.mod_desc with + | Tmod_ident (mp,_) + | Tmod_constraint + ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) -> + (* We special case these because interactions between + strengthening of module types and packages can cause + spurious escape errors. See examples from PR#6982 in the + testsuite. This can be removed when such issues are + fixed. *) + extend_path mp, env + | _ -> + let sg = extract_sig_open env modl.mod_loc modl.mod_type in + let sg, env = Env.enter_signature ~scope sg env in + lookup_type_in_sig sg, env + in + let fl' = + List.fold_right + (fun (lid, _t) fl -> + match type_path lid with + | exception Not_found -> fl + | path -> begin + match Env.find_type path env with + | exception Not_found -> fl + | decl -> + if decl.type_arity > 0 then begin + fl + end else begin + let t = Btype.newgenty (Tconstr (path,[],ref Mnil)) in + (lid, t) :: fl + end + end) + fl [] + in + fl', env + in + let mty = + if fl = [] then (Mty_ident p) + else modtype_of_package env modl.mod_loc p fl' + in + List.iter + (fun (n, ty) -> + try Ctype.unify env ty (Ctype.newvar ()) + with Ctype.Unify _ -> + raise (Error(modl.mod_loc, env, Scoping_pack (n,ty)))) + fl'; + let modl = wrap_constraint_package env true modl mty Tmodtype_implicit in + modl, fl' + +(* Fill in the forward declarations *) + +let type_open_decl ?used_slot env od = + type_open_decl ?used_slot ?toplevel:None false (Signature_names.create ()) env + od + +let type_open_descr ?used_slot env od = + type_open_descr ?used_slot ?toplevel:None env od + +let () = + Typecore.type_module := type_module_alias; + Typetexp.transl_modtype_longident := transl_modtype_longident; + Typetexp.transl_modtype := transl_modtype; + Typecore.type_open := type_open_ ?toplevel:None; + Typetexp.type_open := type_open_ ?toplevel:None; + Typecore.type_open_decl := type_open_decl; + Typecore.type_package := type_package; + Typeclass.type_open_descr := type_open_descr; + type_module_type_of_fwd := type_module_type_of + + +(* Typecheck an implementation file *) + +let gen_annot target annots = + let annot = Unit_info.annot target in + Cmt2annot.gen_annot (Some (Unit_info.Artifact.filename annot)) + ~sourcefile:(Unit_info.Artifact.source_file annot) + ~use_summaries:false + annots + +let type_implementation target initial_env ast = + let sourcefile = Unit_info.source_file target in + let save_cmt target annots initial_env cmi shape = + Cmt_format.save_cmt (Unit_info.cmt target) + annots initial_env cmi shape; + gen_annot target annots; + in + Cmt_format.clear (); + Misc.try_finally (fun () -> + Typecore.reset_delayed_checks (); + Env.reset_required_globals (); + if !Clflags.print_types then (* #7656 *) + ignore @@ Warnings.parse_options false "-32-34-37-38-60"; + let (str, sg, names, shape, finalenv) = + type_structure initial_env ast in + let shape = + let id = Ident.create_persistent @@ Unit_info.modname target in + Shape.set_uid_if_none shape (Uid.of_compilation_unit_id id) + in + let simple_sg = Signature_names.simplify finalenv names sg in + if !Clflags.print_types then begin + Typecore.force_delayed_checks (); + let shape = Shape_reduce.local_reduce Env.empty shape in + Printtyp.wrap_printing_env ~error:false initial_env + Format.(fun () -> fprintf std_formatter "%a@." + (Printtyp.printed_signature @@ Unit_info.source_file target) + simple_sg + ); + gen_annot target (Cmt_format.Implementation str); + { structure = str; + coercion = Tcoerce_none; + shape; + signature = simple_sg + } (* result is ignored by Compile.implementation *) + end else begin + let source_intf = Unit_info.mli_from_source target in + if !Clflags.cmi_file <> None + || Sys.file_exists source_intf then begin + let compiled_intf_file = + match !Clflags.cmi_file with + | Some cmi_file -> Unit_info.Artifact.from_filename cmi_file + | None -> + try Unit_info.find_normalized_cmi target with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled source_intf)) + in + let dclsig = Env.read_signature compiled_intf_file in + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg source_intf + dclsig shape + in + Typecore.force_delayed_checks (); + (* It is important to run these checks after the inclusion test above, + so that value declarations which are not used internally but + exported are not reported as being unused. *) + let shape = Shape_reduce.local_reduce Env.empty shape in + let annots = Cmt_format.Implementation str in + save_cmt target annots initial_env None (Some shape); + { structure = str; + coercion; + shape; + signature = dclsig + } + end else begin + Location.prerr_warning + (Location.in_file (Unit_info.source_file target)) + Warnings.Missing_mli; + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg "(inferred signature)" simple_sg shape + in + check_nongen_signature finalenv simple_sg; + normalize_signature simple_sg; + Typecore.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the values being exported. We can still capture unused + declarations like "let x = true;; let x = 1;;", because in this + case, the inferred signature contains only the last declaration. *) + let shape = Shape_reduce.local_reduce Env.empty shape in + let alerts = Builtin_attributes.alerts_of_str ~mark:true ast in + if not !Clflags.dont_write_files then begin + let cmi = + Env.save_signature ~alerts simple_sg (Unit_info.cmi target) + in + let annots = Cmt_format.Implementation str in + save_cmt target annots initial_env (Some cmi) (Some shape) + end; + { structure = str; + coercion; + shape; + signature = simple_sg + } + end + end + ) + ~exceptionally:(fun () -> + let annots = + Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ())) + in + save_cmt target annots initial_env None None + ) + +let save_signature target tsg initial_env cmi = + Cmt_format.save_cmt (Unit_info.cmti target) + (Cmt_format.Interface tsg) initial_env (Some cmi) None + +let type_interface env ast = + transl_signature env ast + +(* "Packaging" of several compilation units into one unit + having them as sub-modules. *) + +let package_signatures units = + let units_with_ids = + List.map + (fun (name, sg) -> + let oldid = Ident.create_persistent name in + let newid = Ident.create_local name in + (oldid, newid, sg)) + units + in + let subst = + List.fold_left + (fun acc (oldid, newid, _) -> + Subst.add_module oldid (Pident newid) acc) + Subst.identity units_with_ids + in + List.map + (fun (_, newid, sg) -> + (* This signature won't be used for anything, it'll just be saved in a cmi + and cmt. *) + let sg = Subst.signature Make_local subst sg in + let md = + { md_type=Mty_signature sg; + md_attributes=[]; + md_loc=Location.none; + md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + Sig_module(newid, Mp_present, md, Trec_not, Exported)) + units_with_ids + +let package_units initial_env objfiles target_cmi = + (* Read the signatures of the units *) + let units = + List.map + (fun f -> + let artifact = Unit_info.Artifact.from_filename f in + let sg = Env.read_signature (Unit_info.companion_cmi artifact) in + if Unit_info.is_cmi artifact && + not(Mtype.no_code_needed_sig Env.initial sg) + then raise(Error(Location.none, Env.empty, + Implementation_is_required f)); + Unit_info.Artifact.modname artifact, sg) + objfiles in + (* Compute signature of packaged unit *) + Ident.reinit(); + let sg = package_signatures units in + (* Compute the shape of the package *) + let prefix = Unit_info.Artifact.prefix target_cmi in + let pack_uid = Uid.of_compilation_unit_id (Ident.create_persistent prefix) in + let shape = + List.fold_left (fun map (name, _sg) -> + let id = Ident.create_persistent name in + Shape.Map.add_module map id (Shape.for_persistent_unit name) + ) Shape.Map.empty units + |> Shape.str ~uid:pack_uid + in + (* See if explicit interface is provided *) + let mli = Unit_info.mli_from_artifact target_cmi in + if Sys.file_exists mli then begin + if not (Sys.file_exists @@ Unit_info.Artifact.filename target_cmi) then + begin + raise(Error(Location.in_file mli, Env.empty, + Interface_not_compiled mli)) + end; + let dclsig = Env.read_signature target_cmi in + let cc, _shape = + Includemod.compunit initial_env ~mark:Mark_both + "(obtained by packing)" sg mli dclsig shape + in + Cmt_format.save_cmt (Unit_info.companion_cmt target_cmi) + (Cmt_format.Packed (sg, objfiles)) initial_env None (Some shape); + cc + end else begin + (* Determine imports *) + let unit_names = List.map fst units in + let imports = + List.filter + (fun (name, _crc) -> not (List.mem name unit_names)) + (Env.imports()) in + (* Write packaged signature *) + if not !Clflags.dont_write_files then begin + let cmi = + Env.save_signature_with_imports ~alerts:Misc.Stdlib.String.Map.empty + sg target_cmi imports + in + Cmt_format.save_cmt (Unit_info.companion_cmt target_cmi) + (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) initial_env + (Some cmi) (Some shape); + end; + Tcoerce_none + end + + +(* Error report *) +open Printtyp.Doc + +let report_error ~loc _env = function + Cannot_apply mty -> + Location.errorf ~loc + "@[This module is not a functor; it has type@ %a@]" + (Style.as_inline_code modtype) mty + | Not_included errs -> + Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg + "@[Signature mismatch:@ %a@]" + Includemod_errorprinter.err_msgs errs + | Cannot_eliminate_dependency mty -> + Location.errorf ~loc + "@[This functor has type@ %a@ \ + The parameter cannot be eliminated in the result type.@ \ + Please bind the argument to a module identifier.@]" + (Style.as_inline_code modtype) mty + | Signature_expected -> + Location.errorf ~loc "This module type is not a signature" + | Structure_expected mty -> + Location.errorf ~loc + "@[This module is not a structure; it has type@ %a" + (Style.as_inline_code modtype) mty + | With_no_component lid -> + Location.errorf ~loc + "@[The signature constrained by %a has no component named %a@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + | With_mismatch(lid, explanation) -> + Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg + "@[\ + @[In this %a constraint, the new definition of %a@ \ + does not match its original definition@ \ + in the constrained signature:@]@ \ + %a@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + Includemod_errorprinter.err_msgs explanation + | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> + Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg + "@[\ + @[This %a constraint on %a makes the applicative functor @ \ + type %a ill-typed in the constrained signature:@]@ \ + %a@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + Style.inline_code (Path.name path) + Includemod_errorprinter.err_msgs explanation + | With_changes_module_alias(lid, id, path) -> + Location.errorf ~loc + "@[\ + @[This %a constraint on %a changes %a, which is aliased @ \ + in the constrained signature (as %a)@].@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + Style.inline_code (Path.name path) + Style.inline_code (Ident.name id) + | With_cannot_remove_constrained_type -> + Location.errorf ~loc + "@[Destructive substitutions are not supported for constrained @ \ + types (other than when replacing a type constructor with @ \ + a type constructor with the same arguments).@]" + | With_cannot_remove_packed_modtype (p,mty) -> + let[@manual.ref "ss:module-type-substitution"] manual_ref = + [ 12; 7; 3 ] + in + let pp_constraint ppf () = + fprintf ppf "%s := %a" + (Path.name p) modtype mty + in + Location.errorf ~loc + "This %a constraint@ %a@ makes a packed module ill-formed.@ %a" + Style.inline_code "with" + (Style.as_inline_code pp_constraint) () + Misc.print_see_manual manual_ref + | With_package_manifest (lid, ty) -> + Location.errorf ~loc + "In the constrained signature, type %a is defined to be %a.@ \ + Package %a constraints may only be used on abstract types." + (Style.as_inline_code longident) lid + (Style.as_inline_code type_expr) ty + Style.inline_code "with" + | Repeated_name(kind, name) -> + Location.errorf ~loc + "@[Multiple definition of the %s name %a.@ \ + Names must be unique in a given structure or signature.@]" + (Sig_component_kind.to_string kind) Style.inline_code name + | Non_generalizable { vars; expression } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + Out_type.prepare_for_printing vars; + Out_type.add_type_to_preparation expression; + Location.errorf ~loc + "@[The type of this expression,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + (Style.as_inline_code Out_type.prepared_type_scheme) expression + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + (Style.as_inline_code Out_type.prepared_type_scheme)) vars + Misc.print_see_manual manual_ref + | Non_generalizable_module { vars; mty; item } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + Out_type.prepare_for_printing vars; + Out_type.add_type_to_preparation item.val_type; + let sub = + [ Location.msg ~loc:item.val_loc + "The type of this value,@ %a,@ \ + contains the non-generalizable type variable(s) %a." + (Style.as_inline_code Out_type.prepared_type_scheme) + item.val_type + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + @@ Style.as_inline_code Out_type.prepared_type_scheme) vars + ] + in + Location.errorf ~loc ~sub + "@[The type of this module,@ %a,@ \ + contains non-generalizable type variable(s).@ %a@]" + modtype mty + Misc.print_see_manual manual_ref + | Implementation_is_required intf_name -> + Location.errorf ~loc + "@[The interface %a@ declares values, not just types.@ \ + An implementation must be provided.@]" + Location.Doc.quoted_filename intf_name + | Interface_not_compiled intf_name -> + Location.errorf ~loc + "@[Could not find the .cmi file for interface@ %a.@]" + Location.Doc.quoted_filename intf_name + | Not_allowed_in_functor_body -> + Location.errorf ~loc + "@[This expression creates fresh types.@ %s@]" + "It is not allowed inside applicative functors." + | Not_a_packed_module ty -> + Location.errorf ~loc + "This expression is not a packed module. It has type@ %a" + (Style.as_inline_code type_expr) ty + | Incomplete_packed_module ty -> + Location.errorf ~loc + "The type of this packed module contains variables:@ %a" + (Style.as_inline_code type_expr) ty + | Scoping_pack (lid, ty) -> + Location.errorf ~loc + "The type %a in this module cannot be exported.@ \ + Its type contains local dependencies:@ %a" + (Style.as_inline_code longident) lid + (Style.as_inline_code type_expr) ty + | Recursive_module_require_explicit_type -> + Location.errorf ~loc "Recursive modules require an explicit module type." + | Apply_generative -> + Location.errorf ~loc + "This is a generative functor. It can only be applied to %a" + Style.inline_code "()" + | Cannot_scrape_alias p -> + Location.errorf ~loc + "This is an alias for module %a, which is missing" + (Style.as_inline_code path) p + | Cannot_alias p -> + Location.errorf ~loc + "Functor arguments, such as %a, cannot be aliased" + (Style.as_inline_code path) p + | Cannot_scrape_package_type p -> + Location.errorf ~loc + "The type of this packed module refers to %a, which is missing" + (Style.as_inline_code path) p + | Badly_formed_signature (context, err) -> + Location.errorf ~loc "@[In %s:@ %a@]" + context + Typedecl.report_error_doc err + | Cannot_hide_id Illegal_shadowing + { shadowed_item_kind; shadowed_item_id; shadowed_item_loc; + shadower_id; user_id; user_kind; user_loc } -> + let shadowed = + Printtyp.namespaced_ident shadowed_item_kind shadowed_item_id + in + let shadower = + Printtyp.namespaced_ident shadowed_item_kind shadower_id + in + let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in + let shadowed_msg = + Location.msg ~loc:shadowed_item_loc + "@[%s %a came from this include.@]" + (String.capitalize_ascii shadowed_item_kind) + Style.inline_code shadowed + in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %a has no valid type@ if %a is shadowed.@]" + (Sig_component_kind.to_string user_kind) + Style.inline_code (Ident.name user_id) + Style.inline_code shadowed + in + Location.errorf ~loc ~sub:[shadowed_msg; user_msg] + "Illegal shadowing of included %s %a@ by %a." + shadowed_item_kind + Style.inline_code shadowed + Style.inline_code shadower + | Cannot_hide_id Appears_in_signature + { opened_item_kind; opened_item_id; user_id; user_kind; user_loc } -> + let opened_item_kind= Sig_component_kind.to_string opened_item_kind in + let opened_id = Ident.name opened_item_id in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %a has no valid type@ if %a is hidden.@]" + (Sig_component_kind.to_string user_kind) + Style.inline_code (Ident.name user_id) + Style.inline_code opened_id + in + Location.errorf ~loc ~sub:[user_msg] + "The %s %a introduced by this open appears in the signature." + opened_item_kind + Style.inline_code opened_id + | Invalid_type_subst_rhs -> + Location.errorf ~loc "Only type synonyms are allowed on the right of %a" + Style.inline_code ":=" + | Unpackable_local_modtype_subst p -> + let[@manual.ref "ss:module-type-substitution"] manual_ref = + [ 12; 7; 3 ] + in + Location.errorf ~loc + "The module type@ %a@ is not a valid type for a packed module:@ \ + it is defined as a local substitution (temporary name)@ \ + for an anonymous module type.@ %a" + Style.inline_code (Path.name p) + Misc.print_see_manual manual_ref + +let report_error env ~loc err = + Printtyp.wrap_printing_env ~error:true env + (fun () -> report_error env ~loc err) + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (report_error ~loc env err) + | Error_forward err -> + Some err + | _ -> + None + ) diff --git a/upstream/ocaml_503/typing/typemod.mli b/upstream/ocaml_503/typing/typemod.mli new file mode 100644 index 000000000..04a7591dc --- /dev/null +++ b/upstream/ocaml_503/typing/typemod.mli @@ -0,0 +1,143 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Type-checking of the module language and typed ast hooks + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Types + +module Signature_names : sig + type t + + val simplify: Env.t -> t -> signature -> signature +end + +val type_module: + Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t +val type_structure: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t +val type_toplevel_phrase: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t +val type_implementation: + Unit_info.t -> Env.t -> Parsetree.structure -> + Typedtree.implementation +val type_interface: + Env.t -> Parsetree.signature -> Typedtree.signature +val check_nongen_signature: + Env.t -> Types.signature -> unit + (* +val type_open_: + ?used_slot:bool ref -> ?toplevel:bool -> + Asttypes.override_flag -> + Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t + *) +val modtype_of_package: + Env.t -> Location.t -> + Path.t -> (Longident.t * type_expr) list -> module_type + +val path_of_module : Typedtree.module_expr -> Path.t option + +val save_signature: + Unit_info.t -> Typedtree.signature -> Env.t -> + Cmi_format.cmi_infos -> unit + +val package_units: + Env.t -> string list -> Unit_info.Artifact.t -> Typedtree.module_coercion + +(* Should be in Envaux, but it breaks the build of the debugger *) +val initial_env: + loc:Location.t -> + initially_opened_module:string option -> + open_implicit_modules:string list -> Env.t + +module Sig_component_kind : sig + type t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + val to_string : t -> string +end + +type hiding_error = + | Illegal_shadowing of { + shadowed_item_id: Ident.t; + shadowed_item_kind: Sig_component_kind.t; + shadowed_item_loc: Location.t; + shadower_id: Ident.t; + user_id: Ident.t; + user_kind: Sig_component_kind.t; + user_loc: Location.t; + } + | Appears_in_signature of { + opened_item_id: Ident.t; + opened_item_kind: Sig_component_kind.t; + user_id: Ident.t; + user_kind: Sig_component_kind.t; + user_loc: Location.t; + } + +type error = + Cannot_apply of module_type + | Not_included of Includemod.explanation + | Cannot_eliminate_dependency of module_type + | Signature_expected + | Structure_expected of module_type + | With_no_component of Longident.t + | With_mismatch of Longident.t * Includemod.explanation + | With_makes_applicative_functor_ill_typed of + Longident.t * Path.t * Includemod.explanation + | With_changes_module_alias of Longident.t * Ident.t * Path.t + | With_cannot_remove_constrained_type + | With_package_manifest of Longident.t * type_expr + | Repeated_name of Sig_component_kind.t * string + | Non_generalizable of { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : module_type } + | Implementation_is_required of string + | Interface_not_compiled of string + | Not_allowed_in_functor_body + | Not_a_packed_module of type_expr + | Incomplete_packed_module of type_expr + | Scoping_pack of Longident.t * type_expr + | Recursive_module_require_explicit_type + | Apply_generative + | Cannot_scrape_alias of Path.t + | Cannot_scrape_package_type of Path.t + | Badly_formed_signature of string * Typedecl.error + | Cannot_hide_id of hiding_error + | Invalid_type_subst_rhs + | Unpackable_local_modtype_subst of Path.t + | With_cannot_remove_packed_modtype of Path.t * module_type + | Cannot_alias of Path.t + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +val report_error: Env.t -> loc:Location.t -> error -> Location.error diff --git a/upstream/ocaml_503/typing/typeopt.ml b/upstream/ocaml_503/typing/typeopt.ml new file mode 100644 index 000000000..2b8fd3e95 --- /dev/null +++ b/upstream/ocaml_503/typing/typeopt.ml @@ -0,0 +1,227 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +open Path +open Types +open Asttypes +open Typedtree +open Lambda + +let scrape_ty env ty = + match get_desc ty with + | Tconstr _ -> + let ty = Ctype.expand_head_opt env ty in + begin match get_desc ty with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with + | {type_kind = ( Type_variant (_, Variant_unboxed) + | Type_record (_, Record_unboxed _) ); _} -> begin + match Typedecl_unboxed.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2 + end + | _ -> ty + | exception Not_found -> ty + end + | _ -> + ty + end + | _ -> ty + +let scrape env ty = + get_desc (scrape_ty env ty) + +let scrape_poly env ty = + let ty = scrape_ty env ty in + match get_desc ty with + | Tpoly (ty, _) -> get_desc ty + | d -> d + +let is_function_type env ty = + match scrape env ty with + | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs) + | _ -> None + +let is_base_type env ty base_ty_path = + match scrape env ty with + | Tconstr(p, _, _) -> Path.same p base_ty_path + | _ -> false + +let is_immediate = function + | Type_immediacy.Unknown -> false + | Type_immediacy.Always -> true + | Type_immediacy.Always_on_64bits -> + (* In bytecode, we don't know at compile time whether we are + targeting 32 or 64 bits. *) + !Clflags.native_code && Sys.word_size = 64 + +let maybe_pointer_type env ty = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Immediate + else Pointer + +let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type + +type classification = + | Int + | Float + | Lazy + | Addr (* anything except a float or a lazy *) + | Any + +let classify env ty = + let ty = scrape_ty env ty in + if maybe_pointer_type env ty = Immediate then Int + else match get_desc ty with + | Tvar _ | Tunivar _ -> + Any + | Tconstr (p, _args, _abbrev) -> + if Path.same p Predef.path_float then Float + else if Path.same p Predef.path_lazy_t then Lazy + else if Path.same p Predef.path_string + || Path.same p Predef.path_bytes + || Path.same p Predef.path_array + || Path.same p Predef.path_nativeint + || Path.same p Predef.path_int32 + || Path.same p Predef.path_int64 then Addr + else begin + try + match (Env.find_type p env).type_kind with + | Type_abstract _ -> + Any + | Type_record _ | Type_variant _ | Type_open -> + Addr + with Not_found -> + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *) + Any + end + | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ -> + Addr + | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> + assert false + +let array_type_kind env ty = + match scrape_poly env ty with + | Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array -> + begin match classify env elt_ty with + | Any -> if Config.flat_float_array then Pgenarray else Paddrarray + | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray + | Addr | Lazy -> Paddrarray + | Int -> Pintarray + end + | Tconstr(p, [], _) when Path.same p Predef.path_floatarray -> + Pfloatarray + | _ -> + (* This can happen with e.g. Obj.field *) + Pgenarray + +let array_kind exp = array_type_kind exp.exp_env exp.exp_type + +let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type + +let bigarray_decode_type env ty tbl dfl = + match scrape env ty with + | Tconstr(Pdot(Pident mod_id, type_name), [], _) + when Ident.name mod_id = "Stdlib__Bigarray" -> + begin try List.assoc type_name tbl with Not_found -> dfl end + | _ -> + dfl + +let kind_table = + ["float16_elt", Pbigarray_float16; + "float32_elt", Pbigarray_float32; + "float64_elt", Pbigarray_float64; + "int8_signed_elt", Pbigarray_sint8; + "int8_unsigned_elt", Pbigarray_uint8; + "int16_signed_elt", Pbigarray_sint16; + "int16_unsigned_elt", Pbigarray_uint16; + "int32_elt", Pbigarray_int32; + "int64_elt", Pbigarray_int64; + "int_elt", Pbigarray_caml_int; + "nativeint_elt", Pbigarray_native_int; + "complex32_elt", Pbigarray_complex32; + "complex64_elt", Pbigarray_complex64] + +let layout_table = + ["c_layout", Pbigarray_c_layout; + "fortran_layout", Pbigarray_fortran_layout] + +let bigarray_type_kind_and_layout env typ = + match scrape env typ with + | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) -> + (bigarray_decode_type env elt_type kind_table Pbigarray_unknown, + bigarray_decode_type env layout_type layout_table + Pbigarray_unknown_layout) + | _ -> + (Pbigarray_unknown, Pbigarray_unknown_layout) + +let value_kind env ty = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Pintval + else begin + match get_desc ty with + | Tconstr(p, _, _) when Path.same p Predef.path_float -> + Pfloatval + | Tconstr(p, _, _) when Path.same p Predef.path_int32 -> + Pboxedintval Pint32 + | Tconstr(p, _, _) when Path.same p Predef.path_int64 -> + Pboxedintval Pint64 + | Tconstr(p, _, _) when Path.same p Predef.path_nativeint -> + Pboxedintval Pnativeint + | _ -> + Pgenval + end + +(** Whether a forward block is needed for a lazy thunk on a value, i.e. + if the value can be represented as a float/forward/lazy *) +let lazy_val_requires_forward env ty = + match classify env ty with + | Any | Lazy -> true + | Float -> Config.flat_float_array + | Addr | Int -> false + +(** The compilation of the expression [lazy e] depends on the form of e: + constants, floats and identifiers are optimized. The optimization must be + taken into account when determining whether a recursive binding is safe. *) +let classify_lazy_argument : Typedtree.expression -> + [`Constant_or_function + |`Float_that_cannot_be_shortcut + |`Identifier of [`Forward_value|`Other] + |`Other] = + fun e -> match e.exp_desc with + | Texp_constant + ( Const_int _ | Const_char _ | Const_string _ + | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) + | Texp_function _ + | Texp_construct (_, {cstr_arity = 0}, _) -> + `Constant_or_function + | Texp_constant(Const_float _) -> + if Config.flat_float_array + then `Float_that_cannot_be_shortcut + else `Constant_or_function + | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type -> + `Identifier `Forward_value + | Texp_ident _ -> + `Identifier `Other + | _ -> + `Other + +let value_kind_union k1 k2 = + if k1 = k2 then k1 + else Pgenval diff --git a/upstream/ocaml_503/typing/typeopt.mli b/upstream/ocaml_503/typing/typeopt.mli new file mode 100644 index 000000000..d1fcf41e7 --- /dev/null +++ b/upstream/ocaml_503/typing/typeopt.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +val is_function_type : + Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option +val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool + +val maybe_pointer_type : Env.t -> Types.type_expr + -> Lambda.immediate_or_pointer +val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer + +val array_type_kind : Env.t -> Types.type_expr -> Lambda.array_kind +val array_kind : Typedtree.expression -> Lambda.array_kind +val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind +val bigarray_type_kind_and_layout : + Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout +val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind + +val classify_lazy_argument : Typedtree.expression -> + [ `Constant_or_function + | `Float_that_cannot_be_shortcut + | `Identifier of [`Forward_value | `Other] + | `Other] + +val value_kind_union : + Lambda.value_kind -> Lambda.value_kind -> Lambda.value_kind + (** [value_kind_union k1 k2] is a value_kind at least as general as + [k1] and [k2] *) diff --git a/upstream/ocaml_503/typing/types.ml b/upstream/ocaml_503/typing/types.ml new file mode 100644 index 000000000..c66c98eaa --- /dev/null +++ b/upstream/ocaml_503/typing/types.ml @@ -0,0 +1,961 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Representation of types and declarations *) + +open Asttypes + +(* Type expressions for the core language *) + +type transient_expr = + { mutable desc: type_desc; + mutable level: int; + mutable scope: scope_field; + id: int } + +and scope_field = int + (* bit field: 27 bits for scope (Ident.highest_scope = 100_000_000) + and at least 4 marks *) + +and type_expr = transient_expr + +and type_desc = + Tvar of string option + | Tarrow of arg_label * type_expr * type_expr * commutable + | Ttuple of type_expr list + | Tconstr of Path.t * type_expr list * abbrev_memo ref + | Tobject of type_expr * (Path.t * type_expr list) option ref + | Tfield of string * field_kind * type_expr * type_expr + | Tnil + | Tlink of type_expr + | Tsubst of type_expr * type_expr option + | Tvariant of row_desc + | Tunivar of string option + | Tpoly of type_expr * type_expr list + | Tpackage of Path.t * (Longident.t * type_expr) list + +and row_desc = + { row_fields: (label * row_field) list; + row_more: type_expr; + row_closed: bool; + row_fixed: fixed_explanation option; + row_name: (Path.t * type_expr list) option } +and fixed_explanation = + | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid +and row_field = [`some] row_field_gen +and row_field_cell = [`some | `none] row_field_gen ref +and _ row_field_gen = + RFpresent : type_expr option -> [> `some] row_field_gen + | RFeither : + { no_arg: bool; + arg_type: type_expr list; + matched: bool; + ext: row_field_cell} -> [> `some] row_field_gen + | RFabsent : [> `some] row_field_gen + | RFnone : [> `none] row_field_gen + +and abbrev_memo = + Mnil + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + | Mlink of abbrev_memo ref + +and any = [`some | `none | `var] +and field_kind = [`some|`var] field_kind_gen +and _ field_kind_gen = + FKvar : {mutable field_kind: any field_kind_gen} -> [> `var] field_kind_gen + | FKprivate : [> `none] field_kind_gen (* private method; only under FKvar *) + | FKpublic : [> `some] field_kind_gen (* public method *) + | FKabsent : [> `some] field_kind_gen (* hidden private method *) + +and commutable = [`some|`var] commutable_gen +and _ commutable_gen = + Cok : [> `some] commutable_gen + | Cunknown : [> `none] commutable_gen + | Cvar : {mutable commu: any commutable_gen} -> [> `var] commutable_gen + +module TransientTypeOps = struct + type t = type_expr + let compare t1 t2 = t1.id - t2.id + let hash t = t.id + let equal t1 t2 = t1 == t2 +end + +module TransientTypeHash = Hashtbl.Make(TransientTypeOps) + +(* *) + +module Uid = Shape.Uid + +(* Maps of methods and instance variables *) + +module MethSet = Misc.Stdlib.String.Set +module VarSet = Misc.Stdlib.String.Set + +module Meths = Misc.Stdlib.String.Map +module Vars = Misc.Stdlib.String.Map + + +(* Value descriptions *) + +type value_description = + { val_type: type_expr; (* Type of the value *) + val_kind: value_kind; + val_loc: Location.t; + val_attributes: Parsetree.attributes; + val_uid: Uid.t; + } + +and value_kind = + Val_reg (* Regular value *) + | Val_prim of Primitive.description (* Primitive *) + | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) + | Val_self of + class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + +(* Variance *) +(* Variance forms a product lattice of the following partial orders: + 0 <= may_pos <= pos + 0 <= may_weak <= may_neg <= neg + 0 <= inj + Additionally, the following implications are valid + pos => inj + neg => inj + Examples: + type 'a t : may_pos + may_neg + may_weak + type 'a t = 'a : pos + type 'a t = 'a -> unit : neg + type 'a t = ('a -> unit) -> unit : pos + may_weak + type 'a t = A of (('a -> unit) -> unit) : pos + type +'a p = .. : may_pos + inj + type +!'a t : may_pos + inj + type -!'a t : may_neg + inj + type 'a t = A : inj + *) + +module Variance = struct + type t = int + type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv + let single = function + | May_pos -> 1 + | May_neg -> 2 + 4 + | May_weak -> 4 + | Inj -> 8 + | Pos -> 16 + 8 + 1 + | Neg -> 32 + 8 + 4 + 2 + | Inv -> 63 + let union v1 v2 = v1 lor v2 + let inter v1 v2 = v1 land v2 + let subset v1 v2 = (v1 land v2 = v1) + let eq (v1 : t) v2 = (v1 = v2) + let set x v = union v (single x) + let set_if b x v = if b then set x v else v + let mem x = subset (single x) + let null = 0 + let unknown = 7 + let full = single Inv + let covariant = single Pos + let contravariant = single Neg + let swap f1 f2 v v' = + set_if (mem f2 v) f1 (set_if (mem f1 v) f2 v') + let conjugate v = + let v' = inter v (union (single Inj) (single May_weak)) in + swap Pos Neg v (swap May_pos May_neg v v') + let compose v1 v2 = + if mem Inv v1 && mem Inj v2 then full else + let mp = + mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2 + and mn = + mem May_pos v1 && mem May_neg v2 || mem May_neg v1 && mem May_pos v2 + and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2 + and inj = mem Inj v1 && mem Inj v2 + and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2 + and neg = mem Pos v1 && mem Neg v2 || mem Neg v1 && mem Pos v2 in + List.fold_left (fun v (b,f) -> set_if b f v) null + [mp, May_pos; mn, May_neg; mw, May_weak; inj, Inj; pos, Pos; neg, Neg] + let strengthen v = + if mem May_neg v then v else v land (full - single May_weak) + let get_upper v = (mem May_pos v, mem May_neg v) + let get_lower v = (mem Pos v, mem Neg v, mem Inj v) + let unknown_signature ~injective ~arity = + let v = if injective then set Inj unknown else unknown in + Misc.replicate_list v arity +end + +module Separability = struct + type t = Ind | Sep | Deepsep + type signature = t list + let eq (m1 : t) m2 = (m1 = m2) + let rank = function + | Ind -> 0 + | Sep -> 1 + | Deepsep -> 2 + let compare m1 m2 = compare (rank m1) (rank m2) + let max m1 m2 = if rank m1 >= rank m2 then m1 else m2 + + let print ppf = function + | Ind -> Format.fprintf ppf "Ind" + | Sep -> Format.fprintf ppf "Sep" + | Deepsep -> Format.fprintf ppf "Deepsep" + + let print_signature ppf modes = + let pp_sep ppf () = Format.fprintf ppf ",@," in + Format.fprintf ppf "@[(%a)@]" + (Format.pp_print_list ~pp_sep print) modes + + let default_signature ~arity = + let default_mode = if Config.flat_float_array then Deepsep else Ind in + Misc.replicate_list default_mode arity +end + +(* Type definitions *) + +type type_declaration = + { type_params: type_expr list; + type_arity: int; + type_kind: type_decl_kind; + type_private: private_flag; + type_manifest: type_expr option; + type_variance: Variance.t list; + type_separability: Separability.t list; + type_is_newtype: bool; + type_expansion_scope: int; + type_loc: Location.t; + type_attributes: Parsetree.attributes; + type_immediate: Type_immediacy.t; + type_unboxed_default: bool; + type_uid: Uid.t; + } + +and type_decl_kind = (label_declaration, constructor_declaration) type_kind + +and ('lbl, 'cstr) type_kind = + Type_abstract of type_origin + | Type_record of 'lbl list * record_representation + | Type_variant of 'cstr list * variant_representation + | Type_open + +and type_origin = + Definition + | Rec_check_regularity + | Existential of string + +and record_representation = + Record_regular (* All fields are boxed / tagged *) + | Record_float (* All fields are floats *) + | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) + | Record_inlined of int (* Inlined record *) + | Record_extension of Path.t (* Inlined record under extension *) + +and variant_representation = + Variant_regular (* Constant or boxed constructors *) + | Variant_unboxed (* One unboxed single-field constructor *) + +and label_declaration = + { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; + ld_uid: Uid.t; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_args: constructor_arguments; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; + cd_uid: Uid.t; + } + +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + +type extension_constructor = + { ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + ext_uid: Uid.t; + } + +and type_transparence = + Type_public (* unrestricted expansion *) + | Type_new (* "new" type *) + | Type_private (* private type *) + +(* Type expressions for the class language *) + +type class_type = + Cty_constr of Path.t * type_expr list * class_type + | Cty_signature of class_signature + | Cty_arrow of arg_label * type_expr * class_type + +type class_declaration = + { cty_params: type_expr list; + mutable cty_type: class_type; + cty_path: Path.t; + cty_new: type_expr option; + cty_variance: Variance.t list; + cty_loc: Location.t; + cty_attributes: Parsetree.attributes; + cty_uid: Uid.t; + } + +type class_type_declaration = + { clty_params: type_expr list; + clty_type: class_type; + clty_path: Path.t; + clty_hash_type: type_declaration; + clty_variance: Variance.t list; + clty_loc: Location.t; + clty_attributes: Parsetree.attributes; + clty_uid: Uid.t; + } + +(* Type expressions for the module language *) + +type visibility = + | Exported + | Hidden + +type module_type = + Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of functor_parameter * module_type + | Mty_alias of Path.t + +and functor_parameter = + | Unit + | Named of Ident.t option * module_type + +and module_presence = + | Mp_present + | Mp_absent + +and signature = signature_item list + +and signature_item = + Sig_value of Ident.t * value_description * visibility + | Sig_type of Ident.t * type_declaration * rec_status * visibility + | Sig_typext of Ident.t * extension_constructor * ext_status * visibility + | Sig_module of + Ident.t * module_presence * module_declaration * rec_status * visibility + | Sig_modtype of Ident.t * modtype_declaration * visibility + | Sig_class of Ident.t * class_declaration * rec_status * visibility + | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility + +and module_declaration = + { + md_type: module_type; + md_attributes: Parsetree.attributes; + md_loc: Location.t; + md_uid: Uid.t; + } + +and modtype_declaration = + { + mtd_type: module_type option; (* Note: abstract *) + mtd_attributes: Parsetree.attributes; + mtd_loc: Location.t; + mtd_uid: Uid.t; + } + +and rec_status = + Trec_not (* first in a nonrecursive group *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) + +and ext_status = + Text_first (* first constructor of an extension *) + | Text_next (* not first constructor of an extension *) + | Text_exception (* an exception *) + + +(* Constructor and record label descriptions inserted held in typing + environments *) + +type constructor_description = + { cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; + cstr_uid: Uid.t; + } + +and constructor_tag = + Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_unboxed (* Constructor of an unboxed type *) + | Cstr_extension of Path.t * bool (* Extension constructor + true if a constant false if a block*) + +let equal_tag t1 t2 = + match (t1, t2) with + | Cstr_constant i1, Cstr_constant i2 -> i2 = i1 + | Cstr_block i1, Cstr_block i2 -> i2 = i1 + | Cstr_unboxed, Cstr_unboxed -> true + | Cstr_extension (path1, b1), Cstr_extension (path2, b2) -> + Path.same path1 path2 && b1 = b2 + | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false + +let may_equal_constr c1 c2 = + c1.cstr_arity = c2.cstr_arity + && (match c1.cstr_tag,c2.cstr_tag with + | Cstr_extension _,Cstr_extension _ -> + (* extension constructors may be rebindings of each other *) + true + | tag1, tag2 -> + equal_tag tag1 tag2) + +let item_visibility = function + | Sig_value (_, _, vis) + | Sig_type (_, _, _, vis) + | Sig_typext (_, _, _, vis) + | Sig_module (_, _, _, _, vis) + | Sig_modtype (_, _, vis) + | Sig_class (_, _, _, vis) + | Sig_class_type (_, _, _, vis) -> vis + +type label_description = + { lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_pos: int; (* Position in block *) + lbl_all: label_description array; (* All the labels in this type *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +let rec bound_value_identifiers = function + [] -> [] + | Sig_value(id, {val_kind = Val_reg}, _) :: rem -> + id :: bound_value_identifiers rem + | Sig_typext(id, _, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, Mp_present, _, _, _) :: rem -> + id :: bound_value_identifiers rem + | Sig_class(id, _, _, _) :: rem -> id :: bound_value_identifiers rem + | _ :: rem -> bound_value_identifiers rem + +let signature_item_id = function + | Sig_value (id, _, _) + | Sig_type (id, _, _, _) + | Sig_typext (id, _, _, _) + | Sig_module (id, _, _, _, _) + | Sig_modtype (id, _, _) + | Sig_class (id, _, _, _) + | Sig_class_type (id, _, _, _) + -> id + +(**** Definitions for backtracking ****) + +type change = + Ctype of type_expr * type_desc + | Ccompress of type_expr * type_desc * type_desc + | Clevel of type_expr * int + | Cscope of type_expr * int + | Cname of + (Path.t * type_expr list) option ref * (Path.t * type_expr list) option + | Crow of [`none|`some] row_field_gen ref + | Ckind of [`var] field_kind_gen + | Ccommu of [`var] commutable_gen + | Cuniv of type_expr option ref * type_expr option + +type changes = + Change of change * changes ref + | Unchanged + | Invalid + +let trail = Local_store.s_table ref Unchanged + +let log_change ch = + let r' = ref Unchanged in + !trail := Change (ch, r'); + trail := r' + +(* constructor and accessors for [field_kind] *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +let rec field_kind_internal_repr : field_kind -> field_kind = function + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as fk} -> + field_kind_internal_repr fk + | kind -> kind + +let field_kind_repr fk = + match field_kind_internal_repr fk with + | FKvar _ -> Fprivate + | FKpublic -> Fpublic + | FKabsent -> Fabsent + +let field_public = FKpublic +let field_absent = FKabsent +let field_private () = FKvar {field_kind=FKprivate} + +(* Constructor and accessors for [commutable] *) + +let rec is_commu_ok : type a. a commutable_gen -> bool = function + | Cvar {commu} -> is_commu_ok commu + | Cunknown -> false + | Cok -> true + +let commu_ok = Cok +let commu_var () = Cvar {commu=Cunknown} + +(**** Representative of a type ****) + +let rec repr_link (t : type_expr) d : type_expr -> type_expr = + function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> + log_change (Ccompress (t, t.desc, d)); + t.desc <- d; + t' + +let repr_link1 t = function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> t' + +let repr t = + match t.desc with + Tlink t' -> + repr_link1 t t' + | Tfield (_, k, _, t') when field_kind_internal_repr k = FKabsent -> + repr_link1 t t' + | _ -> t + +(* scope_field and marks *) + +let scope_mask = (1 lsl 27) - 1 +let marks_mask = (-1) lxor scope_mask +let () = assert (Ident.highest_scope land marks_mask = 0) + +type type_mark = + | Mark of {mark: int; mutable marked: type_expr list} + | Hash of {visited: unit TransientTypeHash.t} +let type_marks = + (* All the bits in marks_mask *) + List.init (Sys.int_size - 27) (fun x -> 1 lsl (x + 27)) +let available_marks = Local_store.s_ref type_marks +let with_type_mark f = + match !available_marks with + | mark :: rem as old -> + available_marks := rem; + let mk = Mark {mark; marked = []} in + Misc.try_finally (fun () -> f mk) ~always: begin fun () -> + available_marks := old; + match mk with + | Mark {marked} -> + (* unmark marked type nodes *) + List.iter + (fun ty -> ty.scope <- ty.scope land ((-1) lxor mark)) + marked + | Hash _ -> () + end + | [] -> + (* When marks are exhausted, fall back to using a hash table *) + f (Hash {visited = TransientTypeHash.create 1}) + +(* getters for type_expr *) + +let get_desc t = (repr t).desc +let get_level t = (repr t).level +let get_scope t = (repr t).scope land scope_mask +let get_id t = (repr t).id +let not_marked_node mark t = + match mark with + | Mark {mark} -> (repr t).scope land mark = 0 + | Hash {visited} -> not (TransientTypeHash.mem visited (repr t)) + +(* transient type_expr *) + +module Transient_expr = struct + let create desc ~level ~scope ~id = {desc; level; scope; id} + let set_desc ty d = ty.desc <- d + let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d + let set_level ty lv = ty.level <- lv + let get_scope ty = ty.scope land scope_mask + let get_marks ty = ty.scope lsr 27 + let set_scope ty sc = + if (sc land marks_mask <> 0) then + invalid_arg "Types.Transient_expr.set_scope"; + ty.scope <- (ty.scope land marks_mask) lor sc + let try_mark_node mark ty = + match mark with + | Mark ({mark} as mk) -> + (ty.scope land mark = 0) && (* mark type node when not marked *) + (ty.scope <- ty.scope lor mark; mk.marked <- ty :: mk.marked; true) + | Hash {visited} -> + not (TransientTypeHash.mem visited ty) && + (TransientTypeHash.add visited ty (); true) + let coerce ty = ty + let repr = repr + let type_expr ty = ty +end + +(* setting marks *) +let try_mark_node mark t = Transient_expr.try_mark_node mark (repr t) + +(* Comparison for [type_expr]; cannot be used for functors *) + +let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 +let compare_type t1 t2 = compare (get_id t1) (get_id t2) + +(* Constructor and accessors for [row_desc] *) + +let create_row ~fields ~more ~closed ~fixed ~name = + { row_fields=fields; row_more=more; + row_closed=closed; row_fixed=fixed; row_name=name } + +(* [row_fields] subsumes the original [row_repr] *) +let rec row_fields row = + match get_desc row.row_more with + | Tvariant row' -> + row.row_fields @ row_fields row' + | _ -> + row.row_fields + +let rec row_repr_no_fields row = + match get_desc row.row_more with + | Tvariant row' -> row_repr_no_fields row' + | _ -> row + +let row_more row = (row_repr_no_fields row).row_more +let row_closed row = (row_repr_no_fields row).row_closed +let row_fixed row = (row_repr_no_fields row).row_fixed +let row_name row = (row_repr_no_fields row).row_name + +let rec get_row_field tag row = + let rec find = function + | (tag',f) :: fields -> + if tag = tag' then f else find fields + | [] -> + match get_desc row.row_more with + | Tvariant row' -> get_row_field tag row' + | _ -> RFabsent + in find row.row_fields + +let set_row_name row row_name = + let row_fields = row_fields row in + let row = row_repr_no_fields row in + {row with row_fields; row_name} + +type row_desc_repr = + Row of { fields: (label * row_field) list; + more:type_expr; + closed:bool; + fixed:fixed_explanation option; + name:(Path.t * type_expr list) option } + +let row_repr row = + let fields = row_fields row in + let row = row_repr_no_fields row in + Row { fields; + more = row.row_more; + closed = row.row_closed; + fixed = row.row_fixed; + name = row.row_name } + +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +let rec row_field_repr_aux tl : row_field -> row_field = function + | RFeither ({ext = {contents = RFnone}} as r) -> + RFeither {r with arg_type = tl@r.arg_type} + | RFeither {arg_type; + ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_repr_aux (tl@arg_type) rf + | RFpresent (Some _) when tl <> [] -> + RFpresent (Some (List.hd tl)) + | RFpresent _ as rf -> rf + | RFabsent -> RFabsent + +let row_field_repr fi = + match row_field_repr_aux [] fi with + | RFeither {no_arg; arg_type; matched} -> Reither (no_arg, arg_type, matched) + | RFpresent t -> Rpresent t + | RFabsent -> Rabsent + +let rec row_field_ext (fi : row_field) = + match fi with + | RFeither {ext = {contents = RFnone} as ext} -> ext + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_ext rf + | _ -> Misc.fatal_error "Types.row_field_ext " + +let rf_present oty = RFpresent oty +let rf_absent = RFabsent +let rf_either ?use_ext_of ~no_arg arg_type ~matched = + let ext = + match use_ext_of with + Some rf -> row_field_ext rf + | None -> ref RFnone + in + RFeither {no_arg; arg_type; matched; ext} + +let rf_either_of = function + | None -> + RFeither {no_arg=true; arg_type=[]; matched=false; ext=ref RFnone} + | Some ty -> + RFeither {no_arg=false; arg_type=[ty]; matched=false; ext=ref RFnone} + +let eq_row_field_ext rf1 rf2 = + row_field_ext rf1 == row_field_ext rf2 + +let changed_row_field_exts l f = + let exts = List.map row_field_ext l in + f (); + List.exists (fun r -> !r <> RFnone) exts + +let match_row_field ~present ~absent ~either (f : row_field) = + match f with + | RFabsent -> absent () + | RFpresent t -> present t + | RFeither {no_arg; arg_type; matched; ext} -> + let e : row_field option = + match !ext with + | RFnone -> None + | RFeither _ | RFpresent _ | RFabsent as e -> Some e + in + either no_arg arg_type matched (ext,e) + +(**** Some type creators ****) + +let new_id = Local_store.s_ref (-1) + +let create_expr = Transient_expr.create + +let proto_newty3 ~level ~scope desc = + incr new_id; + create_expr desc ~level ~scope ~id:!new_id + + (**********************************) + (* Utilities for backtracking *) + (**********************************) + +let undo_change = function + Ctype (ty, desc) -> Transient_expr.set_desc ty desc + | Ccompress (ty, desc, _) -> Transient_expr.set_desc ty desc + | Clevel (ty, level) -> Transient_expr.set_level ty level + | Cscope (ty, scope) -> Transient_expr.set_scope ty scope + | Cname (r, v) -> r := v + | Crow r -> r := RFnone + | Ckind (FKvar r) -> r.field_kind <- FKprivate + | Ccommu (Cvar r) -> r.commu <- Cunknown + | Cuniv (r, v) -> r := v + +type snapshot = changes ref * int +let last_snapshot = Local_store.s_ref 0 + +let log_type ty = + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) +let link_type ty ty' = + let ty = repr ty in + let ty' = repr ty' in + if ty == ty' then () else begin + log_type ty; + let desc = ty.desc in + Transient_expr.set_desc ty (Tlink ty'); + (* Name is a user-supplied name for this unification variable (obtained + * through a type annotation for instance). *) + match desc, ty'.desc with + Tvar name, Tvar name' -> + begin match name, name' with + | Some _, None -> log_type ty'; Transient_expr.set_desc ty' (Tvar name) + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then + (log_type ty'; Transient_expr.set_desc ty' (Tvar name)) + | None, None -> () + end + | _ -> () + end + (* ; assert (check_memorized_abbrevs ()) *) + (* ; check_expans [] ty' *) +(* TODO: consider eliminating set_type_desc, replacing it with link types *) +let set_type_desc ty td = + let ty = repr ty in + if td != ty.desc then begin + log_type ty; + Transient_expr.set_desc ty td + end +(* TODO: separate set_level into two specific functions: *) +(* set_lower_level and set_generic_level *) +let set_level ty level = + let ty = repr ty in + if level <> ty.level then begin + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + Transient_expr.set_level ty level + end + +(* TODO: introduce a guard and rename it to set_higher_scope? *) +let set_scope ty scope = + let ty = repr ty in + let prev_scope = ty.scope land marks_mask in + if scope <> prev_scope then begin + if ty.id <= !last_snapshot then log_change (Cscope (ty, prev_scope)); + Transient_expr.set_scope ty scope + end + +let set_univar rty ty = + log_change (Cuniv (rty, !rty)); rty := Some ty +let set_name nm v = + log_change (Cname (nm, !nm)); nm := v + +let rec link_row_field_ext ~(inside : row_field) (v : row_field) = + match inside with + | RFeither {ext = {contents = RFnone} as e} -> + let RFeither _ | RFpresent _ | RFabsent as v = v in + log_change (Crow e); e := v + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + link_row_field_ext ~inside:rf v + | _ -> invalid_arg "Types.link_row_field_ext" + +let rec link_kind ~(inside : field_kind) (k : field_kind) = + match inside with + | FKvar ({field_kind = FKprivate} as rk) as inside -> + (* prevent a loop by normalizing k and comparing it with inside *) + let FKvar _ | FKpublic | FKabsent as k = field_kind_internal_repr k in + if k != inside then begin + log_change (Ckind inside); + rk.field_kind <- k + end + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as inside} -> + link_kind ~inside k + | _ -> invalid_arg "Types.link_kind" + +let rec commu_repr : commutable -> commutable = function + | Cvar {commu = Cvar _ | Cok as commu} -> commu_repr commu + | c -> c + +let rec link_commu ~(inside : commutable) (c : commutable) = + match inside with + | Cvar ({commu = Cunknown} as rc) as inside -> + (* prevent a loop by normalizing c and comparing it with inside *) + let Cvar _ | Cok as c = commu_repr c in + if c != inside then begin + log_change (Ccommu inside); + rc.commu <- c + end + | Cvar {commu = Cvar _ | Cok as inside} -> + link_commu ~inside c + | _ -> invalid_arg "Types.link_commu" + +let set_commu_ok c = link_commu ~inside:c Cok + +let snapshot () = + let old = !last_snapshot in + last_snapshot := !new_id; + (!trail, old) + +let rec rev_log accu = function + Unchanged -> accu + | Invalid -> assert false + | Change (ch, next) -> + let d = !next in + next := Invalid; + rev_log (ch::accu) d + +let backtrack ~cleanup_abbrev (changes, old) = + match !changes with + Unchanged -> last_snapshot := old + | Invalid -> failwith "Types.backtrack" + | Change _ as change -> + cleanup_abbrev (); + let backlog = rev_log [] change in + List.iter undo_change backlog; + changes := Unchanged; + last_snapshot := old; + trail := changes + +let undo_first_change_after (changes, _) = + match !changes with + | Change (ch, _) -> + undo_change ch + | _ -> () + +let rec rev_compress_log log r = + match !r with + Unchanged | Invalid -> + log + | Change (Ccompress _, next) -> + rev_compress_log (r::log) next + | Change (_, next) -> + rev_compress_log log next + +let undo_compress (changes, _old) = + match !changes with + Unchanged + | Invalid -> () + | Change _ -> + let log = rev_compress_log [] changes in + List.iter + (fun r -> match !r with + Change (Ccompress (ty, desc, d), next) when ty.desc == d -> + Transient_expr.set_desc ty desc; r := !next + | _ -> ()) + log diff --git a/upstream/ocaml_503/typing/types.mli b/upstream/ocaml_503/typing/types.mli new file mode 100644 index 000000000..ca0cc6e06 --- /dev/null +++ b/upstream/ocaml_503/typing/types.mli @@ -0,0 +1,758 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** {0 Representation of types and declarations} *) + +(** [Types] defines the representation of types and declarations (that is, the + content of module signatures). + + CMI files are made of marshalled types. +*) + +(** Asttypes exposes basic definitions shared both by Parsetree and Types. *) +open Asttypes + +(** Type expressions for the core language. + + The [type_desc] variant defines all the possible type expressions one can + find in OCaml. [type_expr] wraps this with some annotations. + + The [level] field tracks the level of polymorphism associated to a type, + guiding the generalization algorithm. + Put shortly, when referring to a type in a given environment, both the type + and the environment have a level. If the type has an higher level, then it + can be considered fully polymorphic (type variables will be printed as + ['a]), otherwise it'll be weakly polymorphic, or non generalized (type + variables printed as ['_a]). + See [http://okmij.org/ftp/ML/generalization.html] for more information. + + Note about [type_declaration]: one should not make the confusion between + [type_expr] and [type_declaration]. + + [type_declaration] refers specifically to the [type] construct in OCaml + language, where you create and name a new type or type alias. + + [type_expr] is used when you refer to existing types, e.g. when annotating + the expected type of a value. + + Also, as the type system of OCaml is generative, a [type_declaration] can + have the side-effect of introducing a new type constructor, different from + all other known types. + Whereas [type_expr] is a pure construct which allows referring to existing + types. + + Note on mutability: TBD. + *) +type type_expr +type row_desc +type row_field +type field_kind +type commutable + +type type_desc = + | Tvar of string option + (** [Tvar (Some "a")] ==> ['a] or ['_a] + [Tvar None] ==> [_] *) + + | Tarrow of arg_label * type_expr * type_expr * commutable + (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] + [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1 -> e2] + [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2] + + See [commutable] for the last argument. *) + + | Ttuple of type_expr list + (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) + + | Tconstr of Path.t * type_expr list * abbrev_memo ref + (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] + The last parameter keep tracks of known expansions, see [abbrev_memo]. *) + + | Tobject of type_expr * (Path.t * type_expr list) option ref + (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >] + f1, fn are represented as a linked list of types using Tfield and Tnil + constructors. + + [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct]. + where A.ct is the type of some class. + + There are also special cases for so-called "class-types", cf. [Typeclass] + and [Ctype.set_object_name]: + + [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...), + Some(`A.#ct`, [rv;t1;...;tn])] + ==> [(t1, ..., tn) #A.ct] + [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct] + + where [rv] is the hidden row variable. + *) + + | Tfield of string * field_kind * type_expr * type_expr + (** [Tfield ("foo", field_public, t, ts)] ==> [<...; foo : t; ts>] *) + + | Tnil + (** [Tnil] ==> [<...; >] *) + + | Tlink of type_expr + (** Indirection used by unification engine. *) + + | Tsubst of type_expr * type_expr option + (** [Tsubst] is used temporarily to store information in low-level + functions manipulating representation of types, such as + instantiation or copy. + The first argument contains a copy of the original node. + The second is available only when the first is the row variable of + a polymorphic variant. It then contains a copy of the whole variant. + This constructor should not appear outside of these cases. *) + + | Tvariant of row_desc + (** Representation of polymorphic variants, see [row_desc]. *) + + | Tunivar of string option + (** Occurrence of a type variable introduced by a + forall quantifier / [Tpoly]. *) + + | Tpoly of type_expr * type_expr list + (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty], + where 'a1 ... 'an are names given to types in tyl + and occurrences of those types in ty. *) + + | Tpackage of Path.t * (Longident.t * type_expr) list + (** Type of a first-class module (a.k.a package). *) + +and fixed_explanation = + | Univar of type_expr (** The row type was bound to an univar *) + | Fixed_private (** The row type is private *) + | Reified of Path.t (** The row was reified *) + | Rigid (** The row type was made rigid during constraint verification *) + +(** [abbrev_memo] allows one to keep track of different expansions of a type + alias. This is done for performance purposes. + + For instance, when defining [type 'a pair = 'a * 'a], when one refers to an + ['a pair], it is just a shortcut for the ['a * 'a] type. + This expansion will be stored in the [abbrev_memo] of the corresponding + [Tconstr] node. + + In practice, [abbrev_memo] behaves like list of expansions with a mutable + tail. + + Note on marshalling: [abbrev_memo] must not appear in saved types. + [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and + removing abbreviations. +*) +and abbrev_memo = + | Mnil (** No known abbreviation *) + + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + (** Found one abbreviation. + A valid abbreviation should be at least as visible and reachable by the + same path. + The first expression is the abbreviation and the second the expansion. *) + + | Mlink of abbrev_memo ref + (** Abbreviations can be found after this indirection *) + +(** [commutable] is a flag appended to every arrow type. + + When typing an application, if the type of the functional is + known, its type is instantiated with [commu_ok] arrows, otherwise as + [commu_var ()]. + + When the type is not known, the application will be used to infer + the actual type. This is fragile in presence of labels where + there is no principal type. + + Two incompatible applications must rely on [is_commu_ok] arrows, + otherwise they will trigger an error. + + let f g = + g ~a:() ~b:(); + g ~b:() ~a:(); + + Error: This function is applied to arguments + in an order different from other calls. + This is only allowed when the real type is known. +*) + +val is_commu_ok: commutable -> bool +val commu_ok: commutable +val commu_var: unit -> commutable + +(** [field_kind] indicates the accessibility of a method. + + An [Fprivate] field may become [Fpublic] or [Fabsent] during unification, + but not the other way round. + + The same [field_kind] is kept shared when copying [Tfield] nodes + so that the copies of the self-type of a class share the same accessibility + (see also PR#10539). + *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +val field_kind_repr: field_kind -> field_kind_view +val field_public: field_kind +val field_absent: field_kind +val field_private: unit -> field_kind +val field_kind_internal_repr: field_kind -> field_kind + (* Removes indirections in [field_kind]. + Only needed for performance. *) + +(** Getters for type_expr; calls repr before answering a value *) + +val get_desc: type_expr -> type_desc +val get_level: type_expr -> int +val get_scope: type_expr -> int +val get_id: type_expr -> int + +(** Access to marks. They are stored in the scope field. *) +type type_mark +val with_type_mark: (type_mark -> 'a) -> 'a + (* run a computation using exclusively an available type mark *) + +val not_marked_node: type_mark -> type_expr -> bool + (* Return true if a type node is not yet marked *) + +val try_mark_node: type_mark -> type_expr -> bool + (* Mark a type node if it is not yet marked. + Marks will be automatically removed when leaving the + scope of [with_type_mark]. + + Return false if it was already marked *) + +(** Transient [type_expr]. + Should only be used immediately after [Transient_expr.repr] *) +type transient_expr = private + { mutable desc: type_desc; + mutable level: int; + mutable scope: scope_field; + id: int } +and scope_field (* abstract *) + +module Transient_expr : sig + (** Operations on [transient_expr] *) + + val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr + val get_scope: transient_expr -> int + val get_marks: transient_expr -> int + val set_desc: transient_expr -> type_desc -> unit + val set_level: transient_expr -> int -> unit + val set_scope: transient_expr -> int -> unit + val repr: type_expr -> transient_expr + val type_expr: transient_expr -> type_expr + val coerce: type_expr -> transient_expr + (** Coerce without normalizing with [repr] *) + + val set_stub_desc: type_expr -> type_desc -> unit + (** Instantiate a not yet instantiated stub. + Fail if already instantiated. *) + + val try_mark_node: type_mark -> transient_expr -> bool +end + +val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr + +(** Functions and definitions moved from Btype *) + +val proto_newty3: level:int -> scope:int -> type_desc -> transient_expr + (** Create a type with a fresh id *) + +module TransientTypeOps : sig + (** Comparisons for functors *) + + type t = transient_expr + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +module TransientTypeHash : Hashtbl.S with type key = transient_expr + +(** Comparisons for [type_expr]; cannot be used for functors *) + +val eq_type: type_expr -> type_expr -> bool +val compare_type: type_expr -> type_expr -> int + +(** Constructor and accessors for [row_desc] *) + +(** [ `X | `Y ] (row_closed = true) + [< `X | `Y ] (row_closed = true) + [> `X | `Y ] (row_closed = false) + [< `X | `Y > `X ] (row_closed = true) + + type t = [> `X ] as 'a (row_more = Tvar a) + type t = private [> `X ] (row_more = Tconstr ("t#row", [], ref Mnil)) + + And for: + + let f = function `X -> `X -> | `Y -> `X + + the type of "f" will be a [Tarrow] whose lhs will (basically) be: + + Tvariant { row_fields = [("X", _)]; + row_more = + Tvariant { row_fields = [("Y", _)]; + row_more = + Tvariant { row_fields = []; + row_more = _; + _ }; + _ }; + _ + } + +*) + +val create_row: + fields:(label * row_field) list -> + more:type_expr -> + closed:bool -> + fixed:fixed_explanation option -> + name:(Path.t * type_expr list) option -> row_desc + +val row_fields: row_desc -> (label * row_field) list +val row_more: row_desc -> type_expr +val row_closed: row_desc -> bool +val row_fixed: row_desc -> fixed_explanation option +val row_name: row_desc -> (Path.t * type_expr list) option + +val set_row_name: row_desc -> (Path.t * type_expr list) option -> row_desc + +val get_row_field: label -> row_desc -> row_field + +(** get all fields at once; different from the old [row_repr] *) +type row_desc_repr = + Row of { fields: (label * row_field) list; + more: type_expr; + closed: bool; + fixed: fixed_explanation option; + name: (Path.t * type_expr list) option } + +val row_repr: row_desc -> row_desc_repr + +(** Current contents of a row field *) +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +val row_field_repr: row_field -> row_field_view +val rf_present: type_expr option -> row_field +val rf_absent: row_field +val rf_either: + ?use_ext_of:row_field -> + no_arg:bool -> type_expr list -> matched:bool -> row_field +val rf_either_of: type_expr option -> row_field + +val eq_row_field_ext: row_field -> row_field -> bool +val changed_row_field_exts: row_field list -> (unit -> unit) -> bool + +type row_field_cell +val match_row_field: + present:(type_expr option -> 'a) -> + absent:(unit -> 'a) -> + either:(bool -> type_expr list -> bool -> + row_field_cell * row_field option ->'a) -> + row_field -> 'a + + +(* *) + +module Uid = Shape.Uid + +(* Sets and maps of methods and instance variables *) + +module MethSet : Set.S with type elt = string +module VarSet : Set.S with type elt = string + +module Meths : Map.S with type key = string +module Vars : Map.S with type key = string + +(* Value descriptions *) + +type value_description = + { val_type: type_expr; (* Type of the value *) + val_kind: value_kind; + val_loc: Location.t; + val_attributes: Parsetree.attributes; + val_uid: Uid.t; + } + +and value_kind = + Val_reg (* Regular value *) + | Val_prim of Primitive.description (* Primitive *) + | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) + | Val_self of class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + (* The [field_kind] is always [Fabsent] in a complete class type. *) + +(* Variance *) + +module Variance : sig + type t + type f = + May_pos (* allow positive occurrences *) + | May_neg (* allow negative occurrences *) + | May_weak (* allow occurrences under a negative position *) + | Inj (* type is injective in this parameter *) + | Pos (* there is a positive occurrence *) + | Neg (* there is a negative occurrence *) + | Inv (* both negative and positive occurrences *) + val null : t (* no occurrence *) + val full : t (* strictly invariant (all flags) *) + val covariant : t (* strictly covariant (May_pos, Pos and Inj) *) + val contravariant : t (* strictly contravariant *) + val unknown : t (* allow everything, guarantee nothing *) + val union : t -> t -> t + val inter : t -> t -> t + val subset : t -> t -> bool + val eq : t -> t -> bool + val set : f -> t -> t + val set_if : bool -> f -> t -> t + val mem : f -> t -> bool + val conjugate : t -> t (* exchange positive and negative *) + val compose : t -> t -> t + val strengthen : t -> t (* remove May_weak when possible *) + val get_upper : t -> bool * bool (* may_pos, may_neg *) + val get_lower : t -> bool * bool * bool (* pos, neg, inj *) + val unknown_signature : injective:bool -> arity:int -> t list + (** The most pessimistic variance for a completely unknown type. *) +end + +module Separability : sig + (** see {!Typedecl_separability} for an explanation of separability + and separability modes.*) + + type t = Ind | Sep | Deepsep + val eq : t -> t -> bool + val print : Format.formatter -> t -> unit + + val rank : t -> int + (** Modes are ordered from the least to the most demanding: + Ind < Sep < Deepsep. + 'rank' maps them to integers in an order-respecting way: + m1 < m2 <=> rank m1 < rank m2 *) + + val compare : t -> t -> int + (** Compare two mode according to their mode ordering. *) + + val max : t -> t -> t + (** [max_mode m1 m2] returns the most demanding mode. It is used to + express the conjunction of two parameter mode constraints. *) + + type signature = t list + (** The 'separability signature' of a type assigns a mode for + each of its parameters. [('a, 'b) t] has mode [(m1, m2)] if + [(t1, t2) t] is separable whenever [t1, t2] have mode [m1, m2]. *) + + val print_signature : Format.formatter -> signature -> unit + + val default_signature : arity:int -> signature + (** The most pessimistic separability for a completely unknown type. *) +end + +(* Type definitions *) + +type type_declaration = + { type_params: type_expr list; + type_arity: int; + type_kind: type_decl_kind; + type_private: private_flag; + type_manifest: type_expr option; + type_variance: Variance.t list; + (* covariant, contravariant, weakly contravariant, injective *) + type_separability: Separability.t list; + type_is_newtype: bool; + type_expansion_scope: int; + type_loc: Location.t; + type_attributes: Parsetree.attributes; + type_immediate: Type_immediacy.t; + type_unboxed_default: bool; + (* true if the unboxed-ness of this type was chosen by a compiler flag *) + type_uid: Uid.t; + } + +and type_decl_kind = (label_declaration, constructor_declaration) type_kind + +and ('lbl, 'cstr) type_kind = + Type_abstract of type_origin + | Type_record of 'lbl list * record_representation + | Type_variant of 'cstr list * variant_representation + | Type_open + +and type_origin = + Definition + | Rec_check_regularity (* See Typedecl.transl_type_decl *) + | Existential of string + +and record_representation = + Record_regular (* All fields are boxed / tagged *) + | Record_float (* All fields are floats *) + | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) + | Record_inlined of int (* Inlined record *) + | Record_extension of Path.t (* Inlined record under extension *) + (* The argument is the path of the extension *) + +and variant_representation = + Variant_regular (* Constant or boxed constructors *) + | Variant_unboxed (* One unboxed single-field constructor *) + +and label_declaration = + { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; + ld_uid: Uid.t; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_args: constructor_arguments; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; + cd_uid: Uid.t; + } + +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + +type extension_constructor = + { + ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + ext_uid: Uid.t; + } + +and type_transparence = + Type_public (* unrestricted expansion *) + | Type_new (* "new" type *) + | Type_private (* private type *) + +(* Type expressions for the class language *) + +type class_type = + Cty_constr of Path.t * type_expr list * class_type + | Cty_signature of class_signature + | Cty_arrow of arg_label * type_expr * class_type + +type class_declaration = + { cty_params: type_expr list; + mutable cty_type: class_type; + cty_path: Path.t; + cty_new: type_expr option; + cty_variance: Variance.t list; + cty_loc: Location.t; + cty_attributes: Parsetree.attributes; + cty_uid: Uid.t; + } + +type class_type_declaration = + { clty_params: type_expr list; + clty_type: class_type; + clty_path: Path.t; + clty_hash_type: type_declaration; (* object type with an open row *) + clty_variance: Variance.t list; + clty_loc: Location.t; + clty_attributes: Parsetree.attributes; + clty_uid: Uid.t; + } + +(* Type expressions for the module language *) + +type visibility = + | Exported + | Hidden + +type module_type = + Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of functor_parameter * module_type + | Mty_alias of Path.t + +and functor_parameter = + | Unit + | Named of Ident.t option * module_type + +and module_presence = + | Mp_present + | Mp_absent + +and signature = signature_item list + +and signature_item = + Sig_value of Ident.t * value_description * visibility + | Sig_type of Ident.t * type_declaration * rec_status * visibility + | Sig_typext of Ident.t * extension_constructor * ext_status * visibility + | Sig_module of + Ident.t * module_presence * module_declaration * rec_status * visibility + | Sig_modtype of Ident.t * modtype_declaration * visibility + | Sig_class of Ident.t * class_declaration * rec_status * visibility + | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility + +and module_declaration = + { + md_type: module_type; + md_attributes: Parsetree.attributes; + md_loc: Location.t; + md_uid: Uid.t; + } + +and modtype_declaration = + { + mtd_type: module_type option; (* None: abstract *) + mtd_attributes: Parsetree.attributes; + mtd_loc: Location.t; + mtd_uid: Uid.t; + } + +and rec_status = + Trec_not (* first in a nonrecursive group *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) + +and ext_status = + Text_first (* first constructor in an extension *) + | Text_next (* not first constructor in an extension *) + | Text_exception + +val item_visibility : signature_item -> visibility + +(* Constructor and record label descriptions inserted held in typing + environments *) + +type constructor_description = + { cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; + cstr_uid: Uid.t; + } + +and constructor_tag = + Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_unboxed (* Constructor of an unboxed type *) + | Cstr_extension of Path.t * bool (* Extension constructor + true if a constant false if a block*) + +(* Constructors are the same *) +val equal_tag : constructor_tag -> constructor_tag -> bool + +(* Constructors may be the same, given potential rebinding *) +val may_equal_constr : + constructor_description -> constructor_description -> bool + +type label_description = + { lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_pos: int; (* Position in block *) + lbl_all: label_description array; (* All the labels in this type *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +(** Extracts the list of "value" identifiers bound by a signature. + "Value" identifiers are identifiers for signature components that + correspond to a run-time value: values, extensions, modules, classes. + Note: manifest primitives do not correspond to a run-time value! *) +val bound_value_identifiers: signature -> Ident.t list + +val signature_item_id : signature_item -> Ident.t + +(**** Utilities for backtracking ****) + +type snapshot + (* A snapshot for backtracking *) +val snapshot: unit -> snapshot + (* Make a snapshot for later backtracking. Costs nothing *) +val backtrack: cleanup_abbrev:(unit -> unit) -> snapshot -> unit + (* Backtrack to a given snapshot. Only possible if you have + not already backtracked to a previous snapshot. + Calls [cleanup_abbrev] internally *) +val undo_first_change_after: snapshot -> unit + (* Backtrack only the first change after a snapshot. + Does not update the list of changes *) +val undo_compress: snapshot -> unit + (* Backtrack only path compression. Only meaningful if you have + not already backtracked to a previous snapshot. + Does not call [cleanup_abbrev] *) + +(** Functions to use when modifying a type (only Ctype?). + The old values are logged and reverted on backtracking. + *) + +val link_type: type_expr -> type_expr -> unit + (* Set the desc field of [t1] to [Tlink t2], logging the old + value if there is an active snapshot *) +val set_type_desc: type_expr -> type_desc -> unit + (* Set directly the desc field, without sharing *) +val set_level: type_expr -> int -> unit +val set_scope: type_expr -> int -> unit +val set_name: + (Path.t * type_expr list) option ref -> + (Path.t * type_expr list) option -> unit +val link_row_field_ext: inside:row_field -> row_field -> unit + (* Extract the extension variable of [inside] and set it to the + second argument *) +val set_univar: type_expr option ref -> type_expr -> unit +val link_kind: inside:field_kind -> field_kind -> unit +val link_commu: inside:commutable -> commutable -> unit +val set_commu_ok: commutable -> unit diff --git a/upstream/ocaml_503/typing/typetexp.ml b/upstream/ocaml_503/typing/typetexp.ml new file mode 100644 index 000000000..1ba0b14b4 --- /dev/null +++ b/upstream/ocaml_503/typing/typetexp.ml @@ -0,0 +1,972 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *) + +(* Typechecking of type expressions for the core language *) + +open Asttypes +open Misc +open Parsetree +open Typedtree +open Types +open Ctype + +exception Already_bound + +type error = + | Unbound_type_variable of string * string list + | No_type_wildcards + | Undefined_type_constructor of Path.t + | Type_arity_mismatch of Longident.t * int * int + | Bound_type_variable of string + | Recursive_type + | Type_mismatch of Errortrace.unification_error + | Alias_type_mismatch of Errortrace.unification_error + | Present_has_conjunction of string + | Present_has_no_type of string + | Constructor_mismatch of type_expr * type_expr + | Not_a_variant of type_expr + | Variant_tags of string * string + | Invalid_variable_name of string + | Cannot_quantify of string * type_expr + | Multiple_constraints_on_type of Longident.t + | Method_mismatch of string * type_expr * type_expr + | Opened_object of Path.t option + | Not_an_object of type_expr + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +module TyVarEnv : sig + val reset : unit -> unit + (* see mli file *) + + val is_in_scope : string -> bool + + val add : string -> type_expr -> unit + (* add a global type variable to the environment *) + + val with_local_scope : (unit -> 'a) -> 'a + (* see mli file *) + + type poly_univars + val with_univars : poly_univars -> (unit -> 'a) -> 'a + (* evaluate with a locally extended set of univars *) + + val make_poly_univars : string list -> poly_univars + (* see mli file *) + + val check_poly_univars : Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + type policy + val fixed_policy : policy (* no wildcards allowed *) + val extensible_policy : policy (* common case *) + val univars_policy : policy (* fresh variables are univars (in methods) *) + val new_any_var : Location.t -> Env.t -> policy -> type_expr + (* create a new variable to represent a _; fails for fixed_policy *) + val new_var : ?name:string -> policy -> type_expr + (* create a new variable according to the given policy *) + + val add_pre_univar : type_expr -> policy -> unit + (* remember that a variable might become a univar if it isn't unified; + used for checking method types *) + + val collect_univars : (unit -> 'a) -> 'a * type_expr list + (* collect univars during a computation; returns the univars. + The wrapped computation should use [univars_policy]. + postcondition: the returned type_exprs are all Tunivar *) + + val reset_locals : ?univars:poly_univars -> unit -> unit + (* clear out the local type variable env't; call this when starting + a new e.g. type signature. Optionally pass some univars that + are in scope. *) + + val lookup_local : + row_context:type_expr option ref list -> string -> type_expr + (* look up a local type variable; throws Not_found if it isn't in scope *) + + val remember_used : string -> type_expr -> Location.t -> unit + (* remember that a given name is bound to a given type *) + + val globalize_used_variables : policy -> Env.t -> unit -> unit + (* after finishing with a type signature, used variables are unified to the + corresponding global type variables if they exist. Otherwise, in function + of the policy, fresh used variables are either + - added to the global type variable scope if they are not longer + variables under the {!fixed_policy} + - added to the global type variable scope under the {!extensible_policy} + - expected to be collected later by a call to `collect_univar` under the + {!universal_policy} + *) + +end = struct + (** Map indexed by type variable names. *) + module TyVarMap = Misc.Stdlib.String.Map + + let not_generic v = get_level v <> Btype.generic_level + + (* These are the "global" type variables: they were in scope before + we started processing the current type. + *) + let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t) + + (* These are variables that have been used in the currently-being-checked + type. + *) + let used_variables = + ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t) + + (* These are variables we expect to become univars (they were introduced with + e.g. ['a .]), but we need to make sure they don't unify first. Why not + just birth them as univars? Because they might successfully unify with a + row variable in the ['a. < m : ty; .. > as 'a] idiom. They are like the + [used_variables], but will not be globalized in [globalize_used_variables]. + *) + type pending_univar = { + univar: type_expr (** the univar itself *); + mutable associated: type_expr option ref list + (** associated references to row variables that we want to generalize + if possible *) + } + + let univars = ref ([] : (string * pending_univar) list) + let assert_univars uvs = + assert (List.for_all (fun (_name, v) -> not_generic v.univar) uvs) + + (* These are variables that will become univars when we're done with the + current type. Used to force free variables in method types to become + univars. + *) + let pre_univars = ref ([] : type_expr list) + + let reset () = + reset_global_level (); + type_variables := TyVarMap.empty + + let is_in_scope name = + TyVarMap.mem name !type_variables + + let add name v = + assert (not_generic v); + type_variables := TyVarMap.add name v !type_variables + + let narrow () = + (increase_global_level (), !type_variables) + + let widen (gl, tv) = + restore_global_level gl; + type_variables := tv + + let with_local_scope f = + let context = narrow () in + Fun.protect + f + ~finally:(fun () -> widen context) + + (* throws Not_found if the variable is not in scope *) + let lookup_global_type_variable name = + TyVarMap.find name !type_variables + + let get_in_scope_names () = + let add_name name _ l = + if name = "_" then l else Pprintast.tyvar_of_name name :: l + in + TyVarMap.fold add_name !type_variables [] + + (*****) + type poly_univars = (string * pending_univar) list + + let with_univars new_ones f = + assert_univars new_ones; + let old_univars = !univars in + univars := new_ones @ !univars; + Fun.protect + f + ~finally:(fun () -> univars := old_univars) + + let make_poly_univars vars = + let make name = { univar=newvar ~name (); associated = [] } in + List.map (fun name -> name, make name ) vars + + let promote_generics_to_univars promoted vars = + List.fold_left + (fun acc v -> + match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name); + v :: acc + | _ -> acc + ) + promoted vars + + let check_poly_univars env loc vars = + let univars = + vars |> List.map (fun (name, {univar=ty1; _ }) -> + let v = Btype.proxy ty1 in + begin match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name) + | _ -> + raise (Error (loc, env, Cannot_quantify(name, v))) + end; + v) + in + (* Since we are promoting variables to univars in + {!promote_generics_to_univars}, even if a row variable is associated with + multiple univars we will promote it once, when checking the nearest + univar associated to this row variable. + *) + let promote_associated acc (_,v) = + let enclosed_rows = List.filter_map (!) v.associated in + promote_generics_to_univars acc enclosed_rows + in + List.fold_left promote_associated univars vars + + let instance_poly_univars env loc vars = + let vs = check_poly_univars env loc vars in + vs |> List.iter (fun v -> + match get_desc v with + | Tunivar name -> + set_type_desc v (Tvar name) + | _ -> assert false); + vs + + (*****) + let reset_locals ?univars:(uvs=[]) () = + assert_univars uvs; + univars := uvs; + used_variables := TyVarMap.empty + + let associate row_context p = + let add l x = if List.memq x l then l else x :: l in + p.associated <- List.fold_left add row_context p.associated + + (* throws Not_found if the variable is not in scope *) + let lookup_local ~row_context name = + try + let p = List.assoc name !univars in + associate row_context p; + p.univar + with Not_found -> + instance (fst (TyVarMap.find name !used_variables)) + (* This call to instance might be redundant; all variables + inserted into [used_variables] are non-generic, but some + might get generalized. *) + + let remember_used name v loc = + assert (not_generic v); + used_variables := TyVarMap.add name (v, loc) !used_variables + + + type flavor = Unification | Universal + type extensibility = Extensible | Fixed + type policy = { flavor : flavor; extensibility : extensibility } + + let fixed_policy = { flavor = Unification; extensibility = Fixed } + let extensible_policy = { flavor = Unification; extensibility = Extensible } + let univars_policy = { flavor = Universal; extensibility = Extensible } + + let add_pre_univar tv = function + | { flavor = Universal } -> + assert (not_generic tv); + pre_univars := tv :: !pre_univars + | _ -> () + + let collect_univars f = + pre_univars := []; + let result = f () in + let univs = promote_generics_to_univars [] !pre_univars in + result, univs + + let new_var ?name policy = + let tv = Ctype.newvar ?name () in + add_pre_univar tv policy; + tv + + let new_any_var loc env = function + | { extensibility = Fixed } -> raise(Error(loc, env, No_type_wildcards)) + | policy -> new_var policy + + let globalize_used_variables { flavor; extensibility } env = + let r = ref [] in + TyVarMap.iter + (fun name (ty, loc) -> + if flavor = Unification || is_in_scope name then + let v = new_global_var () in + let snap = Btype.snapshot () in + if try unify env v ty; true with _ -> Btype.backtrack snap; false + then try + r := (loc, v, lookup_global_type_variable name) :: !r + with Not_found -> + if extensibility = Fixed && Btype.is_Tvar ty then + raise(Error(loc, env, + Unbound_type_variable (Pprintast.tyvar_of_name name, + get_in_scope_names ()))); + let v2 = new_global_var () in + r := (loc, v, v2) :: !r; + add name v2) + !used_variables; + used_variables := TyVarMap.empty; + fun () -> + List.iter + (function (loc, t1, t2) -> + try unify env t1 t2 with Unify err -> + raise (Error(loc, env, Type_mismatch err))) + !r +end + +(* Support for first-class modules. *) + +let transl_modtype_longident = ref (fun _ -> assert false) +let transl_modtype = ref (fun _ -> assert false) +let check_package_with_type_constraints = ref (fun _ -> assert false) + +let sort_constraints_no_duplicates loc env l = + List.sort + (fun (s1, _t1) (s2, _t2) -> + if s1.txt = s2.txt then + raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); + compare s1.txt s2.txt) + l + +(* Translation of type expressions *) + +let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') + +let validate_name = function + None -> None + | Some name as s -> + if name <> "" && strict_ident name.[0] then s else None + +let new_global_var ?name () = + new_global_var ?name:(validate_name name) () +let newvar ?name () = + newvar ?name:(validate_name name) () + +let valid_tyvar_name name = + name <> "" && name.[0] <> '_' + +let transl_type_param env styp = + let loc = styp.ptyp_loc in + match styp.ptyp_desc with + Ptyp_any -> + let ty = new_global_var ~name:"_" () in + { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env; + ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } + | Ptyp_var name -> + let ty = + if not (valid_tyvar_name name) then + raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + if TyVarEnv.is_in_scope name then + raise Already_bound; + let v = new_global_var ~name () in + TyVarEnv.add name v; + v + in + { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env; + ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } + | _ -> assert false + +let transl_type_param env styp = + (* Currently useless, since type parameters cannot hold attributes + (but this could easily be lifted in the future). *) + Builtin_attributes.warning_scope styp.ptyp_attributes + (fun () -> transl_type_param env styp) + +(* Forward declaration (set in Typemod.type_open) *) + +let type_open : + (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> + Longident.t loc -> Path.t * Env.t) + ref = + ref (fun ?used_slot:_ _ -> assert false) + +let rec transl_type env ~policy ?(aliased=false) ~row_context styp = + Builtin_attributes.warning_scope styp.ptyp_attributes + (fun () -> transl_type_aux env ~policy ~aliased ~row_context styp) + +and transl_type_aux env ~row_context ~aliased ~policy styp = + let loc = styp.ptyp_loc in + let ctyp ctyp_desc ctyp_type = + { ctyp_desc; ctyp_type; ctyp_env = env; + ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes } + in + match styp.ptyp_desc with + Ptyp_any -> + let ty = TyVarEnv.new_any_var styp.ptyp_loc env policy in + ctyp Ttyp_any ty + | Ptyp_var name -> + let ty = + if not (valid_tyvar_name name) then + raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); + begin try + TyVarEnv.lookup_local ~row_context:row_context name + with Not_found -> + let v = TyVarEnv.new_var ~name policy in + TyVarEnv.remember_used name v styp.ptyp_loc; + v + end + in + ctyp (Ttyp_var name) ty + | Ptyp_arrow(l, st1, st2) -> + let cty1 = transl_type env ~policy ~row_context st1 in + let cty2 = transl_type env ~policy ~row_context st2 in + let ty1 = cty1.ctyp_type in + let ty1 = + if Btype.is_optional l + then newty (Tconstr(Predef.path_option,[ty1], ref Mnil)) + else ty1 in + let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, commu_ok)) in + ctyp (Ttyp_arrow (l, cty1, cty2)) ty + | Ptyp_tuple stl -> + assert (List.length stl >= 2); + let ctys = List.map (transl_type env ~policy ~row_context) stl in + let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in + ctyp (Ttyp_tuple ctys) ty + | Ptyp_constr(lid, stl) -> + let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in + let stl = + match stl with + | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 -> + List.map (fun _ -> t) decl.type_params + | _ -> stl + in + if List.length stl <> decl.type_arity then + raise(Error(styp.ptyp_loc, env, + Type_arity_mismatch(lid.txt, decl.type_arity, + List.length stl))); + let args = List.map (transl_type env ~policy ~row_context) stl in + let params = instance_list decl.type_params in + let unify_param = + match decl.type_manifest with + None -> unify_var + | Some ty -> + if get_level ty = Btype.generic_level then unify_var else unify + in + List.iter2 + (fun (sty, cty) ty' -> + try unify_param env ty' cty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (List.combine stl args) params; + let constr = + newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in + ctyp (Ttyp_constr (path, lid, args)) constr + | Ptyp_object (fields, o) -> + let ty, fields = transl_fields env ~policy ~row_context o fields in + ctyp (Ttyp_object (fields, o)) (newobj ty) + | Ptyp_class(lid, stl) -> + let (path, decl) = + let path, decl = Env.lookup_cltype ~loc:lid.loc lid.txt env in + (path, decl.clty_hash_type) + in + if List.length stl <> decl.type_arity then + raise(Error(styp.ptyp_loc, env, + Type_arity_mismatch(lid.txt, decl.type_arity, + List.length stl))); + let args = List.map (transl_type env ~policy ~row_context) stl in + let body = Option.get decl.type_manifest in + let (params, body) = instance_parameterized_type decl.type_params body in + List.iter2 + (fun (sty, cty) ty' -> + try unify_var env ty' cty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (List.combine stl args) params; + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in + let ty = Ctype.apply ~use_current_level:true env params body ty_args in + let ty = match get_desc ty with + | Tobject (fi, _) -> + let _, tv = flatten_fields fi in + TyVarEnv.add_pre_univar tv policy; + ty + | _ -> + assert false + in + ctyp (Ttyp_class (path, lid, args)) ty + | Ptyp_alias(st, alias) -> + let cty = + try + let t = TyVarEnv.lookup_local ~row_context alias.txt in + let ty = transl_type env ~policy ~aliased:true ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(alias.loc, env, Alias_type_mismatch err)) + end; + ty + with Not_found -> + let t, ty = + with_local_level_generalize_structure_if_principal begin fun () -> + let t = newvar () in + (* Use the whole location, which is used by [Type_mismatch]. *) + TyVarEnv.remember_used alias.txt t styp.ptyp_loc; + let ty = transl_type env ~policy ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(alias.loc, env, Alias_type_mismatch err)) + end; + (t, ty) + end + in + let t = instance t in + let px = Btype.proxy t in + begin match get_desc px with + | Tvar None -> set_type_desc px (Tvar (Some alias.txt)) + | Tunivar None -> set_type_desc px (Tunivar (Some alias.txt)) + | _ -> () + end; + { ty with ctyp_type = t } + in + ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type + | Ptyp_variant(fields, closed, present) -> + let name = ref None in + let mkfield l f = + newty (Tvariant (create_row ~fields:[l,f] ~more:(newvar()) + ~closed:true ~fixed:None ~name:None)) in + let hfields = Hashtbl.create 17 in + let add_typed_field loc l f = + let h = Btype.hash_variant l in + try + let (l',f') = Hashtbl.find hfields h in + (* Check for tag conflicts *) + if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); + let ty = mkfield l f and ty' = mkfield l f' in + if is_equal env false [ty] [ty'] then () else + try unify env ty ty' + with Unify _trace -> + raise(Error(loc, env, Constructor_mismatch (ty,ty'))) + with Not_found -> + Hashtbl.add hfields h (l,f) + in + let add_field row_context field = + let rf_loc = field.prf_loc in + let rf_attributes = field.prf_attributes in + let rf_desc = match field.prf_desc with + | Rtag (l, c, stl) -> + name := None; + let tl = + Builtin_attributes.warning_scope rf_attributes + (fun () -> List.map (transl_type env ~policy ~row_context) stl) + in + let f = match present with + Some present when not (List.mem l.txt present) -> + let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in + rf_either ty_tl ~no_arg:c ~matched:false + | _ -> + if List.length stl > 1 || c && stl <> [] then + raise(Error(styp.ptyp_loc, env, + Present_has_conjunction l.txt)); + match tl with [] -> rf_present None + | st :: _ -> rf_present (Some st.ctyp_type) + in + add_typed_field styp.ptyp_loc l.txt f; + Ttag (l,c,tl) + | Rinherit sty -> + let cty = transl_type env ~policy ~row_context sty in + let ty = cty.ctyp_type in + let nm = + match get_desc cty.ctyp_type with + Tconstr(p, tl, _) -> Some(p, tl) + | _ -> None + in + name := if Hashtbl.length hfields <> 0 then None else nm; + let fl = match get_desc (expand_head env cty.ctyp_type), nm with + Tvariant row, _ when Btype.static_row row -> + row_fields row + | Tvar _, Some(p, _) -> + raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p)) + | _ -> + raise(Error(sty.ptyp_loc, env, Not_a_variant ty)) + in + List.iter + (fun (l, f) -> + let f = match present with + Some present when not (List.mem l present) -> + begin match row_field_repr f with + Rpresent oty -> rf_either_of oty + | _ -> assert false + end + | _ -> f + in + add_typed_field sty.ptyp_loc l f) + fl; + Tinherit cty + in + { rf_desc; rf_loc; rf_attributes; } + in + let more_slot = ref None in + let row_context = + if aliased then row_context else more_slot :: row_context + in + let tfields = List.map (add_field row_context) fields in + let fields = List.rev (Hashtbl.fold (fun _ p l -> p :: l) hfields []) in + begin match present with None -> () + | Some present -> + List.iter + (fun l -> if not (List.mem_assoc l fields) then + raise(Error(styp.ptyp_loc, env, Present_has_no_type l))) + present + end; + let name = !name in + let make_row more = + create_row ~fields ~more ~closed:(closed = Closed) ~fixed:None ~name + in + let more = + if Btype.static_row (make_row (newvar ())) then newty Tnil else + TyVarEnv.new_var policy + in + more_slot := Some more; + let ty = newty (Tvariant (make_row more)) in + ctyp (Ttyp_variant (tfields, closed, present)) ty + | Ptyp_poly(vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let new_univars, cty = + with_local_level_generalize begin fun () -> + let new_univars = TyVarEnv.make_poly_univars vars in + let cty = TyVarEnv.with_univars new_univars begin fun () -> + transl_type env ~policy ~row_context st + end in + (new_univars, cty) + end + in + let ty = cty.ctyp_type in + let ty_list = TyVarEnv.check_poly_univars env styp.ptyp_loc new_univars in + let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in + let ty' = Btype.newgenty (Tpoly(ty, ty_list)) in + unify_var env (newvar()) ty'; + ctyp (Ttyp_poly (vars, cty)) ty' + | Ptyp_package (p, l) -> + let loc = styp.ptyp_loc in + let l = sort_constraints_no_duplicates loc env l in + let mty = Ast_helper.Mty.mk ~loc (Pmty_ident p) in + let mty = TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in + let ptys = + List.map (fun (s, pty) -> s, transl_type env ~policy ~row_context pty) l + in + let mty = + if ptys <> [] then + !check_package_with_type_constraints loc env mty.mty_type ptys + else mty.mty_type + in + let path = !transl_modtype_longident loc env p.txt in + let ty = newty (Tpackage (path, + List.map (fun (s, cty) -> (s.txt, cty.ctyp_type)) ptys)) + in + ctyp (Ttyp_package { + pack_path = path; + pack_type = mty; + pack_fields = ptys; + pack_txt = p; + }) ty + | Ptyp_open (mod_ident, t) -> + let path, new_env = + !type_open Asttypes.Fresh env loc mod_ident + in + let cty = transl_type new_env ~policy ~row_context t in + ctyp (Ttyp_open (path, mod_ident, cty)) cty.ctyp_type + | Ptyp_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and transl_fields env ~policy ~row_context o fields = + let hfields = Hashtbl.create 17 in + let add_typed_field loc l ty = + try + let ty' = Hashtbl.find hfields l in + if is_equal env false [ty] [ty'] then () else + try unify env ty ty' + with Unify _trace -> + raise(Error(loc, env, Method_mismatch (l, ty, ty'))) + with Not_found -> + Hashtbl.add hfields l ty in + let add_field {pof_desc; pof_loc; pof_attributes;} = + let of_loc = pof_loc in + let of_attributes = pof_attributes in + let of_desc = match pof_desc with + | Otag (s, ty1) -> begin + let ty1 = + Builtin_attributes.warning_scope of_attributes + (fun () -> transl_type env ~policy ~row_context + (Ast_helper.Typ.force_poly ty1)) + in + let field = OTtag (s, ty1) in + add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type; + field + end + | Oinherit sty -> begin + let cty = transl_type env ~policy ~row_context sty in + let nm = + match get_desc cty.ctyp_type with + Tconstr(p, _, _) -> Some p + | _ -> None in + let t = expand_head env cty.ctyp_type in + match get_desc t, nm with + Tobject (tf, _), _ + when (match get_desc tf with Tfield _ | Tnil -> true | _ -> false) -> + begin + if opened_object t then + raise (Error (sty.ptyp_loc, env, Opened_object nm)); + let rec iter_add ty = + match get_desc ty with + | Tfield (s, _k, ty1, ty2) -> + add_typed_field sty.ptyp_loc s ty1; + iter_add ty2 + | Tnil -> () + | _ -> assert false + in + iter_add tf; + OTinherit cty + end + | Tvar _, Some p -> + raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p)) + | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t)) + end in + { of_desc; of_loc; of_attributes; } + in + let object_fields = List.map add_field fields in + let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in + let ty_init = + match o with + | Closed -> newty Tnil + | Open -> TyVarEnv.new_var policy + in + let ty = List.fold_left (fun ty (s, ty') -> + newty (Tfield (s, field_public, ty', ty))) ty_init fields in + ty, object_fields + + +(* Make the rows "fixed" in this type, to make universal check easier *) +let rec make_fixed_univars mark ty = + if try_mark_node mark ty then + begin match get_desc ty with + | Tvariant row -> + let Row {fields; more; name; closed} = row_repr row in + if Btype.is_Tunivar more then + let fields = + List.map + (fun (s,f as p) -> match row_field_repr f with + Reither (no_arg, tl, _m) -> + s, rf_either tl ~use_ext_of:f ~no_arg ~matched:true + | _ -> p) + fields + in + set_type_desc ty + (Tvariant + (create_row ~fields ~more ~name ~closed + ~fixed:(Some (Univar more)))); + Btype.iter_row (make_fixed_univars mark) row + | _ -> + Btype.iter_type_expr (make_fixed_univars mark) ty + end + +let make_fixed_univars ty = + with_type_mark (fun mark -> make_fixed_univars mark ty) + +let transl_type env policy styp = + transl_type env ~policy ~row_context:[] styp + +let transl_simple_type env ?univars ~closed styp = + TyVarEnv.reset_locals ?univars (); + let policy = TyVarEnv.(if closed then fixed_policy else extensible_policy) in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + make_fixed_univars typ.ctyp_type; + typ + +let transl_simple_type_univars env styp = + TyVarEnv.reset_locals (); + let typ, univs = + TyVarEnv.collect_univars begin fun () -> + with_local_level_generalize begin fun () -> + let policy = TyVarEnv.univars_policy in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + typ + end + end in + make_fixed_univars typ.ctyp_type; + { typ with ctyp_type = + instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } + +let transl_simple_type_delayed env styp = + TyVarEnv.reset_locals (); + let typ, force = + with_local_level_generalize begin fun () -> + let policy = TyVarEnv.extensible_policy in + let typ = transl_type env policy styp in + make_fixed_univars typ.ctyp_type; + (* This brings the used variables to the global level, but doesn't link + them to their other occurrences just yet. This will be done when + [force] is called. *) + let force = TyVarEnv.globalize_used_variables policy env in + (typ, force) + end + in + (typ, instance typ.ctyp_type, force) + +let transl_type_scheme env styp = + match styp.ptyp_desc with + | Ptyp_poly (vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let univars, typ = + with_local_level_generalize begin fun () -> + TyVarEnv.reset (); + let univars = TyVarEnv.make_poly_univars vars in + let typ = transl_simple_type env ~univars ~closed:true st in + (univars, typ) + end + in + let _ = TyVarEnv.instance_poly_univars env styp.ptyp_loc univars in + { ctyp_desc = Ttyp_poly (vars, typ); + ctyp_type = typ.ctyp_type; + ctyp_env = env; + ctyp_loc = styp.ptyp_loc; + ctyp_attributes = styp.ptyp_attributes } + | _ -> + with_local_level_generalize + (fun () -> TyVarEnv.reset (); transl_simple_type env ~closed:false styp) + + +(* Error report *) + +open Format_doc +open Printtyp.Doc +module Style = Misc.Style +let pp_tag ppf t = fprintf ppf "`%s" t +let pp_out_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty +let pp_type ppf ty = Style.as_inline_code Printtyp.Doc.type_expr ppf ty + +let report_error_doc env ppf = function + | Unbound_type_variable (name, in_scope_names) -> + fprintf ppf "The type variable %a is unbound in this type declaration.@ %a" + Style.inline_code name + did_you_mean (fun () -> Misc.spellcheck in_scope_names name ) + | No_type_wildcards -> + fprintf ppf "A type wildcard %a is not allowed in this type declaration." + Style.inline_code "_" + | Undefined_type_constructor p -> + fprintf ppf "The type constructor@ %a@ is not yet completely defined" + (Style.as_inline_code path) p + | Type_arity_mismatch(lid, expected, provided) -> + fprintf ppf + "@[The type constructor %a@ expects %i argument(s),@ \ + but is here applied to %i argument(s)@]" + (Style.as_inline_code longident) lid expected provided + | Bound_type_variable name -> + fprintf ppf "Already bound type parameter %a" + (Style.as_inline_code Pprintast.Doc.tyvar) name + | Recursive_type -> + fprintf ppf "This type is recursive" + | Type_mismatch trace -> + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf Env.empty trace + (msg "This type") + (msg "should be an instance of type") + | Alias_type_mismatch trace -> + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf Env.empty trace + (msg "This alias is bound to type") + (msg "but is used as an instance of type") + | Present_has_conjunction l -> + fprintf ppf "The present constructor %a has a conjunctive type" + Style.inline_code l + | Present_has_no_type l -> + fprintf ppf + "@[@[The constructor %a is missing from the upper bound@ \ + (between %a@ and %a)@ of this polymorphic variant@ \ + but is present in@ its lower bound (after %a).@]@,\ + @[@{Hint@}: Either add %a in the upper bound,@ \ + or remove it@ from the lower bound.@]@]" + (Style.as_inline_code pp_tag) l + Style.inline_code "<" + Style.inline_code ">" + Style.inline_code ">" + (Style.as_inline_code pp_tag) l + | Constructor_mismatch (ty, ty') -> + wrap_printing_env ~error:true env (fun () -> + Out_type.prepare_for_printing [ty; ty']; + fprintf ppf "@[%s %a@ %s@ %a@]" + "This variant type contains a constructor" + pp_out_type (Out_type.tree_of_typexp Type ty) + "which should be" + pp_out_type (Out_type.tree_of_typexp Type ty')) + | Not_a_variant ty -> + fprintf ppf + "@[The type %a@ does not expand to a polymorphic variant type@]" + pp_type ty; + begin match get_desc ty with + | Tvar (Some s) -> + (* PR#7012: help the user that wrote 'Foo instead of `Foo *) + Misc.did_you_mean ppf (fun () -> ["`" ^ s]) + | _ -> () + end + | Variant_tags (lab1, lab2) -> + fprintf ppf + "@[Variant tags %a@ and %a have the same hash value.@ %s@]" + (Style.as_inline_code pp_tag) lab1 + (Style.as_inline_code pp_tag) lab2 + "Change one of them." + | Invalid_variable_name name -> + fprintf ppf "The type variable name %a is not allowed in programs" + Style.inline_code name + | Cannot_quantify (name, v) -> + fprintf ppf + "@[The universal type variable %a cannot be generalized:@ " + (Style.as_inline_code Pprintast.Doc.tyvar) name; + if Btype.is_Tvar v then + fprintf ppf "it escapes its scope" + else if Btype.is_Tunivar v then + fprintf ppf "it is already bound to another variable" + else + fprintf ppf "it is bound to@ %a" pp_type v; + fprintf ppf ".@]"; + | Multiple_constraints_on_type s -> + fprintf ppf "Multiple constraints for type %a" + (Style.as_inline_code longident) s + | Method_mismatch (l, ty, ty') -> + wrap_printing_env ~error:true env (fun () -> + fprintf ppf "@[Method %a has type %a,@ which should be %a@]" + Style.inline_code l + pp_type ty + pp_type ty') + | Opened_object nm -> + fprintf ppf + "Illegal open object type%a" + (fun ppf -> function + Some p -> fprintf ppf "@ %a" (Style.as_inline_code path) p + | None -> fprintf ppf "") nm + | Not_an_object ty -> + fprintf ppf "@[The type %a@ is not an object type@]" + pp_type ty + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (Location.error_of_printer ~loc (report_error_doc env) err) + | Error_forward err -> + Some err + | _ -> + None + ) + +let report_error env = Format_doc.compat (report_error_doc env) diff --git a/upstream/ocaml_503/typing/typetexp.mli b/upstream/ocaml_503/typing/typetexp.mli new file mode 100644 index 000000000..bd03489f3 --- /dev/null +++ b/upstream/ocaml_503/typing/typetexp.mli @@ -0,0 +1,109 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Typechecking of type expressions for the core language *) + +open Types + +module TyVarEnv : sig + (* this is just the subset of [TyVarEnv] that is needed outside + of [Typetexp]. See the ml file for more. *) + + val reset : unit -> unit + (** removes all type variables from scope *) + + val with_local_scope : (unit -> 'a) -> 'a + (** Evaluate in a narrowed type-variable scope *) + + type poly_univars + val make_poly_univars : string list -> poly_univars + (** remember that a list of strings connotes univars; this must + always be paired with a [check_poly_univars]. *) + + val check_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Verify that the given univars are universally quantified, + and return the list of variables. The type in which the + univars are used must be generalised *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Same as [check_poly_univars], but instantiates the resulting + type scheme (i.e. variables become Tvar rather than Tunivar) *) + +end + +(* Forward declaration, to be filled in by Typemod.type_open *) +val type_open: + (?used_slot:bool ref -> Asttypes.override_flag -> Env.t -> Location.t -> + Longident.t Asttypes.loc -> Path.t * Env.t) + ref + +val valid_tyvar_name : string -> bool + +val transl_simple_type: + Env.t -> ?univars:TyVarEnv.poly_univars -> closed:bool + -> Parsetree.core_type -> Typedtree.core_type +val transl_simple_type_univars: + Env.t -> Parsetree.core_type -> Typedtree.core_type +val transl_simple_type_delayed + : Env.t + -> Parsetree.core_type + -> Typedtree.core_type * type_expr * (unit -> unit) + (* Translate a type, but leave type variables unbound. Returns + the type, an instance of the corresponding type_expr, and a + function that binds the type variable. *) +val transl_type_scheme: + Env.t -> Parsetree.core_type -> Typedtree.core_type +val transl_type_param: + Env.t -> Parsetree.core_type -> Typedtree.core_type + +exception Already_bound + +type error = + | Unbound_type_variable of string * string list + | No_type_wildcards + | Undefined_type_constructor of Path.t + | Type_arity_mismatch of Longident.t * int * int + | Bound_type_variable of string + | Recursive_type + | Type_mismatch of Errortrace.unification_error + | Alias_type_mismatch of Errortrace.unification_error + | Present_has_conjunction of string + | Present_has_no_type of string + | Constructor_mismatch of type_expr * type_expr + | Not_a_variant of type_expr + | Variant_tags of string * string + | Invalid_variable_name of string + | Cannot_quantify of string * type_expr + | Multiple_constraints_on_type of Longident.t + | Method_mismatch of string * type_expr * type_expr + | Opened_object of Path.t option + | Not_an_object of type_expr + +exception Error of Location.t * Env.t * error + +val report_error: Env.t -> error Format_doc.format_printer +val report_error_doc: Env.t -> error Format_doc.printer + +(* Support for first-class modules. *) +val transl_modtype_longident: (* from Typemod *) + (Location.t -> Env.t -> Longident.t -> Path.t) ref +val transl_modtype: (* from Typemod *) + (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref +val check_package_with_type_constraints: (* from Typemod *) + (Location.t -> Env.t -> Types.module_type -> + (Longident.t Asttypes.loc * Typedtree.core_type) list -> + Types.module_type) ref diff --git a/upstream/ocaml_503/typing/untypeast.ml b/upstream/ocaml_503/typing/untypeast.ml new file mode 100644 index 000000000..07e4e8643 --- /dev/null +++ b/upstream/ocaml_503/typing/untypeast.ml @@ -0,0 +1,965 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + +open Asttypes +open Parsetree +open Ast_helper + +module T = Typedtree + +type mapper = { + attribute: mapper -> T.attribute -> attribute; + attributes: mapper -> T.attribute list -> attribute list; + binding_op: mapper -> T.binding_op -> T.pattern -> binding_op; + case: 'k . mapper -> 'k T.case -> case; + class_declaration: mapper -> T.class_declaration -> class_declaration; + class_description: mapper -> T.class_description -> class_description; + class_expr: mapper -> T.class_expr -> class_expr; + class_field: mapper -> T.class_field -> class_field; + class_signature: mapper -> T.class_signature -> class_signature; + class_structure: mapper -> T.class_structure -> class_structure; + class_type: mapper -> T.class_type -> class_type; + class_type_declaration: mapper -> T.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> T.class_type_field -> class_type_field; + constructor_declaration: mapper -> T.constructor_declaration + -> constructor_declaration; + expr: mapper -> T.expression -> expression; + extension_constructor: mapper -> T.extension_constructor + -> extension_constructor; + include_declaration: mapper -> T.include_declaration -> include_declaration; + include_description: mapper -> T.include_description -> include_description; + label_declaration: mapper -> T.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> T.module_binding -> module_binding; + module_declaration: mapper -> T.module_declaration -> module_declaration; + module_substitution: mapper -> T.module_substitution -> module_substitution; + module_expr: mapper -> T.module_expr -> module_expr; + module_type: mapper -> T.module_type -> module_type; + module_type_declaration: + mapper -> T.module_type_declaration -> module_type_declaration; + package_type: mapper -> T.package_type -> package_type; + open_declaration: mapper -> T.open_declaration -> open_declaration; + open_description: mapper -> T.open_description -> open_description; + pat: 'k . mapper -> 'k T.general_pattern -> pattern; + row_field: mapper -> T.row_field -> row_field; + object_field: mapper -> T.object_field -> object_field; + signature: mapper -> T.signature -> signature; + signature_item: mapper -> T.signature_item -> signature_item; + structure: mapper -> T.structure -> structure; + structure_item: mapper -> T.structure_item -> structure_item; + typ: mapper -> T.core_type -> core_type; + type_declaration: mapper -> T.type_declaration -> type_declaration; + type_extension: mapper -> T.type_extension -> type_extension; + type_exception: mapper -> T.type_exception -> type_exception; + type_kind: mapper -> T.type_kind -> type_kind; + value_binding: mapper -> T.value_binding -> value_binding; + value_description: mapper -> T.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * T.with_constraint) + -> with_constraint; +} + +open T + +(* +Some notes: + + * For Pexp_apply, it is unclear whether arguments are reordered, especially + when there are optional arguments. + +*) + + +(** Utility functions. *) + +let string_is_prefix sub str = + let sublen = String.length sub in + String.length str >= sublen && String.sub str 0 sublen = sub + +let rec lident_of_path = function + | Path.Pident id -> Longident.Lident (Ident.name id) + | Path.Papply (p1, p2) -> + Longident.Lapply (lident_of_path p1, lident_of_path p2) + | Path.Pdot (p, s) | Path.Pextra_ty (p, Pcstr_ty s) -> + Longident.Ldot (lident_of_path p, s) + | Path.Pextra_ty (p, _) -> lident_of_path p + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +(** Extract the [n] patterns from the case of a letop *) +let rec extract_letop_patterns n pat = + if n = 0 then pat, [] + else begin + match pat.pat_desc with + | Tpat_tuple([first; rest]) -> + let next, others = extract_letop_patterns (n-1) rest in + first, next :: others + | _ -> + let rec anys n = + if n = 0 then [] + else { pat with pat_desc = Tpat_any } :: anys (n-1) + in + { pat with pat_desc = Tpat_any }, anys (n-1) + end + +(** Mapping functions. *) + +let constant = function + | Const_char c -> Const.char c + | Const_string (s,loc,d) -> Const.string ?quotation_delimiter:d ~loc s + | Const_int i -> Const.integer (Int.to_string i) + | Const_int32 i -> Const.integer ~suffix:'l' (Int32.to_string i) + | Const_int64 i -> Const.integer ~suffix:'L' (Int64.to_string i) + | Const_nativeint i -> Const.integer ~suffix:'n' (Nativeint.to_string i) + | Const_float f -> Const.float f + +let attribute sub a = { + attr_name = map_loc sub a.attr_name; + attr_payload = a.attr_payload; + attr_loc = a.attr_loc + } + +let attributes sub l = List.map (sub.attribute sub) l + +let structure sub str = + List.map (sub.structure_item sub) str.str_items + +let open_description sub od = + let loc = sub.location sub od.open_loc in + let attrs = sub.attributes sub od.open_attributes in + Opn.mk ~loc ~attrs + ~override:od.open_override + (snd od.open_expr) + +let open_declaration sub od = + let loc = sub.location sub od.open_loc in + let attrs = sub.attributes sub od.open_attributes in + Opn.mk ~loc ~attrs + ~override:od.open_override + (sub.module_expr sub od.open_expr) + +let structure_item sub item = + let loc = sub.location sub item.str_loc in + let desc = + match item.str_desc with + Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) + | Tstr_value (rec_flag, list) -> + Pstr_value (rec_flag, List.map (sub.value_binding sub) list) + | Tstr_primitive vd -> + Pstr_primitive (sub.value_description sub vd) + | Tstr_type (rec_flag, list) -> + Pstr_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tstr_typext tyext -> + Pstr_typext (sub.type_extension sub tyext) + | Tstr_exception ext -> + Pstr_exception (sub.type_exception sub ext) + | Tstr_module mb -> + Pstr_module (sub.module_binding sub mb) + | Tstr_recmodule list -> + Pstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype mtd -> + Pstr_modtype (sub.module_type_declaration sub mtd) + | Tstr_open od -> + Pstr_open (sub.open_declaration sub od) + | Tstr_class list -> + Pstr_class + (List.map + (fun (ci, _) -> sub.class_declaration sub ci) + list) + | Tstr_class_type list -> + Pstr_class_type + (List.map + (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) + list) + | Tstr_include incl -> + Pstr_include (sub.include_declaration sub incl) + | Tstr_attribute x -> + Pstr_attribute x + in + Str.mk ~loc desc + +let value_description sub v = + let loc = sub.location sub v.val_loc in + let attrs = sub.attributes sub v.val_attributes in + Val.mk ~loc ~attrs + ~prim:v.val_prim + (map_loc sub v.val_name) + (sub.typ sub v.val_desc) + +let module_binding sub mb = + let loc = sub.location sub mb.mb_loc in + let attrs = sub.attributes sub mb.mb_attributes in + Mb.mk ~loc ~attrs + (map_loc sub mb.mb_name) + (sub.module_expr sub mb.mb_expr) + +let type_parameter sub (ct, v) = (sub.typ sub ct, v) + +let type_declaration sub decl = + let loc = sub.location sub decl.typ_loc in + let attrs = sub.attributes sub decl.typ_attributes in + Type.mk ~loc ~attrs + ~params:(List.map (type_parameter sub) decl.typ_params) + ~cstrs:( + List.map + (fun (ct1, ct2, loc) -> + (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc)) + decl.typ_cstrs) + ~kind:(sub.type_kind sub decl.typ_kind) + ~priv:decl.typ_private + ?manifest:(Option.map (sub.typ sub) decl.typ_manifest) + (map_loc sub decl.typ_name) + +let type_kind sub tk = match tk with + | Ttype_abstract -> Ptype_abstract + | Ttype_variant list -> + Ptype_variant (List.map (sub.constructor_declaration sub) list) + | Ttype_record list -> + Ptype_record (List.map (sub.label_declaration sub) list) + | Ttype_open -> Ptype_open + +let constructor_arguments sub = function + | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) + +let constructor_declaration sub cd = + let loc = sub.location sub cd.cd_loc in + let attrs = sub.attributes sub cd.cd_attributes in + Type.constructor ~loc ~attrs + ~vars:cd.cd_vars + ~args:(constructor_arguments sub cd.cd_args) + ?res:(Option.map (sub.typ sub) cd.cd_res) + (map_loc sub cd.cd_name) + +let label_declaration sub ld = + let loc = sub.location sub ld.ld_loc in + let attrs = sub.attributes sub ld.ld_attributes in + Type.field ~loc ~attrs + ~mut:ld.ld_mutable + (map_loc sub ld.ld_name) + (sub.typ sub ld.ld_type) + +let type_extension sub tyext = + let attrs = sub.attributes sub tyext.tyext_attributes in + Te.mk ~attrs + ~params:(List.map (type_parameter sub) tyext.tyext_params) + ~priv:tyext.tyext_private + (map_loc sub tyext.tyext_txt) + (List.map (sub.extension_constructor sub) tyext.tyext_constructors) + +let type_exception sub tyexn = + let attrs = sub.attributes sub tyexn.tyexn_attributes in + Te.mk_exception ~attrs + (sub.extension_constructor sub tyexn.tyexn_constructor) + +let extension_constructor sub ext = + let loc = sub.location sub ext.ext_loc in + let attrs = sub.attributes sub ext.ext_attributes in + Te.constructor ~loc ~attrs + (map_loc sub ext.ext_name) + (match ext.ext_kind with + | Text_decl (vs, args, ret) -> + Pext_decl (vs, constructor_arguments sub args, + Option.map (sub.typ sub) ret) + | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) + ) + +let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> + let loc = sub.location sub pat.pat_loc in + (* todo: fix attributes on extras *) + let attrs = sub.attributes sub pat.pat_attributes in + let desc = + match pat with + { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } -> + Ppat_unpack { txt = None; loc } + | { pat_extra=[Tpat_unpack, _, _attrs]; + pat_desc = Tpat_var (_,name, _); _ } -> + Ppat_unpack { name with txt = Some name.txt } + | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> + Ppat_type (map_loc sub lid) + | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> + Ppat_constraint (sub.pat sub { pat with pat_extra=rem }, + sub.typ sub ct) + | _ -> + match pat.pat_desc with + Tpat_any -> Ppat_any + | Tpat_var (id, name, _) -> + begin + match (Ident.name id).[0] with + 'A'..'Z' -> + Ppat_unpack { name with txt = Some name.txt} + | _ -> + Ppat_var name + end + + (* We transform (_ as x) in x if _ and x have the same location. + The compiler transforms (x:t) into (_ as x : t). + This avoids transforming a warning 27 into a 26. + *) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _) + when pat_loc = pat.pat_loc -> + Ppat_var name + + | Tpat_alias (pat, _id, name, _) -> + Ppat_alias (sub.pat sub pat, name) + | Tpat_constant cst -> Ppat_constant (constant cst) + | Tpat_tuple list -> + Ppat_tuple (List.map (sub.pat sub) list) + | Tpat_construct (lid, _, args, vto) -> + let tyo = + match vto with + None -> None + | Some (vl, ty) -> + let vl = + List.map (fun x -> {x with txt = Ident.name x.txt}) vl + in + Some (vl, sub.typ sub ty) + in + let arg = + match args with + [] -> None + | [arg] -> Some (sub.pat sub arg) + | args -> Some (Pat.tuple ~loc (List.map (sub.pat sub) args)) + in + Ppat_construct (map_loc sub lid, + match tyo, arg with + | Some (vl, ty), Some arg -> + Some (vl, Pat.mk ~loc (Ppat_constraint (arg, ty))) + | None, Some arg -> Some ([], arg) + | _, None -> None) + | Tpat_variant (label, pato, _) -> + Ppat_variant (label, Option.map (sub.pat sub) pato) + | Tpat_record (list, closed) -> + Ppat_record (List.map (fun (lid, _, pat) -> + map_loc sub lid, sub.pat sub pat) list, closed) + | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) + | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) + + | Tpat_exception p -> Ppat_exception (sub.pat sub p) + | Tpat_value p -> (sub.pat sub (p :> pattern)).ppat_desc + | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) + in + Pat.mk ~loc ~attrs desc + +let exp_extra sub (extra, loc, attrs) sexp = + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + let desc = + match extra with + Texp_coerce (cty1, cty2) -> + Pexp_coerce (sexp, + Option.map (sub.typ sub) cty1, + sub.typ sub cty2) + | Texp_constraint cty -> + Pexp_constraint (sexp, sub.typ sub cty) + | Texp_poly cto -> Pexp_poly (sexp, Option.map (sub.typ sub) cto) + | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) + in + Exp.mk ~loc ~attrs desc + +let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_guard; c_rhs} -> + { + pc_lhs = sub.pat sub c_lhs; + pc_guard = Option.map (sub.expr sub) c_guard; + pc_rhs = sub.expr sub c_rhs; + } + +let value_binding sub vb = + let loc = sub.location sub vb.vb_loc in + let attrs = sub.attributes sub vb.vb_attributes in + Vb.mk ~loc ~attrs + (sub.pat sub vb.vb_pat) + (sub.expr sub vb.vb_expr) + +let expression sub exp = + let loc = sub.location sub exp.exp_loc in + let attrs = sub.attributes sub exp.exp_attributes in + let desc = + match exp.exp_desc with + Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) + | Texp_constant cst -> Pexp_constant (constant cst) + | Texp_let (rec_flag, list, exp) -> + Pexp_let (rec_flag, + List.map (sub.value_binding sub) list, + sub.expr sub exp) + | Texp_function (params, body) -> + let body, constraint_ = + match body with + | Tfunction_body body -> + (* Unlike function cases, the [exp_extra] is placed on the body + itself. *) + Pfunction_body (sub.expr sub body), None + | Tfunction_cases { cases; loc; exp_extra; attributes; _ } -> + let cases = List.map (sub.case sub) cases in + let constraint_ = + match exp_extra with + | Some (Texp_coerce (ty1, ty2)) -> + Some + (Pcoerce (Option.map (sub.typ sub) ty1, sub.typ sub ty2)) + | Some (Texp_constraint ty) -> + Some (Pconstraint (sub.typ sub ty)) + | Some (Texp_poly _ | Texp_newtype _) | None -> None + in + Pfunction_cases (cases, loc, attributes), constraint_ + in + let params = + List.concat_map + (fun fp -> + let pat, default_arg = + match fp.fp_kind with + | Tparam_pat pat -> pat, None + | Tparam_optional_default (pat, expr) -> pat, Some expr + in + let pat = sub.pat sub pat in + let default_arg = Option.map (sub.expr sub) default_arg in + let newtypes = + List.map + (fun x -> + { pparam_desc = Pparam_newtype x; + pparam_loc = x.loc; + }) + fp.fp_newtypes + in + let pparam_desc = + Pparam_val (fp.fp_arg_label, default_arg, pat) + in + { pparam_desc; pparam_loc = fp.fp_loc } :: newtypes) + params + in + Pexp_function (params, constraint_, body) + | Texp_apply (exp, list) -> + Pexp_apply (sub.expr sub exp, + List.fold_right (fun (label, expo) list -> + match expo with + None -> list + | Some exp -> (label, sub.expr sub exp) :: list + ) list []) + | Texp_match (exp, cases, eff_cases, _) -> + let merged_cases = List.map (sub.case sub) cases + @ List.map + (fun c -> + let uc = sub.case sub c in + let pat = { uc.pc_lhs + (* XXX KC: The 2nd argument of Ppat_effect is wrong *) + with ppat_desc = Ppat_effect (uc.pc_lhs, uc.pc_lhs) } + in + { uc with pc_lhs = pat }) + eff_cases + in + Pexp_match (sub.expr sub exp, merged_cases) + | Texp_try (exp, exn_cases, eff_cases) -> + let merged_cases = List.map (sub.case sub) exn_cases + @ List.map + (fun c -> + let uc = sub.case sub c in + let pat = { uc.pc_lhs + (* XXX KC: The 2nd argument of Ppat_effect is wrong *) + with ppat_desc = Ppat_effect (uc.pc_lhs, uc.pc_lhs) } + in + { uc with pc_lhs = pat }) + eff_cases + in + Pexp_try (sub.expr sub exp, merged_cases) + | Texp_tuple list -> + Pexp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, _, args) -> + Pexp_construct (map_loc sub lid, + (match args with + [] -> None + | [ arg ] -> Some (sub.expr sub arg) + | args -> + Some + (Exp.tuple ~loc (List.map (sub.expr sub) args)) + )) + | Texp_variant (label, expo) -> + Pexp_variant (label, Option.map (sub.expr sub) expo) + | Texp_record { fields; extended_expression; _ } -> + let list = Array.fold_left (fun l -> function + | _, Kept _ -> l + | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) + [] fields + in + Pexp_record (list, Option.map (sub.expr sub) extended_expression) + | Texp_field (exp, lid, _label) -> + Pexp_field (sub.expr sub exp, map_loc sub lid) + | Texp_setfield (exp1, lid, _label, exp2) -> + Pexp_setfield (sub.expr sub exp1, map_loc sub lid, + sub.expr sub exp2) + | Texp_array list -> + Pexp_array (List.map (sub.expr sub) list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Pexp_ifthenelse (sub.expr sub exp1, + sub.expr sub exp2, + Option.map (sub.expr sub) expo) + | Texp_sequence (exp1, exp2) -> + Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) + | Texp_while (exp1, exp2) -> + Pexp_while (sub.expr sub exp1, sub.expr sub exp2) + | Texp_for (_id, name, exp1, exp2, dir, exp3) -> + Pexp_for (name, + sub.expr sub exp1, sub.expr sub exp2, + dir, sub.expr sub exp3) + | Texp_send (exp, meth) -> + Pexp_send (sub.expr sub exp, match meth with + Tmeth_name name -> mkloc name loc + | Tmeth_val id -> mkloc (Ident.name id) loc + | Tmeth_ancestor(id, _) -> mkloc (Ident.name id) loc) + | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid) + | Texp_instvar (_, path, name) -> + Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path}) + | Texp_setinstvar (_, _path, lid, exp) -> + Pexp_setinstvar (map_loc sub lid, sub.expr sub exp) + | Texp_override (_, list) -> + Pexp_override (List.map (fun (_path, lid, exp) -> + (map_loc sub lid, sub.expr sub exp) + ) list) + | Texp_letmodule (_id, name, _pres, mexpr, exp) -> + Pexp_letmodule (name, sub.module_expr sub mexpr, + sub.expr sub exp) + | Texp_letexception (ext, exp) -> + Pexp_letexception (sub.extension_constructor sub ext, + sub.expr sub exp) + | Texp_assert (exp, _) -> Pexp_assert (sub.expr sub exp) + | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp) + | Texp_object (cl, _) -> + Pexp_object (sub.class_structure sub cl) + | Texp_pack (mexpr) -> + Pexp_pack (sub.module_expr sub mexpr) + | Texp_letop {let_; ands; body; _} -> + let pat, and_pats = + extract_letop_patterns (List.length ands) body.c_lhs + in + let let_ = sub.binding_op sub let_ pat in + let ands = List.map2 (sub.binding_op sub) ands and_pats in + let body = sub.expr sub body.c_rhs in + Pexp_letop {let_; ands; body } + | Texp_unreachable -> + Pexp_unreachable + | Texp_extension_constructor (lid, _) -> + Pexp_extension ({ txt = "ocaml.extension_constructor"; loc }, + PStr [ Str.eval ~loc + (Exp.construct ~loc (map_loc sub lid) None) + ]) + | Texp_open (od, exp) -> + Pexp_open (sub.open_declaration sub od, sub.expr sub exp) + in + List.fold_right (exp_extra sub) exp.exp_extra + (Exp.mk ~loc ~attrs desc) + +let binding_op sub bop pat = + let pbop_op = bop.bop_op_name in + let pbop_pat = sub.pat sub pat in + let pbop_exp = sub.expr sub bop.bop_exp in + let pbop_loc = bop.bop_loc in + {pbop_op; pbop_pat; pbop_exp; pbop_loc} + +let package_type sub pack = + (map_loc sub pack.pack_txt, + List.map (fun (s, ct) -> + (s, sub.typ sub ct)) pack.pack_fields) + +let module_type_declaration sub mtd = + let loc = sub.location sub mtd.mtd_loc in + let attrs = sub.attributes sub mtd.mtd_attributes in + Mtd.mk ~loc ~attrs + ?typ:(Option.map (sub.module_type sub) mtd.mtd_type) + (map_loc sub mtd.mtd_name) + +let signature sub sg = + List.map (sub.signature_item sub) sg.sig_items + +let signature_item sub item = + let loc = sub.location sub item.sig_loc in + let desc = + match item.sig_desc with + Tsig_value v -> + Psig_value (sub.value_description sub v) + | Tsig_type (rec_flag, list) -> + Psig_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tsig_typesubst list -> + Psig_typesubst (List.map (sub.type_declaration sub) list) + | Tsig_typext tyext -> + Psig_typext (sub.type_extension sub tyext) + | Tsig_exception ext -> + Psig_exception (sub.type_exception sub ext) + | Tsig_module md -> + Psig_module (sub.module_declaration sub md) + | Tsig_modsubst ms -> + Psig_modsubst (sub.module_substitution sub ms) + | Tsig_recmodule list -> + Psig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype mtd -> + Psig_modtype (sub.module_type_declaration sub mtd) + | Tsig_modtypesubst mtd -> + Psig_modtypesubst (sub.module_type_declaration sub mtd) + | Tsig_open od -> + Psig_open (sub.open_description sub od) + | Tsig_include incl -> + Psig_include (sub.include_description sub incl) + | Tsig_class list -> + Psig_class (List.map (sub.class_description sub) list) + | Tsig_class_type list -> + Psig_class_type (List.map (sub.class_type_declaration sub) list) + | Tsig_attribute x -> + Psig_attribute x + in + Sig.mk ~loc desc + +let module_declaration sub md = + let loc = sub.location sub md.md_loc in + let attrs = sub.attributes sub md.md_attributes in + Md.mk ~loc ~attrs + (map_loc sub md.md_name) + (sub.module_type sub md.md_type) + +let module_substitution sub ms = + let loc = sub.location sub ms.ms_loc in + let attrs = sub.attributes sub ms.ms_attributes in + Ms.mk ~loc ~attrs + (map_loc sub ms.ms_name) + (map_loc sub ms.ms_txt) + +let include_infos f sub incl = + let loc = sub.location sub incl.incl_loc in + let attrs = sub.attributes sub incl.incl_attributes in + Incl.mk ~loc ~attrs + (f sub incl.incl_mod) + +let include_declaration sub = include_infos sub.module_expr sub +let include_description sub = include_infos sub.module_type sub + +let class_infos f sub ci = + let loc = sub.location sub ci.ci_loc in + let attrs = sub.attributes sub ci.ci_attributes in + Ci.mk ~loc ~attrs + ~virt:ci.ci_virt + ~params:(List.map (type_parameter sub) ci.ci_params) + (map_loc sub ci.ci_id_name) + (f sub ci.ci_expr) + +let class_declaration sub = class_infos sub.class_expr sub +let class_description sub = class_infos sub.class_type sub +let class_type_declaration sub = class_infos sub.class_type sub + +let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter = + function + | Unit -> Unit + | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype) + +let module_type (sub : mapper) mty = + let loc = sub.location sub mty.mty_loc in + let attrs = sub.attributes sub mty.mty_attributes in + let desc = match mty.mty_desc with + Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) + | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) + | Tmty_signature sg -> Pmty_signature (sub.signature sub sg) + | Tmty_functor (arg, mtype2) -> + Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2) + | Tmty_with (mtype, list) -> + Pmty_with (sub.module_type sub mtype, + List.map (sub.with_constraint sub) list) + | Tmty_typeof mexpr -> + Pmty_typeof (sub.module_expr sub mexpr) + in + Mty.mk ~loc ~attrs desc + +let with_constraint sub (_path, lid, cstr) = + match cstr with + | Twith_type decl -> + Pwith_type (map_loc sub lid, sub.type_declaration sub decl) + | Twith_module (_path, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Twith_modtype mty -> + let mty = sub.module_type sub mty in + Pwith_modtype (map_loc sub lid,mty) + | Twith_typesubst decl -> + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) + | Twith_modsubst (_path, lid2) -> + Pwith_modsubst (map_loc sub lid, map_loc sub lid2) + | Twith_modtypesubst mty -> + let mty = sub.module_type sub mty in + Pwith_modtypesubst (map_loc sub lid, mty) + +let module_expr (sub : mapper) mexpr = + let loc = sub.location sub mexpr.mod_loc in + let attrs = sub.attributes sub mexpr.mod_attributes in + match mexpr.mod_desc with + Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> + sub.module_expr sub m + | _ -> + let desc = match mexpr.mod_desc with + Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) + | Tmod_structure st -> Pmod_structure (sub.structure sub st) + | Tmod_functor (arg, mexpr) -> + Pmod_functor + (functor_parameter sub arg, sub.module_expr sub mexpr) + | Tmod_apply (mexp1, mexp2, _) -> + Pmod_apply (sub.module_expr sub mexp1, + sub.module_expr sub mexp2) + | Tmod_apply_unit mexp1 -> + Pmod_apply_unit (sub.module_expr sub mexp1) + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + Pmod_constraint (sub.module_expr sub mexpr, + sub.module_type sub mtype) + | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> + assert false + | Tmod_unpack (exp, _pack) -> + Pmod_unpack (sub.expr sub exp) + (* TODO , sub.package_type sub pack) *) + in + Mod.mk ~loc ~attrs desc + +let class_expr sub cexpr = + let loc = sub.location sub cexpr.cl_loc in + let attrs = sub.attributes sub cexpr.cl_attributes in + let desc = match cexpr.cl_desc with + | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ }, + None, _, _, _ ) -> + Pcl_constr (map_loc sub lid, + List.map (sub.typ sub) tyl) + | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr) + + | Tcl_fun (label, pat, _pv, cl, _partial) -> + Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl) + + | Tcl_apply (cl, args) -> + Pcl_apply (sub.class_expr sub cl, + List.fold_right (fun (label, expo) list -> + match expo with + None -> list + | Some exp -> (label, sub.expr sub exp) :: list + ) args []) + + | Tcl_let (rec_flat, bindings, _ivars, cl) -> + Pcl_let (rec_flat, + List.map (sub.value_binding sub) bindings, + sub.class_expr sub cl) + + | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> + Pcl_constraint (sub.class_expr sub cl, sub.class_type sub clty) + + | Tcl_open (od, e) -> + Pcl_open (sub.open_description sub od, sub.class_expr sub e) + + | Tcl_ident _ -> assert false + | Tcl_constraint (_, None, _, _, _) -> assert false + in + Cl.mk ~loc ~attrs desc + +let class_type sub ct = + let loc = sub.location sub ct.cltyp_loc in + let attrs = sub.attributes sub ct.cltyp_attributes in + let desc = match ct.cltyp_desc with + Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) + | Tcty_constr (_path, lid, list) -> + Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) + | Tcty_arrow (label, ct, cl) -> + Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) + | Tcty_open (od, e) -> + Pcty_open (sub.open_description sub od, sub.class_type sub e) + in + Cty.mk ~loc ~attrs desc + +let class_signature sub cs = + { + pcsig_self = sub.typ sub cs.csig_self; + pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields; + } + +let class_type_field sub ctf = + let loc = sub.location sub ctf.ctf_loc in + let attrs = sub.attributes sub ctf.ctf_attributes in + let desc = match ctf.ctf_desc with + Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) + | Tctf_val (s, mut, virt, ct) -> + Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct) + | Tctf_method (s, priv, virt, ct) -> + Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + | Tctf_attribute x -> Pctf_attribute x + in + Ctf.mk ~loc ~attrs desc + +let core_type sub ct = + let loc = sub.location sub ct.ctyp_loc in + let attrs = sub.attributes sub ct.ctyp_attributes in + let desc = match ct.ctyp_desc with + Ttyp_any -> Ptyp_any + | Ttyp_var s -> Ptyp_var s + | Ttyp_arrow (label, ct1, ct2) -> + Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) + | Ttyp_constr (_path, lid, list) -> + Ptyp_constr (map_loc sub lid, + List.map (sub.typ sub) list) + | Ttyp_object (list, o) -> + Ptyp_object + (List.map (sub.object_field sub) list, o) + | Ttyp_class (_path, lid, list) -> + Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) + | Ttyp_alias (ct, s) -> + Ptyp_alias (sub.typ sub ct, s) + | Ttyp_variant (list, bool, labels) -> + Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) + | Ttyp_poly (list, ct) -> + let list = List.map (fun v -> mkloc v loc) list in + Ptyp_poly (list, sub.typ sub ct) + | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack) + | Ttyp_open (_path, mod_ident, t) -> Ptyp_open (mod_ident, sub.typ sub t) + in + Typ.mk ~loc ~attrs desc + +let class_structure sub cs = + let rec remove_self = function + | { pat_desc = Tpat_alias (p, id, _s, _) } + when string_is_prefix "selfpat-" (Ident.name id) -> + remove_self p + | p -> p + in + { pcstr_self = sub.pat sub (remove_self cs.cstr_self); + pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields; + } + +let row_field sub {rf_loc; rf_desc; rf_attributes;} = + let loc = sub.location sub rf_loc in + let attrs = sub.attributes sub rf_attributes in + let desc = match rf_desc with + | Ttag (label, bool, list) -> + Rtag (label, bool, List.map (sub.typ sub) list) + | Tinherit ct -> Rinherit (sub.typ sub ct) + in + Rf.mk ~loc ~attrs desc + +let object_field sub {of_loc; of_desc; of_attributes;} = + let loc = sub.location sub of_loc in + let attrs = sub.attributes sub of_attributes in + let desc = match of_desc with + | OTtag (label, ct) -> + Otag (label, sub.typ sub ct) + | OTinherit ct -> Oinherit (sub.typ sub ct) + in + Of.mk ~loc ~attrs desc + +and is_self_pat = function + | { pat_desc = Tpat_alias(_pat, id, _, _) } -> + string_is_prefix "self-" (Ident.name id) + | _ -> false + +(* [Typeclass] adds a [self] parameter to initializers and methods that isn't + present in the source program. +*) +let remove_fun_self exp = + match exp with + | { exp_desc = + Texp_function + ({fp_arg_label = Nolabel; fp_kind = Tparam_pat pat} :: params, body) + } + when is_self_pat pat -> + (match params, body with + | [], Tfunction_body body -> body + | _, _ -> { exp with exp_desc = Texp_function (params, body) }) + | e -> e + +let class_field sub cf = + let loc = sub.location sub cf.cf_loc in + let attrs = sub.attributes sub cf.cf_attributes in + let desc = match cf.cf_desc with + Tcf_inherit (ovf, cl, super, _vals, _meths) -> + Pcf_inherit (ovf, sub.class_expr sub cl, + Option.map (fun v -> mkloc v loc) super) + | Tcf_constraint (cty, cty') -> + Pcf_constraint (sub.typ sub cty, sub.typ sub cty') + | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) -> + Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty)) + | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) -> + Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp)) + | Tcf_method (lab, priv, Tcfk_virtual cty) -> + Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty)) + | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) -> + let exp = remove_fun_self exp in + Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp)) + | Tcf_initializer exp -> + let exp = remove_fun_self exp in + Pcf_initializer (sub.expr sub exp) + | Tcf_attribute x -> Pcf_attribute x + in + Cf.mk ~loc ~attrs desc + +let location _sub l = l + +let default_mapper = + { + attribute = attribute; + attributes = attributes; + binding_op = binding_op; + structure = structure; + structure_item = structure_item; + module_expr = module_expr; + signature = signature; + signature_item = signature_item; + module_type = module_type; + with_constraint = with_constraint; + class_declaration = class_declaration; + class_expr = class_expr; + class_field = class_field; + class_structure = class_structure; + class_type = class_type; + class_type_field = class_type_field; + class_signature = class_signature; + class_type_declaration = class_type_declaration; + class_description = class_description; + type_declaration = type_declaration; + type_kind = type_kind; + typ = core_type; + type_extension = type_extension; + type_exception = type_exception; + extension_constructor = extension_constructor; + value_description = value_description; + pat = pattern; + expr = expression; + module_declaration = module_declaration; + module_substitution = module_substitution; + module_type_declaration = module_type_declaration; + module_binding = module_binding; + package_type = package_type ; + open_declaration = open_declaration; + open_description = open_description; + include_description = include_description; + include_declaration = include_declaration; + value_binding = value_binding; + constructor_declaration = constructor_declaration; + label_declaration = label_declaration; + case = case; + location = location; + row_field = row_field ; + object_field = object_field ; + } + +let untype_structure ?(mapper : mapper = default_mapper) structure = + mapper.structure mapper structure + +let untype_signature ?(mapper : mapper = default_mapper) signature = + mapper.signature mapper signature + +let untype_expression ?(mapper=default_mapper) expression = + mapper.expr mapper expression + +let untype_pattern ?(mapper=default_mapper) pattern = + mapper.pat mapper pattern diff --git a/upstream/ocaml_503/typing/untypeast.mli b/upstream/ocaml_503/typing/untypeast.mli new file mode 100644 index 000000000..809df9ad0 --- /dev/null +++ b/upstream/ocaml_503/typing/untypeast.mli @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Parsetree + +val lident_of_path : Path.t -> Longident.t + +type mapper = { + attribute: mapper -> Typedtree.attribute -> attribute; + attributes: mapper -> Typedtree.attribute list -> attribute list; + binding_op: + mapper -> + Typedtree.binding_op -> Typedtree.pattern -> binding_op; + case: 'k . mapper -> 'k Typedtree.case -> case; + class_declaration: mapper -> Typedtree.class_declaration -> class_declaration; + class_description: mapper -> Typedtree.class_description -> class_description; + class_expr: mapper -> Typedtree.class_expr -> class_expr; + class_field: mapper -> Typedtree.class_field -> class_field; + class_signature: mapper -> Typedtree.class_signature -> class_signature; + class_structure: mapper -> Typedtree.class_structure -> class_structure; + class_type: mapper -> Typedtree.class_type -> class_type; + class_type_declaration: mapper -> Typedtree.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; + constructor_declaration: mapper -> Typedtree.constructor_declaration + -> constructor_declaration; + expr: mapper -> Typedtree.expression -> expression; + extension_constructor: mapper -> Typedtree.extension_constructor + -> extension_constructor; + include_declaration: + mapper -> Typedtree.include_declaration -> include_declaration; + include_description: + mapper -> Typedtree.include_description -> include_description; + label_declaration: + mapper -> Typedtree.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> Typedtree.module_binding -> module_binding; + module_declaration: + mapper -> Typedtree.module_declaration -> module_declaration; + module_substitution: + mapper -> Typedtree.module_substitution -> module_substitution; + module_expr: mapper -> Typedtree.module_expr -> module_expr; + module_type: mapper -> Typedtree.module_type -> module_type; + module_type_declaration: + mapper -> Typedtree.module_type_declaration -> module_type_declaration; + package_type: mapper -> Typedtree.package_type -> package_type; + open_declaration: mapper -> Typedtree.open_declaration -> open_declaration; + open_description: mapper -> Typedtree.open_description -> open_description; + pat: 'k . mapper -> 'k Typedtree.general_pattern -> pattern; + row_field: mapper -> Typedtree.row_field -> row_field; + object_field: mapper -> Typedtree.object_field -> object_field; + signature: mapper -> Typedtree.signature -> signature; + signature_item: mapper -> Typedtree.signature_item -> signature_item; + structure: mapper -> Typedtree.structure -> structure; + structure_item: mapper -> Typedtree.structure_item -> structure_item; + typ: mapper -> Typedtree.core_type -> core_type; + type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; + type_extension: mapper -> Typedtree.type_extension -> type_extension; + type_exception: mapper -> Typedtree.type_exception -> type_exception; + type_kind: mapper -> Typedtree.type_kind -> type_kind; + value_binding: mapper -> Typedtree.value_binding -> value_binding; + value_description: mapper -> Typedtree.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) + -> with_constraint; +} + +val default_mapper : mapper + +val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure +val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature +val untype_expression : ?mapper:mapper -> Typedtree.expression -> expression +val untype_pattern : ?mapper:mapper -> _ Typedtree.general_pattern -> pattern + +val constant : Asttypes.constant -> Parsetree.constant diff --git a/upstream/ocaml_503/typing/value_rec_check.ml b/upstream/ocaml_503/typing/value_rec_check.ml new file mode 100644 index 000000000..4f4e4d052 --- /dev/null +++ b/upstream/ocaml_503/typing/value_rec_check.ml @@ -0,0 +1,1421 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremy Yallop, University of Cambridge *) +(* Gabriel Scherer, Project Parsifal, INRIA Saclay *) +(* Alban Reynaud, ENS Lyon *) +(* *) +(* Copyright 2017 Jeremy Yallop *) +(* Copyright 2018 Alban Reynaud *) +(* Copyright 2018 INRIA *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Static checking of recursive declarations, as described in + + A practical mode system for recursive definitions + Alban Reynaud, Gabriel Scherer and Jeremy Yallop + POPL 2021 + +Some recursive definitions are meaningful +{[ + let rec factorial = function 0 -> 1 | n -> n * factorial (n - 1) + let rec infinite_list = 0 :: infinite_list +]} +but some other are meaningless +{[ + let rec x = x + let rec x = x+1 +]} + +Intuitively, a recursive definition makes sense when the body of the +definition can be evaluated without fully knowing what the recursive +name is yet. + +In the [factorial] example, the name [factorial] refers to a function, +evaluating the function definition [function ...] can be done +immediately and will not force a recursive call to [factorial] -- this +will only happen later, when [factorial] is called with an argument. + +In the [infinite_list] example, we can evaluate [0 :: infinite_list] +without knowing the full content of [infinite_list], but with just its +address. This is a case of productive/guarded recursion. + +On the contrary, [let rec x = x] is unguarded recursion (the meaning +is undetermined), and [let rec x = x+1] would need the value of [x] +while evaluating its definition [x+1]. + +This file implements a static check to decide which definitions are +known to be meaningful, and which may be meaningless. In the general +case, we handle a set of mutually-recursive definitions +{[ +let rec x1 = e1 +and x2 = e2 +... +and xn = en +]} + + +Our check (see function [is_valid_recursive_expression] is defined +using two criteria: + +Usage of recursive variables: how does each of the [e1 .. en] use the + recursive variables [x1 .. xn]? + +Static or dynamic size: for which of the [ei] can we compute the + in-memory size of the value without evaluating [ei] (so that we can + pre-allocate it, and thus know its final address before evaluation). + +The "static or dynamic size" is decided by the classify_* functions below. + +The "variable usage" question is decided by a static analysis looking +very much like a type system. The idea is to assign "access modes" to +variables, where an "access mode" [m] is defined as either + + m ::= Ignore (* the value is not used at all *) + | Delay (* the value is not needed at definition time *) + | Guard (* the value is stored under a data constructor *) + | Return (* the value result is directly returned *) + | Dereference (* full access and inspection of the value *) + +The access modes of an expression [e] are represented by a "context" +[G], which is simply a mapping from variables (the variables used in +[e]) to access modes. + +The core notion of the static check is a type-system-like judgment of +the form [G |- e : m], which can be interpreted as meaning either of: + +- If we are allowed to use the variables of [e] at the modes in [G] + (but not more), then it is safe to use [e] at the mode [m]. + +- If we want to use [e] at the mode [m], then its variables are + used at the modes in [G]. + +In practice, for a given expression [e], our implementation takes the +desired mode of use [m] as *input*, and returns a context [G] as +*output*, which is (uniquely determined as) the most permissive choice +of modes [G] for the variables of [e] such that [G |- e : m] holds. +*) + +open Asttypes +open Typedtree +open Types + +(** {1 Static or dynamic size} *) + +type sd = Value_rec_types.recursive_binding_kind + +let is_ref : Types.value_description -> bool = function + | { Types.val_kind = + Types.Val_prim { Primitive.prim_name = "%makemutable"; + prim_arity = 1 } } -> + true + | _ -> false + +(* See the note on abstracted arguments in the documentation for + Typedtree.Texp_apply *) +let is_abstracted_arg : arg_label * expression option -> bool = function + | (_, None) -> true + | (_, Some _) -> false + +let classify_expression : Typedtree.expression -> sd = + (* We need to keep track of the size of expressions + bound by local declarations, to be able to predict + the size of variables. Compare: + + let rec r = + let y = fun () -> r () + in y + + and + + let rec r = + let y = if Random.bool () then ignore else fun () -> r () + in y + + In both cases the final address of `r` must be known before `y` is compiled, + and this is only possible if `r` has a statically-known size. + + The first definition can be allowed (`y` has a statically-known + size) but the second one is unsound (`y` has no statically-known size). + *) + let rec classify_expression env e : sd = + match e.exp_desc with + (* binding and variable cases *) + | Texp_let (rec_flag, vb, e) -> + let env = classify_value_bindings rec_flag env vb in + classify_expression env e + | Texp_letmodule (Some mid, _, _, mexp, e) -> + (* Note on module presence: + For absent modules (i.e. module aliases), the module being bound + does not have a physical representation, but its size can still be + derived from the alias itself, so we can reuse the same code as + for modules that are present. *) + let size = classify_module_expression env mexp in + let env = Ident.add mid size env in + classify_expression env e + | Texp_ident (path, _, _) -> + classify_path env path + + (* non-binding cases *) + | Texp_open (_, e) + | Texp_letmodule (None, _, _, _, e) + | Texp_sequence (_, e) + | Texp_letexception (_, e) -> + classify_expression env e + + | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) -> + classify_expression env e + | Texp_construct _ -> + Static + + | Texp_record { representation = Record_unboxed _; + fields = [| _, Overridden (_,e) |] } -> + classify_expression env e + | Texp_record _ -> + Static + + | Texp_variant _ + | Texp_tuple _ + | Texp_extension_constructor _ + | Texp_constant _ -> + Static + + | Texp_for _ + | Texp_setfield _ + | Texp_while _ + | Texp_setinstvar _ -> + (* Unit-returning expressions *) + Static + + | Texp_unreachable -> + Static + + | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _) + when is_ref vd -> + Static + | Texp_apply (_,args) + when List.exists is_abstracted_arg args -> + Static + | Texp_apply _ -> + Dynamic + + | Texp_array _ -> + Static + | Texp_pack mexp -> + classify_module_expression env mexp + | Texp_function _ -> + Static + | Texp_lazy e -> + (* The code below was copied (in part) from translcore.ml *) + begin match Typeopt.classify_lazy_argument e with + | `Constant_or_function -> + (* A constant expr (of type <> float if [Config.flat_float_array] is + true) gets compiled as itself. *) + classify_expression env e + | `Float_that_cannot_be_shortcut + | `Identifier `Forward_value -> + (* Forward blocks *) + Static + | `Identifier `Other -> + classify_expression env e + | `Other -> + (* other cases compile to a lazy block holding a function *) + Static + end + + | Texp_new _ + | Texp_instvar _ + | Texp_object _ + | Texp_match _ + | Texp_ifthenelse _ + | Texp_send _ + | Texp_field _ + | Texp_assert _ + | Texp_try _ + | Texp_override _ + | Texp_letop _ -> + Dynamic + and classify_value_bindings rec_flag env bindings = + (* We use a non-recursive classification, classifying each + binding with respect to the old environment + (before all definitions), even if the bindings are recursive. + + Note: computing a fixpoint in some way would be more + precise, as the following could be allowed: + + let rec topdef = + let rec x = y and y = fun () -> topdef () + in x + *) + ignore rec_flag; + let old_env = env in + let add_value_binding env vb = + match vb.vb_pat.pat_desc with + | Tpat_var (id, _loc, _uid) -> + let size = classify_expression old_env vb.vb_expr in + Ident.add id size env + | _ -> + (* Note: we don't try to compute any size for complex patterns *) + env + in + List.fold_left add_value_binding env bindings + and classify_path env : _ -> Value_rec_types.recursive_binding_kind = function + | Path.Pident x -> + begin + try Ident.find_same x env + with Not_found -> + (* an identifier will be missing from the map if either: + - it is a non-local identifier + (bound outside the letrec-binding we are analyzing) + - or it is bound by a complex (let p = e in ...) local binding + - or it is bound within a module (let module M = ... in ...) + that we are not traversing for size computation + + For non-local identifiers it might be reasonable (although + not completely clear) to consider them Static (they have + already been evaluated), but for the others we must + under-approximate with Not_recursive. + + This could be fixed by a more complete implementation. + *) + Dynamic + end + | Path.Pdot _ | Path.Papply _ | Path.Pextra_ty _ -> + (* local modules could have such paths to local definitions; + classify_expression could be extend to compute module + shapes more precisely *) + Dynamic + and classify_module_expression env mexp : sd = + match mexp.mod_desc with + | Tmod_ident (path, _) -> + classify_path env path + | Tmod_structure _ -> + Static + | Tmod_functor _ -> + Static + | Tmod_apply _ -> + Dynamic + | Tmod_apply_unit _ -> + Dynamic + | Tmod_constraint (mexp, _, _, coe) -> + begin match coe with + | Tcoerce_none -> + classify_module_expression env mexp + | Tcoerce_structure _ -> + Static + | Tcoerce_functor _ -> + Static + | Tcoerce_primitive _ -> + Misc.fatal_error "letrec: primitive coercion on a module" + | Tcoerce_alias _ -> + Misc.fatal_error "letrec: alias coercion on a module" + end + | Tmod_unpack (e, _) -> + classify_expression env e + in classify_expression Ident.empty + + +(** {1 Usage of recursive variables} *) + +module Mode = struct + (** For an expression in a program, its "usage mode" represents + static information about how the value produced by the expression + will be used by the context around it. *) + type t = + | Ignore + (** [Ignore] is for subexpressions that are not used at all during + the evaluation of the whole program. This is the mode of + a variable in an expression in which it does not occur. *) + + | Delay + (** A [Delay] context can be fully evaluated without evaluating its argument + , which will only be needed at a later point of program execution. For + example, [fun x -> ?] or [lazy ?] are [Delay] contexts. *) + + | Guard + (** A [Guard] context returns the value as a member of a data structure, + for example a variant constructor or record. The value can safely be + defined mutually-recursively with their context, for example in + [let rec li = 1 :: li]. + When these subexpressions participate in a cyclic definition, + this definition is productive/guarded. + + The [Guard] mode is also used when a value is not dereferenced, + it is returned by a sub-expression, but the result of this + sub-expression is discarded instead of being returned. + For example, the subterm [?] is in a [Guard] context + in [let _ = ? in e] and in [?; e]. + When these subexpressions participate in a cyclic definition, + they cannot create a self-loop. + *) + + | Return + (** A [Return] context returns its value without further inspection. + This value cannot be defined mutually-recursively with its context, + as there is a risk of self-loop: in [let rec x = y and y = x], the + two definitions use a single variable in [Return] context. *) + + | Dereference + (** A [Dereference] context consumes, inspects and uses the value + in arbitrary ways. Such a value must be fully defined at the point + of usage, it cannot be defined mutually-recursively with its context. *) + + let equal = ((=) : t -> t -> bool) + + (* Lower-ranked modes demand/use less of the variable/expression they qualify + -- so they allow more recursive definitions. + + Ignore < Delay < Guard < Return < Dereference + *) + let rank = function + | Ignore -> 0 + | Delay -> 1 + | Guard -> 2 + | Return -> 3 + | Dereference -> 4 + + (* Returns the more conservative (highest-ranking) mode of the two + arguments. + + In judgments we write (m + m') for (join m m'). + *) + let join m m' = + if rank m >= rank m' then m else m' + + (* If x is used with the mode m in e[x], and e[x] is used with mode + m' in e'[e[x]], then x is used with mode m'[m] (our notation for + "compose m' m") in e'[e[x]]. + + Return is neutral for composition: m[Return] = m = Return[m]. + + Composition is associative and [Ignore] is a zero/annihilator for + it: (compose Ignore m) and (compose m Ignore) are both Ignore. *) + let compose m' m = match m', m with + | Ignore, _ | _, Ignore -> Ignore + | Dereference, _ -> Dereference + | Delay, _ -> Delay + | Guard, Return -> Guard + | Guard, ((Dereference | Guard | Delay) as m) -> m + | Return, Return -> Return + | Return, ((Dereference | Guard | Delay) as m) -> m +end + +type mode = Mode.t = Ignore | Delay | Guard | Return | Dereference + +module Env : +sig + type t + + val single : Ident.t -> Mode.t -> t + (** Create an environment with a single identifier used with a given mode. + *) + + val empty : t + (** An environment with no used identifiers. *) + + val find : Ident.t -> t -> Mode.t + (** Find the mode of an identifier in an environment. The default mode is + Ignore. *) + + val unguarded : t -> Ident.t list -> Ident.t list + (** unguarded e l: the list of all identifiers in l that are dereferenced or + returned in the environment e. *) + + val dependent : t -> Ident.t list -> Ident.t list + (** dependent e l: the list of all identifiers in l that are used in e + (not ignored). *) + + val join : t -> t -> t + val join_list : t list -> t + (** Environments can be joined pointwise (variable per variable) *) + + val compose : Mode.t -> t -> t + (** Environment composition m[G] extends mode composition m1[m2] + by composing each mode in G pointwise *) + + val remove : Ident.t -> t -> t + (** Remove an identifier from an environment. *) + + val take: Ident.t -> t -> Mode.t * t + (** Remove an identifier from an environment, and return its mode *) + + val remove_list : Ident.t list -> t -> t + (** Remove all the identifiers of a list from an environment. *) + + val equal : t -> t -> bool +end = struct + module M = Map.Make(Ident) + + (** A "t" maps each rec-bound variable to an access status *) + type t = Mode.t M.t + + let equal = M.equal Mode.equal + + let find (id: Ident.t) (tbl: t) = + try M.find id tbl with Not_found -> Ignore + + let empty = M.empty + + let join (x: t) (y: t) = + M.fold + (fun (id: Ident.t) (v: Mode.t) (tbl: t) -> + let v' = find id tbl in + M.add id (Mode.join v v') tbl) + x y + + let join_list li = List.fold_left join empty li + + let compose m env = + M.map (Mode.compose m) env + + let single id mode = M.add id mode empty + + let unguarded env li = + List.filter (fun id -> Mode.rank (find id env) > Mode.rank Guard) li + + let dependent env li = + List.filter (fun id -> Mode.rank (find id env) > Mode.rank Ignore) li + + let remove = M.remove + + let take id env = (find id env, remove id env) + + let remove_list l env = + List.fold_left (fun env id -> M.remove id env) env l +end + +let remove_pat pat env = + Env.remove_list (pat_bound_idents pat) env + +let remove_patlist pats env = + List.fold_right remove_pat pats env + +(* Usage mode judgments. + + There are two main groups of judgment functions: + + - Judgments of the form "G |- ... : m" + compute the environment G of a subterm ... from its mode m, so + the corresponding function has type [... -> Mode.t -> Env.t]. + + We write [... -> term_judg] in this case. + + - Judgments of the form "G |- ... : m -| G'" + + correspond to binding constructs (for example "let x = e" in the + term "let x = e in body") that have both an exterior environment + G (the environment of the whole term "let x = e in body") and an + interior environment G' (the environment at the "in", after the + binding construct has introduced new names in scope). + + For example, let-binding could be given the following rule: + + G |- e : m + m' + ----------------------------------- + G+G' |- (let x = e) : m -| x:m', G' + + Checking the whole term composes this judgment + with the "G |- e : m" form for the let body: + + G |- (let x = e) : m -| G' + G' |- body : m + ------------------------------- + G |- let x = e in body : m + + To this judgment "G |- e : m -| G'" our implementation gives the + type [... -> Mode.t -> Env.t -> Env.t]: it takes the mode and + interior environment as inputs, and returns the exterior + environment. + + We write [... -> bind_judg] in this case. +*) +type term_judg = Mode.t -> Env.t +type bind_judg = Mode.t -> Env.t -> Env.t + +let option : 'a. ('a -> term_judg) -> 'a option -> term_judg = + fun f o m -> match o with + | None -> Env.empty + | Some v -> f v m +let list : 'a. ('a -> term_judg) -> 'a list -> term_judg = + fun f li m -> + List.fold_left (fun env item -> Env.join env (f item m)) Env.empty li +let array : 'a. ('a -> term_judg) -> 'a array -> term_judg = + fun f ar m -> + Array.fold_left (fun env item -> Env.join env (f item m)) Env.empty ar + +let single : Ident.t -> term_judg = Env.single +let remove_id : Ident.t -> term_judg -> term_judg = + fun id f m -> Env.remove id (f m) +let remove_ids : Ident.t list -> term_judg -> term_judg = + fun ids f m -> Env.remove_list ids (f m) + +let join : term_judg list -> term_judg = + fun li m -> Env.join_list (List.map (fun f -> f m) li) + +let empty = fun _ -> Env.empty + +(* A judgment [judg] takes a mode from the context as input, and + returns an environment. The judgment [judg << m], given a mode [m'] + from the context, evaluates [judg] in the composed mode [m'[m]]. *) +let (<<) : term_judg -> Mode.t -> term_judg = + fun f inner_mode -> fun outer_mode -> f (Mode.compose outer_mode inner_mode) + +(* A binding judgment [binder] expects a mode and an inner environment, + and returns an outer environment. [binder >> judg] computes + the inner environment as the environment returned by [judg] + in the ambient mode. *) +let (>>) : bind_judg -> term_judg -> term_judg = + fun binder term mode -> binder mode (term mode) + +(* Expression judgment: + G |- e : m + where (m) is an input of the code and (G) is an output; + in the Prolog mode notation, this is (+G |- -e : -m). +*) +let rec expression : Typedtree.expression -> term_judg = + fun exp -> match exp.exp_desc with + | Texp_ident (pth, _, _) -> + path pth + | Texp_let (rec_flag, bindings, body) -> + (* + G |- : m -| G' + G' |- body : m + ------------------------------- + G |- let in body : m + *) + value_bindings rec_flag bindings >> expression body + | Texp_letmodule (x, _, _, mexp, e) -> + module_binding (x, mexp) >> expression e + | Texp_match (e, cases, eff_cases, _) -> + (* TODO: update comment below for eff_cases + (Gi; mi |- pi -> ei : m)^i + G |- e : sum(mi)^i + ---------------------------------------------- + G + sum(Gi)^i |- match e with (pi -> ei)^i : m + *) + (fun mode -> + let pat_envs, pat_modes = + List.split (List.map (fun c -> case c mode) cases) in + let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in + let eff_envs, eff_modes = + List.split (List.map (fun c -> case c mode) eff_cases) in + let eff_e = expression e (List.fold_left Mode.join Ignore eff_modes) in + Env.join_list + ((Env.join_list (env_e :: pat_envs)) :: (eff_e :: eff_envs))) + | Texp_for (_, _, low, high, _, body) -> + (* + G1 |- low: m[Dereference] + G2 |- high: m[Dereference] + G3 |- body: m[Guard] + --- + G1 + G2 + G3 |- for _ = low to high do body done: m + *) + join [ + expression low << Dereference; + expression high << Dereference; + expression body << Guard; + ] + | Texp_constant _ -> + empty + | Texp_new (pth, _, _) -> + (* + G |- c: m[Dereference] + ----------------------- + G |- new c: m + *) + path pth << Dereference + | Texp_instvar (self_path, pth, _inst_var) -> + join [path self_path << Dereference; path pth] + | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg]) + when is_ref vd -> + (* + G |- e: m[Guard] + ------------------ + G |- ref e: m + *) + expression arg << Guard + | Texp_apply (e, args) -> + (* [args] may contain omitted arguments, corresponding to labels in + the function's type that were not passed in the actual application. + The arguments before the first omitted argument are passed to the + function immediately, so they are dereferenced. The arguments after + the first omitted one are stored in a closure, so guarded. + The function itself is called immediately (dereferenced) if there + is at least one argument before the first omitted one. + On the other hand, if the first argument is omitted then the + function is stored in the closure without being called. *) + let rec split_args ~has_omitted_arg = function + | [] -> [], [] + | (_, None) :: rest -> split_args ~has_omitted_arg:true rest + | (_, Some arg) :: rest -> + let applied, delayed = split_args ~has_omitted_arg rest in + if has_omitted_arg + then applied, arg :: delayed + else arg :: applied, delayed + in + let applied, delayed = split_args ~has_omitted_arg:false args in + let function_mode = + match applied with + | [] -> Guard + | _ :: _ -> Dereference + in + join [expression e << function_mode; + list expression applied << Dereference; + list expression delayed << Guard] + | Texp_tuple exprs -> + list expression exprs << Guard + | Texp_array exprs -> + let array_mode = match Typeopt.array_kind exp with + | Lambda.Pfloatarray -> + (* (flat) float arrays unbox their elements *) + Dereference + | Lambda.Pgenarray -> + (* This is counted as a use, because constructing a generic array + involves inspecting to decide whether to unbox (PR#6939). *) + Dereference + | Lambda.Paddrarray | Lambda.Pintarray -> + (* non-generic, non-float arrays act as constructors *) + Guard + in + list expression exprs << array_mode + | Texp_construct (_, desc, exprs) -> + let access_constructor = + match desc.cstr_tag with + | Cstr_extension (pth, _) -> + path pth << Dereference + | _ -> empty + in + let m' = match desc.cstr_tag with + | Cstr_unboxed -> + Return + | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> + Guard + in + join [ + access_constructor; + list expression exprs << m' + ] + | Texp_variant (_, eo) -> + (* + G |- e: m[Guard] + ------------------ ----------- + G |- `A e: m [] |- `A: m + *) + option expression eo << Guard + | Texp_record { fields = es; extended_expression = eo; + representation = rep } -> + let field_mode = match rep with + | Record_float -> Dereference + | Record_unboxed _ -> Return + | Record_regular | Record_inlined _ + | Record_extension _ -> Guard + in + let field (_label, field_def) = match field_def with + Kept _ -> empty + | Overridden (_, e) -> expression e + in + join [ + array field es << field_mode; + option expression eo << Dereference + ] + | Texp_ifthenelse (cond, ifso, ifnot) -> + (* + Gc |- c: m[Dereference] + G1 |- e1: m + G2 |- e2: m + --- + Gc + G1 + G2 |- if c then e1 else e2: m + + Note: `if c then e1 else e2` is treated in the same way as + `match c with true -> e1 | false -> e2` + *) + join [ + expression cond << Dereference; + expression ifso; + option expression ifnot; + ] + | Texp_setfield (e1, _, _, e2) -> + (* + G1 |- e1: m[Dereference] + G2 |- e2: m[Dereference] + --- + G1 + G2 |- e1.x <- e2: m + + Note: e2 is dereferenced in the case of a field assignment to + a record of unboxed floats in that case, e2 evaluates to + a boxed float and it is unboxed on assignment. + *) + join [ + expression e1 << Dereference; + expression e2 << Dereference; + ] + | Texp_sequence (e1, e2) -> + (* + G1 |- e1: m[Guard] + G2 |- e2: m + -------------------- + G1 + G2 |- e1; e2: m + + Note: `e1; e2` is treated in the same way as `let _ = e1 in e2` + *) + join [ + expression e1 << Guard; + expression e2; + ] + | Texp_while (cond, body) -> + (* + G1 |- cond: m[Dereference] + G2 |- body: m[Guard] + --------------------------------- + G1 + G2 |- while cond do body done: m + *) + join [ + expression cond << Dereference; + expression body << Guard; + ] + | Texp_send (e1, _) -> + (* + G |- e: m[Dereference] + ---------------------- (plus weird 'eo' option) + G |- e#x: m + *) + join [ + expression e1 << Dereference + ] + | Texp_field (e, _, _) -> + (* + G |- e: m[Dereference] + ----------------------- + G |- e.x: m + *) + expression e << Dereference + | Texp_setinstvar (pth,_,_,e) -> + (* + G |- e: m[Dereference] + ---------------------- + G |- x <- e: m + *) + join [ + path pth << Dereference; + expression e << Dereference; + ] + | Texp_letexception ({ext_id}, e) -> + (* G |- e: m + ---------------------------- + G |- let exception A in e: m + *) + remove_id ext_id (expression e) + | Texp_assert (e, _) -> + (* + G |- e: m[Dereference] + ----------------------- + G |- assert e: m + + Note: `assert e` is treated just as if `assert` was a function. + *) + expression e << Dereference + | Texp_pack mexp -> + (* + G |- M: m + ---------------- + G |- module M: m + *) + modexp mexp + | Texp_object (clsstrct, _) -> + class_structure clsstrct + | Texp_try (e, cases, eff_cases) -> + (* + G |- e: m (Gi; _ |- pi -> ei : m)^i + -------------------------------------------- + G + sum(Gi)^i |- try e with (pi -> ei)^i : m + + Contrarily to match, the patterns p do not inspect + the value of e, so their mode does not influence the + mode of e. + *) + let case_env c m = fst (case c m) in + join [ + expression e; + list case_env cases; + list case_env eff_cases; + ] + | Texp_override (pth, fields) -> + (* + G |- pth : m (Gi |- ei : m[Dereference])^i + ---------------------------------------------------- + G + sum(Gi)^i |- {< (xi = ei)^i >} (at path pth) : m + + Note: {< .. >} is desugared to a function application, but + the function implementation might still use its arguments in + a guarded way only -- intuitively it should behave as a constructor. + We could possibly refine the arguments' Dereference into Guard here. + *) + let field (_, _, arg) = expression arg in + join [ + path pth << Dereference; + list field fields << Dereference; + ] + | Texp_function (params, body) -> + (* + G |-{body} b : m[Delay] + (Hj |-{def} Pj : m[Delay])^j + H := sum(Hj)^j + ps := sum(pat(Pj))^j + ----------------------------------- + G + H - ps |- fun (Pj)^j -> b : m + *) + let param_pat param = + (* param P ::= + | ?(pat = expr) + | pat + + Define pat(P) as + pat if P = ?(pat = expr) + pat if P = pat + *) + match param.fp_kind with + | Tparam_pat pat -> pat + | Tparam_optional_default (pat, _) -> pat + in + (* Optional argument defaults. + + G |-{def} P : m + *) + let param_default param = + match param.fp_kind with + | Tparam_optional_default (_, default) -> + (* + G |- e : m + ------------------ + G |-{def} ?(p=e) : m + *) + expression default + | Tparam_pat _ -> + (* + ------------------ + . |-{def} p : m + *) + empty + in + let patterns = List.map param_pat params in + let defaults = List.map param_default params in + let body = function_body body in + let f = join (body :: defaults) << Delay in + (fun m -> + let env = f m in + remove_patlist patterns env) + | Texp_lazy e -> + (* + G |- e: m[Delay] + ---------------- (modulo some subtle compiler optimizations) + G |- lazy e: m + *) + let lazy_mode = match Typeopt.classify_lazy_argument e with + | `Constant_or_function + | `Identifier _ + | `Float_that_cannot_be_shortcut -> + Return + | `Other -> + Delay + in + expression e << lazy_mode + | Texp_letop{let_; ands; body; _} -> + let case_env c m = fst (case c m) in + join [ + list binding_op (let_ :: ands) << Dereference; + case_env body << Delay + ] + | Texp_unreachable -> + (* + ---------- + [] |- .: m + *) + empty + | Texp_extension_constructor (_lid, pth) -> + path pth << Dereference + | Texp_open (od, e) -> + open_declaration od >> expression e + +(* Function bodies. + + G |-{body} b : m +*) +and function_body body = + match body with + | Tfunction_body body -> + (* + G |- e : m + ------------------ + G |-{body} e : m (**) + + (**) The "e" here stands for [Tfunction_body] as opposed to + [Tfunction_cases]. + *) + expression body + | Tfunction_cases { cases; _ } -> + (* + (Gi; _ |- pi -> ei : m)^i (**) + ------------------ + sum(Gi)^i |-{body} function (pi -> ei)^i : m + + (**) Contrarily to match, the values that are pattern-matched + are bound locally, so the pattern modes do not influence + the final environment. + *) + List.map (fun c mode -> fst (case c mode)) cases + |> join + +and binding_op : Typedtree.binding_op -> term_judg = + fun bop -> + join [path bop.bop_op_path; expression bop.bop_exp] + +and class_structure : Typedtree.class_structure -> term_judg = + fun cs -> list class_field cs.cstr_fields + +and class_field : Typedtree.class_field -> term_judg = + fun cf -> match cf.cf_desc with + | Tcf_inherit (_, ce, _super, _inh_vars, _inh_meths) -> + class_expr ce << Dereference + | Tcf_val (_lab, _mut, _, cfk, _) -> + class_field_kind cfk + | Tcf_method (_, _, cfk) -> + class_field_kind cfk + | Tcf_constraint _ -> + empty + | Tcf_initializer e -> + expression e << Dereference + | Tcf_attribute _ -> + empty + +and class_field_kind : Typedtree.class_field_kind -> term_judg = + fun cfk -> match cfk with + | Tcfk_virtual _ -> + empty + | Tcfk_concrete (_, e) -> + expression e << Dereference + +and modexp : Typedtree.module_expr -> term_judg = + fun mexp -> match mexp.mod_desc with + | Tmod_ident (pth, _) -> + path pth + | Tmod_structure s -> + structure s + | Tmod_functor (_, e) -> + modexp e << Delay + | Tmod_apply (f, p, _) -> + join [ + modexp f << Dereference; + modexp p << Dereference; + ] + | Tmod_apply_unit f -> + modexp f << Dereference + | Tmod_constraint (mexp, _, _, coe) -> + let rec coercion coe k = match coe with + | Tcoerce_none -> + k Return + | Tcoerce_structure _ + | Tcoerce_functor _ -> + (* These coercions perform a shallow copy of the input module, + by creating a new module with fields obtained by accessing + the same fields in the input module. *) + k Dereference + | Tcoerce_primitive _ -> + (* This corresponds to 'external' declarations, + and the coercion ignores its argument *) + k Ignore + | Tcoerce_alias (_, pth, coe) -> + (* Alias coercions ignore their arguments, but they evaluate + their alias module 'pth' under another coercion. *) + coercion coe (fun m -> path pth << m) + in + coercion coe (fun m -> modexp mexp << m) + | Tmod_unpack (e, _) -> + expression e + + +(* G |- pth : m *) +and path : Path.t -> term_judg = + (* + ------------ + x: m |- x: m + + G |- A: m[Dereference] + ----------------------- + G |- A.x: m + + G1 |- A: m[Dereference] + G2 |- B: m[Dereference] + ------------------------ (as for term application) + G1 + G2 |- A(B): m + *) + fun pth -> match pth with + | Path.Pident x -> + single x + | Path.Pdot (t, _) -> + path t << Dereference + | Path.Papply (f, p) -> + join [ + path f << Dereference; + path p << Dereference; + ] + | Path.Pextra_ty (p, _extra) -> + path p + +(* G |- struct ... end : m *) +and structure : Typedtree.structure -> term_judg = + (* + G1, {x: _, x in vars(G1)} |- item1: G2 + ... + Gn in m + G2, {x: _, x in vars(G2)} |- item2: G3 + ... + Gn in m + ... + Gn, {x: _, x in vars(Gn)} |- itemn: [] in m + --- + (G1 + ... + Gn) - V |- struct item1 ... itemn end: m + *) + fun s m -> + List.fold_right (fun it env -> structure_item it m env) + s.str_items Env.empty + +(* G |- : m -| G' + where G is an output and m, G' are inputs *) +and structure_item : Typedtree.structure_item -> bind_judg = + fun s m env -> match s.str_desc with + | Tstr_eval (e, _) -> + (* + Ge |- e: m[Guard] + G |- items: m -| G' + --------------------------------- + Ge + G |- (e;; items): m -| G' + + The expression `e` is treated in the same way as let _ = e + *) + let judg_e = expression e << Guard in + Env.join (judg_e m) env + | Tstr_value (rec_flag, bindings) -> + value_bindings rec_flag bindings m env + | Tstr_module {mb_id; mb_expr} -> + module_binding (mb_id, mb_expr) m env + | Tstr_recmodule mbs -> + let bindings = List.map (fun {mb_id; mb_expr} -> (mb_id, mb_expr)) mbs in + recursive_module_bindings bindings m env + | Tstr_primitive _ -> + env + | Tstr_type _ -> + (* + ------------------- + G |- type t: m -| G + *) + env + | Tstr_typext {tyext_constructors = exts; _} -> + let ext_ids = List.map (fun {ext_id = id; _} -> id) exts in + Env.join + (list extension_constructor exts m) + (Env.remove_list ext_ids env) + | Tstr_exception {tyexn_constructor = ext; _} -> + Env.join + (extension_constructor ext m) + (Env.remove ext.ext_id env) + | Tstr_modtype _ + | Tstr_class_type _ + | Tstr_attribute _ -> + env + | Tstr_open od -> + open_declaration od m env + | Tstr_class classes -> + let class_ids = + let class_id ({ci_id_class = id; _}, _) = id in + List.map class_id classes in + let class_declaration ({ci_expr; _}, _) m = + Env.remove_list class_ids (class_expr ci_expr m) in + Env.join + (list class_declaration classes m) + (Env.remove_list class_ids env) + | Tstr_include { incl_mod = mexp; incl_type = mty; _ } -> + let included_ids = List.map Types.signature_item_id mty in + Env.join (modexp mexp m) (Env.remove_list included_ids env) + +(* G |- module M = E : m -| G *) +and module_binding : (Ident.t option * Typedtree.module_expr) -> bind_judg = + fun (id, mexp) m env -> + (* + GE |- E: m[mM + Guard] + ------------------------------------- + GE + G |- module M = E : m -| M:mM, G + *) + let judg_E, env = + match id with + | None -> modexp mexp << Guard, env + | Some id -> + let mM, env = Env.take id env in + let judg_E = modexp mexp << (Mode.join mM Guard) in + judg_E, env + in + Env.join (judg_E m) env + +and open_declaration : Typedtree.open_declaration -> bind_judg = + fun { open_expr = mexp; open_bound_items = sg; _ } m env -> + let judg_E = modexp mexp in + let bound_ids = List.map Types.signature_item_id sg in + Env.join (judg_E m) (Env.remove_list bound_ids env) + +and recursive_module_bindings + : (Ident.t option * Typedtree.module_expr) list -> bind_judg = + fun m_bindings m env -> + let mids = List.filter_map fst m_bindings in + let binding (mid, mexp) m = + let judg_E = + match mid with + | None -> modexp mexp << Guard + | Some mid -> + let mM = Env.find mid env in + modexp mexp << (Mode.join mM Guard) + in + Env.remove_list mids (judg_E m) + in + Env.join (list binding m_bindings m) (Env.remove_list mids env) + +and class_expr : Typedtree.class_expr -> term_judg = + fun ce -> match ce.cl_desc with + | Tcl_ident (pth, _, _) -> + path pth << Dereference + | Tcl_structure cs -> + class_structure cs + | Tcl_fun (_, _, args, ce, _) -> + let ids = List.map fst args in + remove_ids ids (class_expr ce << Delay) + | Tcl_apply (ce, args) -> + let arg (_label, eo) = option expression eo in + join [ + class_expr ce << Dereference; + list arg args << Dereference; + ] + | Tcl_let (rec_flag, bindings, _, ce) -> + value_bindings rec_flag bindings >> class_expr ce + | Tcl_constraint (ce, _, _, _, _) -> + class_expr ce + | Tcl_open (_, ce) -> + class_expr ce + +and extension_constructor : Typedtree.extension_constructor -> term_judg = + fun ec -> match ec.ext_kind with + | Text_decl _ -> + empty + | Text_rebind (pth, _lid) -> + path pth + +(* G |- let (rec?) (pi = ei)^i : m -| G' *) +and value_bindings : rec_flag -> Typedtree.value_binding list -> bind_judg = + fun rec_flag bindings mode bound_env -> + let all_bound_pats = List.map (fun vb -> vb.vb_pat) bindings in + let outer_env = remove_patlist all_bound_pats bound_env in + let bindings_env = + match rec_flag with + | Nonrecursive -> + (* + (Gi, pi:_ |- ei : m[mbody_i])^i (pi : mbody_i -| D)^i + ------------------------------------------------------------ + Sum(Gi) + (D - (pi)^i) |- let (pi=ei)^i : m -| D + *) + let binding_env {vb_pat; vb_expr; _} m = + let m' = Mode.compose m (pattern vb_pat bound_env) in + remove_pat vb_pat (expression vb_expr m') in + list binding_env bindings mode + | Recursive -> + (* + (Gi, (xj : mdef_ij)^j |- ei : m[mbody_i])^i (xi : mbody_i -| D)^i + G'i = Gi + mdef_ij[G'j] + ------------------------------------------------------------------- + Sum(G'i) + (D - (pi)^i) |- let rec (xi=ei)^i : m -| D + + The (mdef_ij)^i,j are a family of modes over two indices: + mdef_ij represents the mode of use, within e_i the definition of x_i, + of the mutually-recursive variable x_j. + + The (G'i)^i are defined from the (Gi)^i as a family of equations, + whose smallest solution is computed as a least fixpoint. + + The (Gi)^i are the "immediate" dependencies of each (ei)^i + on the outer context (excluding the mutually-defined + variables). + The (G'i)^i contain the "transitive" dependencies as well: + if ei depends on xj, then the dependencies of G'i of xi + must contain the dependencies of G'j, composed by + the mode mdef_ij of use of xj in ei. + + For example, consider: + + let rec z = + let rec x = ref y + and y = ref z + in f x + + this definition should be rejected as the body [f x] + dereferences [x], which can be used to access the + yet-unitialized value [z]. This requires realizing that [x] + depends on [z] through [y], which requires the transitive + closure computation. + + An earlier version of our check would take only the (Gi)^i + instead of the (G'i)^i, which is incorrect and would accept + the example above. + *) + (* [binding_env] takes a binding (x_i = e_i) + and computes (Gi, (mdef_ij)^j). *) + let binding_env {vb_pat = x_i; vb_expr = e_i; _} = + let mbody_i = pattern x_i bound_env in + (* Gi, (x_j:mdef_ij)^j *) + let rhs_env_i = expression e_i (Mode.compose mode mbody_i) in + (* (mdef_ij)^j (for a fixed i) *) + let mutual_modes = + let mdef_ij {vb_pat = x_j; _} = pattern x_j rhs_env_i in + List.map mdef_ij bindings in + (* Gi *) + let env_i = remove_patlist all_bound_pats rhs_env_i in + (* (Gi, (mdef_ij)^j) *) + (env_i, mutual_modes) in + let env, mdef = + List.split (List.map binding_env bindings) in + let rec transitive_closure env = + let transitive_deps env_i mdef_i = + (* Gi, (mdef_ij)^j => Gi + Sum_j mdef_ij[Gj] *) + Env.join env_i + (Env.join_list (List.map2 Env.compose mdef_i env)) in + let env' = List.map2 transitive_deps env mdef in + if List.for_all2 Env.equal env env' + then env' + else transitive_closure env' + in + let env'_i = transitive_closure env in + Env.join_list env'_i + in Env.join bindings_env outer_env + +(* G; m' |- (p -> e) : m + with outputs G, m' and input m + + m' is the mode under which the scrutinee of p + (the value matched against p) is placed. +*) +and case + : 'k . 'k Typedtree.case -> mode -> Env.t * mode + = fun { Typedtree.c_lhs; c_guard; c_rhs } -> + (* + Ge |- e : m Gg |- g : m[Dereference] + G := Ge+Gg p : mp -| G + ---------------------------------------- + G - p; m[mp] |- (p (when g)? -> e) : m + *) + let judg = join [ + option expression c_guard << Dereference; + expression c_rhs; + ] in + (fun m -> + let env = judg m in + (remove_pat c_lhs env), Mode.compose m (pattern c_lhs env)) + +(* p : m -| G + with output m and input G + + m is the mode under which the scrutinee of p is placed. +*) +and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env -> + (* + mp := | Dereference if p is destructuring + | Guard otherwise + me := sum{G(x), x in vars(p)} + -------------------------------------------- + p : (mp + me) -| G + *) + let m_pat = if is_destructuring_pattern pat + then Dereference + else Guard + in + let m_env = + pat_bound_idents pat + |> List.map (fun id -> Env.find id env) + |> List.fold_left Mode.join Ignore + in + Mode.join m_pat m_env + +and is_destructuring_pattern : type k . k general_pattern -> bool = + fun pat -> match pat.pat_desc with + | Tpat_any -> false + | Tpat_var (_, _, _) -> false + | Tpat_alias (pat, _, _, _) -> is_destructuring_pattern pat + | Tpat_constant _ -> true + | Tpat_tuple _ -> true + | Tpat_construct _ -> true + | Tpat_variant _ -> true + | Tpat_record (_, _) -> true + | Tpat_array _ -> true + | Tpat_lazy _ -> true + | Tpat_value pat -> is_destructuring_pattern (pat :> pattern) + | Tpat_exception _ -> false + | Tpat_or (l,r,_) -> + is_destructuring_pattern l || is_destructuring_pattern r + +let is_valid_recursive_expression idlist expr : sd option = + match expr.exp_desc with + | Texp_function _ -> + (* Fast path: functions can never have invalid recursive references *) + Some Static + | _ -> + let rkind = classify_expression expr in + let is_valid = + match rkind with + | Static -> + (* The expression has known size or is constant *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] + | Dynamic -> + (* The expression has unknown size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] + in + if is_valid then Some rkind else None + +(* A class declaration may contain let-bindings. If they are recursive, + their validity will already be checked by [is_valid_recursive_expression] + during type-checking. This function here prevents a different kind of + invalid recursion, which is the unsafe creations of objects of this class + in the let-binding. For example, + {|class a = let x = new a in object ... end|} + is forbidden, but + {|class a = let x () = new a in object ... end|} + is allowed. +*) +let is_valid_class_expr idlist ce = + let rec class_expr : mode -> Typedtree.class_expr -> Env.t = + fun mode ce -> match ce.cl_desc with + | Tcl_ident (_, _, _) -> + (* + ---------- + [] |- a: m + *) + Env.empty + | Tcl_structure _ -> + (* + ----------------------- + [] |- struct ... end: m + *) + Env.empty + | Tcl_fun (_, _, _, _, _) -> Env.empty + (* + --------------------------- + [] |- fun x1 ... xn -> C: m + *) + | Tcl_apply (_, _) -> Env.empty + | Tcl_let (rec_flag, bindings, _, ce) -> + value_bindings rec_flag bindings mode (class_expr mode ce) + | Tcl_constraint (ce, _, _, _, _) -> + class_expr mode ce + | Tcl_open (_, ce) -> + class_expr mode ce + in + match Env.unguarded (class_expr Return ce) idlist with + | [] -> true + | _ :: _ -> false diff --git a/upstream/ocaml_503/typing/value_rec_check.mli b/upstream/ocaml_503/typing/value_rec_check.mli new file mode 100644 index 000000000..8010e7c92 --- /dev/null +++ b/upstream/ocaml_503/typing/value_rec_check.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremy Yallop, University of Cambridge *) +(* *) +(* Copyright 2017 Jeremy Yallop *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val is_valid_recursive_expression : + Ident.t list -> + Typedtree.expression -> + Value_rec_types.recursive_binding_kind option + +val is_valid_class_expr : Ident.t list -> Typedtree.class_expr -> bool diff --git a/upstream/ocaml_503/typing/value_rec_types.mli b/upstream/ocaml_503/typing/value_rec_types.mli new file mode 100644 index 000000000..a907935cc --- /dev/null +++ b/upstream/ocaml_503/typing/value_rec_types.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Vincent Laviron, OCamlPro *) +(* *) +(* Copyright 2023 OCamlPro, SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Types related to the compilation of value let-recs (non-functional + recursive definitions) *) + +(** The kind of recursive bindings, as computed by + [Value_rec_check.classify_expression] *) +type recursive_binding_kind = +| Static + (** Bindings for which some kind of pre-allocation scheme is possible. + The expression is allowed to be recursive, as long as its definition does + not inspect recursively defined values. *) +| Dynamic + (** Bindings for which pre-allocation is not possible. + The expression is not allowed to refer to any recursive variable. *) diff --git a/upstream/ocaml_503/utils/arg_helper.ml b/upstream/ocaml_503/utils/arg_helper.ml new file mode 100644 index 000000000..fa80007ad --- /dev/null +++ b/upstream/ocaml_503/utils/arg_helper.ml @@ -0,0 +1,127 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2015--2016 OCamlPro SAS *) +(* Copyright 2015--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +let fatal err = + prerr_endline err; + exit 2 + +module Make (S : sig + module Key : sig + type t + val of_string : string -> t + module Map : Map.S with type key = t + end + + module Value : sig + type t + val of_string : string -> t + end +end) = struct + type parsed = { + base_default : S.Value.t; + base_override : S.Value.t S.Key.Map.t; + user_default : S.Value.t option; + user_override : S.Value.t S.Key.Map.t; + } + + let default v = + { base_default = v; + base_override = S.Key.Map.empty; + user_default = None; + user_override = S.Key.Map.empty; } + + let set_base_default value t = + { t with base_default = value } + + let add_base_override key value t = + { t with base_override = S.Key.Map.add key value t.base_override } + + let reset_base_overrides t = + { t with base_override = S.Key.Map.empty } + + let set_user_default value t = + { t with user_default = Some value } + + let add_user_override key value t = + { t with user_override = S.Key.Map.add key value t.user_override } + + exception Parse_failure of exn + + let parse_exn str ~update = + (* Is the removal of empty chunks really relevant here? *) + (* (It has been added to mimic the old Misc.String.split.) *) + let values = String.split_on_char ',' str |> List.filter ((<>) "") in + let parsed = + List.fold_left (fun acc value -> + match String.index value '=' with + | exception Not_found -> + begin match S.Value.of_string value with + | value -> set_user_default value acc + | exception exn -> raise (Parse_failure exn) + end + | equals -> + let key_value_pair = value in + let length = String.length key_value_pair in + assert (equals >= 0 && equals < length); + if equals = 0 then begin + raise (Parse_failure ( + Failure "Missing key in argument specification")) + end; + let key = + let key = String.sub key_value_pair 0 equals in + try S.Key.of_string key + with exn -> raise (Parse_failure exn) + in + let value = + let value = + String.sub key_value_pair (equals + 1) (length - equals - 1) + in + try S.Value.of_string value + with exn -> raise (Parse_failure exn) + in + add_user_override key value acc) + !update + values + in + update := parsed + + let parse str help_text update = + match parse_exn str ~update with + | () -> () + | exception (Parse_failure exn) -> + fatal (Printf.sprintf "%s: %s" (Printexc.to_string exn) help_text) + + type parse_result = + | Ok + | Parse_failed of exn + + let parse_no_error str update = + match parse_exn str ~update with + | () -> Ok + | exception (Parse_failure exn) -> Parse_failed exn + + let get ~key parsed = + match S.Key.Map.find key parsed.user_override with + | value -> value + | exception Not_found -> + match parsed.user_default with + | Some value -> value + | None -> + match S.Key.Map.find key parsed.base_override with + | value -> value + | exception Not_found -> parsed.base_default + +end diff --git a/upstream/ocaml_503/utils/arg_helper.mli b/upstream/ocaml_503/utils/arg_helper.mli new file mode 100644 index 000000000..18f60fea5 --- /dev/null +++ b/upstream/ocaml_503/utils/arg_helper.mli @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2015--2016 OCamlPro SAS *) +(* Copyright 2015--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Decipher command line arguments of the form + | =[,...] + + (as used for example for the specification of inlining parameters + varying by simplification round). + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +module Make (S : sig + module Key : sig + type t + + (** The textual representation of a key must not contain '=' or ','. *) + val of_string : string -> t + + module Map : Map.S with type key = t + end + + module Value : sig + type t + + (** The textual representation of a value must not contain ','. *) + val of_string : string -> t + end +end) : sig + type parsed + + val default : S.Value.t -> parsed + + val set_base_default : S.Value.t -> parsed -> parsed + + val add_base_override : S.Key.t -> S.Value.t -> parsed -> parsed + + val reset_base_overrides : parsed -> parsed + + val set_user_default : S.Value.t -> parsed -> parsed + + val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed + + val parse : string -> string -> parsed ref -> unit + + type parse_result = + | Ok + | Parse_failed of exn + + val parse_no_error : string -> parsed ref -> parse_result + + val get : key:S.Key.t -> parsed -> S.Value.t +end diff --git a/upstream/ocaml_503/utils/binutils.ml b/upstream/ocaml_503/utils/binutils.ml new file mode 100644 index 000000000..916d14d02 --- /dev/null +++ b/upstream/ocaml_503/utils/binutils.ml @@ -0,0 +1,684 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +let char_to_hex c = + Printf.sprintf "0x%02x" (Char.code c) + +let int_to_hex n = + Printf.sprintf "0x%x" n + +type error = + | Truncated_file + | Unrecognized of string + | Unsupported of string * int64 + | Out_of_range of string + +let error_to_string = function + | Truncated_file -> + "Truncated file" + | Unrecognized magic -> + Printf.sprintf "Unrecognized magic: %s" + (String.concat " " + (List.init (String.length magic) + (fun i -> char_to_hex magic.[i]))) + | Unsupported (s, n) -> + Printf.sprintf "Unsupported: %s: 0x%Lx" s n + | Out_of_range s -> + Printf.sprintf "Out of range constant: %s" s + +exception Error of error + +let name_at ?max_len buf start = + if start < 0 || start > Bytes.length buf then + raise (Error (Out_of_range (int_to_hex start))); + let max_pos = + match max_len with + | None -> Bytes.length buf + | Some n -> Int.min (Bytes.length buf) (start + n) + in + let rec loop pos = + if pos >= max_pos || Bytes.get buf pos = '\000' + then + Bytes.sub_string buf start (pos - start) + else + loop (succ pos) + in + loop start + +let array_find_map f a = + let rec loop i = + if i >= Array.length a then None + else begin + match f a.(i) with + | None -> loop (succ i) + | Some _ as r -> r + end + in + loop 0 + +let array_find f a = + array_find_map (fun x -> if f x then Some x else None) a + +let really_input_bytes ic len = + let buf = Bytes.create len in + really_input ic buf 0 len; + buf + +let uint64_of_uint32 n = + Int64.(logand (of_int32 n) 0xffffffffL) + +type endianness = + | LE + | BE + +type bitness = + | B32 + | B64 + +type decoder = + { + ic: in_channel; + endianness: endianness; + bitness: bitness; + } + +let word_size = function + | {bitness = B64; _} -> 8 + | {bitness = B32; _} -> 4 + +let get_uint16 {endianness; _} buf idx = + match endianness with + | LE -> Bytes.get_uint16_le buf idx + | BE -> Bytes.get_uint16_be buf idx + +let get_uint32 {endianness; _} buf idx = + match endianness with + | LE -> Bytes.get_int32_le buf idx + | BE -> Bytes.get_int32_be buf idx + +let get_uint s d buf idx = + let n = get_uint32 d buf idx in + match Int32.unsigned_to_int n with + | None -> raise (Error (Unsupported (s, Int64.of_int32 n))) + | Some n -> n + +let get_uint64 {endianness; _} buf idx = + match endianness with + | LE -> Bytes.get_int64_le buf idx + | BE -> Bytes.get_int64_be buf idx + +let get_word d buf idx = + match d.bitness with + | B64 -> get_uint64 d buf idx + | B32 -> uint64_of_uint32 (get_uint32 d buf idx) + +let uint64_to_int s n = + match Int64.unsigned_to_int n with + | None -> raise (Error (Unsupported (s, n))) + | Some n -> n + +let load_bytes d off len = + LargeFile.seek_in d.ic off; + really_input_bytes d.ic len + +type t = + { + defines_symbol: string -> bool; + symbol_offset: string -> int64 option; + } + +module ELF = struct + + (* Reference: http://man7.org/linux/man-pages/man5/elf.5.html *) + + let header_size d = + 40 + 3 * word_size d + + type header = + { + e_shoff: int64; + e_shentsize: int; + e_shnum: int; + e_shstrndx: int; + } + + let read_header d = + let buf = load_bytes d 0L (header_size d) in + let word_size = word_size d in + let e_shnum = get_uint16 d buf (36 + 3 * word_size) in + let e_shentsize = get_uint16 d buf (34 + 3 * word_size) in + let e_shoff = get_word d buf (24 + 2 * word_size) in + let e_shstrndx = get_uint16 d buf (38 + 3 * word_size) in + {e_shnum; e_shentsize; e_shoff; e_shstrndx} + + type sh_type = + | SHT_STRTAB + | SHT_DYNSYM + | SHT_OTHER + + type section = + { + sh_name: int; + sh_type: sh_type; + sh_addr: int64; + sh_offset: int64; + sh_size: int; + sh_entsize: int; + sh_name_str: string; + } + + let load_section_body d {sh_offset; sh_size; _} = + load_bytes d sh_offset sh_size + + let read_sections d {e_shoff; e_shnum; e_shentsize; e_shstrndx; _} = + let buf = load_bytes d e_shoff (e_shnum * e_shentsize) in + let word_size = word_size d in + let mk i = + let base = i * e_shentsize in + let sh_name = get_uint "sh_name" d buf (base + 0) in + let sh_type = + match get_uint32 d buf (base + 4) with + | 3l -> SHT_STRTAB + | 11l -> SHT_DYNSYM + | _ -> SHT_OTHER + in + let sh_addr = get_word d buf (base + 8 + word_size) in + let sh_offset = get_word d buf (base + 8 + 2 * word_size) in + let sh_size = + uint64_to_int "sh_size" + (get_word d buf (base + 8 + 3 * word_size)) + in + let sh_entsize = + uint64_to_int "sh_entsize" + (get_word d buf (base + 16 + 5 * word_size)) + in + {sh_name; sh_type; sh_addr; sh_offset; + sh_size; sh_entsize; sh_name_str = ""} + in + let sections = Array.init e_shnum mk in + if e_shstrndx = 0 then + (* no string table *) + sections + else + let shstrtbl = load_section_body d sections.(e_shstrndx) in + let set_name sec = + let sh_name_str = name_at shstrtbl sec.sh_name in + {sec with sh_name_str} + in + Array.map set_name sections + + let read_sections d h = + let {e_shoff; e_shentsize; e_shnum; e_shstrndx} = h in + if e_shoff = 0L then + [||] + else begin + let buf = lazy (load_bytes d e_shoff e_shentsize) in + let word_size = word_size d in + let e_shnum = + if e_shnum = 0 then + (* The real e_shnum is the sh_size of the initial section.*) + uint64_to_int "e_shnum" + (get_word d (Lazy.force buf) (8 + 3 * word_size)) + else + e_shnum + in + let e_shstrndx = + if e_shstrndx = 0xffff then + (* The real e_shstrndx is the sh_link of the initial section. *) + get_uint "e_shstrndx" d (Lazy.force buf) (8 + 4 * word_size) + else + e_shstrndx + in + read_sections d {h with e_shnum; e_shstrndx} + end + + type symbol = + { + st_name: string; + st_value: int64; + st_shndx: int; + } + + let find_section sections type_ sectname = + let f {sh_type; sh_name_str; _} = + sh_type = type_ && sh_name_str = sectname + in + array_find f sections + + let read_symbols d sections = + match find_section sections SHT_DYNSYM ".dynsym" with + | None -> [| |] + | Some {sh_entsize = 0; _} -> + raise (Error (Out_of_range "sh_entsize=0")) + | Some dynsym -> + begin match find_section sections SHT_STRTAB ".dynstr" with + | None -> [| |] + | Some dynstr -> + let strtbl = load_section_body d dynstr in + let buf = load_section_body d dynsym in + let word_size = word_size d in + let mk i = + let base = i * dynsym.sh_entsize in + let st_name = name_at strtbl (get_uint "st_name" d buf base) in + let st_value = get_word d buf (base + word_size (* ! *)) in + let st_shndx = + let off = match d.bitness with B64 -> 6 | B32 -> 14 in + get_uint16 d buf (base + off) + in + {st_name; st_value; st_shndx} + in + Array.init (dynsym.sh_size / dynsym.sh_entsize) mk + end + + let find_symbol symbols symname = + let f = function + | {st_shndx = 0; _} -> false + | {st_name; _} -> st_name = symname + in + array_find f symbols + + let symbol_offset sections symbols symname = + match find_symbol symbols symname with + | None -> + None + | Some {st_shndx; st_value; _} -> + (* st_value in executables and shared objects holds a virtual (absolute) + address. See https://refspecs.linuxfoundation.org/elf/elf.pdf, page + 1-21, "Symbol Values". *) + Some Int64.(add sections.(st_shndx).sh_offset + (sub st_value sections.(st_shndx).sh_addr)) + + let defines_symbol symbols symname = + Option.is_some (find_symbol symbols symname) + + let read ic = + seek_in ic 0; + let identification = really_input_bytes ic 16 in + let bitness = + match Bytes.get identification 4 with + | '\x01' -> B32 + | '\x02' -> B64 + | _ as c -> + raise (Error (Unsupported ("ELFCLASS", Int64.of_int (Char.code c)))) + in + let endianness = + match Bytes.get identification 5 with + | '\x01' -> LE + | '\x02' -> BE + | _ as c -> + raise (Error (Unsupported ("ELFDATA", Int64.of_int (Char.code c)))) + in + let d = {ic; bitness; endianness} in + let header = read_header d in + let sections = read_sections d header in + let symbols = read_symbols d sections in + let symbol_offset = symbol_offset sections symbols in + let defines_symbol = defines_symbol symbols in + {symbol_offset; defines_symbol} +end + +module Mach_O = struct + + (* Reference: + https://github.com/aidansteele/osx-abi-macho-file-format-reference *) + + let size_int = 4 + + let header_size {bitness; _} = + (match bitness with B64 -> 6 | B32 -> 5) * 4 + 2 * size_int + + type header = + { + ncmds: int; + sizeofcmds: int; + } + + let read_header d = + let buf = load_bytes d 0L (header_size d) in + let ncmds = get_uint "ncmds" d buf (8 + 2 * size_int) in + let sizeofcmds = get_uint "sizeofcmds" d buf (12 + 2 * size_int) in + {ncmds; sizeofcmds} + + type lc_symtab = + { + symoff: int32; + nsyms: int; + stroff: int32; + strsize: int; + } + + type load_command = + | LC_SYMTAB of lc_symtab + | OTHER + + let read_load_commands d {ncmds; sizeofcmds} = + let buf = load_bytes d (Int64.of_int (header_size d)) sizeofcmds in + let base = ref 0 in + let mk _ = + let cmd = get_uint32 d buf (!base + 0) in + let cmdsize = get_uint "cmdsize" d buf (!base + 4) in + let lc = + match cmd with + | 0x2l -> + let symoff = get_uint32 d buf (!base + 8) in + let nsyms = get_uint "nsyms" d buf (!base + 12) in + let stroff = get_uint32 d buf (!base + 16) in + let strsize = get_uint "strsize" d buf (!base + 20) in + LC_SYMTAB {symoff; nsyms; stroff; strsize} + | _ -> + OTHER + in + base := !base + cmdsize; + lc + in + Array.init ncmds mk + + type symbol = + { + n_name: string; + n_type: int; + n_value: int64; + } + + let size_nlist d = + 8 + word_size d + + let read_symbols d load_commands = + match + (* Can it happen there be more than one LC_SYMTAB? *) + array_find_map (function + | LC_SYMTAB symtab -> Some symtab + | _ -> None + ) load_commands + with + | None -> [| |] + | Some {symoff; nsyms; stroff; strsize} -> + let strtbl = load_bytes d (uint64_of_uint32 stroff) strsize in + let buf = + load_bytes d (uint64_of_uint32 symoff) (nsyms * size_nlist d) in + let size_nlist = size_nlist d in + let mk i = + let base = i * size_nlist in + let n_name = name_at strtbl (get_uint "n_name" d buf (base + 0)) in + let n_type = Bytes.get_uint8 buf (base + 4) in + let n_value = get_word d buf (base + 8) in + {n_name; n_type; n_value} + in + Array.init nsyms mk + + let fix symname = + "_" ^ symname + + let find_symbol symbols symname = + let f {n_name; n_type; _} = + n_type land 0b1111 = 0b1111 (* N_EXT + N_SECT *) && + n_name = symname + in + array_find f symbols + + let symbol_offset symbols symname = + let symname = fix symname in + match find_symbol symbols symname with + | None -> None + | Some {n_value; _} -> Some n_value + + let defines_symbol symbols symname = + let symname = fix symname in + Option.is_some (find_symbol symbols symname) + + type magic = + | MH_MAGIC + | MH_CIGAM + | MH_MAGIC_64 + | MH_CIGAM_64 + + let read ic = + seek_in ic 0; + let magic = really_input_bytes ic 4 in + let magic = + match Bytes.get_int32_ne magic 0 with + | 0xFEEDFACEl -> MH_MAGIC + | 0xCEFAEDFEl -> MH_CIGAM + | 0xFEEDFACFl -> MH_MAGIC_64 + | 0xCFFAEDFEl -> MH_CIGAM_64 + | _ -> (* should not happen *) + raise (Error (Unrecognized (Bytes.to_string magic))) + in + let bitness = + match magic with + | MH_MAGIC | MH_CIGAM -> B32 + | MH_MAGIC_64 | MH_CIGAM_64 -> B64 + in + let endianness = + match magic, Sys.big_endian with + | (MH_MAGIC | MH_MAGIC_64), false + | (MH_CIGAM | MH_CIGAM_64), true -> LE + | (MH_MAGIC | MH_MAGIC_64), true + | (MH_CIGAM | MH_CIGAM_64), false -> BE + in + let d = {ic; endianness; bitness} in + let header = read_header d in + let load_commands = read_load_commands d header in + let symbols = read_symbols d load_commands in + let symbol_offset = symbol_offset symbols in + let defines_symbol = defines_symbol symbols in + {symbol_offset; defines_symbol} +end + +module FlexDLL = struct + + (* Reference: + https://docs.microsoft.com/en-us/windows/win32/debug/pe-format *) + + let header_size = 24 + + type header = + { + e_lfanew: int64; + number_of_sections: int; + size_of_optional_header: int; + _characteristics: int; + } + + let read_header e_lfanew d buf = + let number_of_sections = get_uint16 d buf 6 in + let size_of_optional_header = get_uint16 d buf 20 in + let _characteristics = get_uint16 d buf 22 in + {e_lfanew; number_of_sections; size_of_optional_header; _characteristics} + + type optional_header_magic = + | PE32 + | PE32PLUS + + type optional_header = + { + _magic: optional_header_magic; + image_base: int64; + } + + let read_optional_header d {e_lfanew; size_of_optional_header; _} = + if size_of_optional_header = 0 then + raise (Error (Unrecognized "SizeOfOptionalHeader=0")); + let buf = + load_bytes d Int64.(add e_lfanew (of_int header_size)) + size_of_optional_header + in + let _magic, image_base = + match get_uint16 d buf 0 with + | 0x10b -> PE32, uint64_of_uint32 (get_uint32 d buf 28) + | 0x20b -> PE32PLUS, get_uint64 d buf 24 + | n -> + raise (Error (Unsupported ("optional_header_magic", Int64.of_int n))) + in + {_magic; image_base} + + type section = + { + name: string; + _virtual_size: int; + virtual_address: int64; + size_of_raw_data: int; + pointer_to_raw_data: int64; + } + + let section_header_size = 40 + + let read_sections d + {e_lfanew; number_of_sections; size_of_optional_header; _} = + let buf = + load_bytes d + Int64.(add e_lfanew (of_int (header_size + size_of_optional_header))) + (number_of_sections * section_header_size) + in + let mk i = + let base = i * section_header_size in + let name = name_at ~max_len:8 buf (base + 0) in + let _virtual_size = get_uint "virtual_size" d buf (base + 8) in + let virtual_address = uint64_of_uint32 (get_uint32 d buf (base + 12)) in + let size_of_raw_data = get_uint "size_of_raw_data" d buf (base + 16) in + let pointer_to_raw_data = + uint64_of_uint32 (get_uint32 d buf (base + 20)) in + {name; _virtual_size; virtual_address; + size_of_raw_data; pointer_to_raw_data} + in + Array.init number_of_sections mk + + type symbol = + { + name: string; + address: int64; + } + + let load_section_body d {size_of_raw_data; pointer_to_raw_data; _} = + load_bytes d pointer_to_raw_data size_of_raw_data + + let find_section sections sectname = + array_find (function ({name; _} : section) -> name = sectname) sections + + (* We extract the list of exported symbols as encoded by flexlink, see + https://github.com/ocaml/flexdll/blob/bd636def70d941674275b2f4b6c13a34ba23f9c9/reloc.ml + #L500-L525 *) + + let read_symbols d {image_base; _} sections = + match find_section sections ".exptbl" with + | None -> [| |] + | Some ({virtual_address; _} as exptbl) -> + let buf = load_section_body d exptbl in + let numexports = + uint64_to_int "numexports" (get_word d buf 0) + in + let word_size = word_size d in + let mk i = + let address = get_word d buf (word_size * (2 * i + 1)) in + let nameoff = get_word d buf (word_size * (2 * i + 2)) in + let name = + let off = Int64.(sub nameoff (add virtual_address image_base)) in + name_at buf (uint64_to_int "exptbl name offset" off) + in + {name; address} + in + Array.init numexports mk + + let symbol_offset {image_base; _} sections symbols = + match find_section sections ".data" with + | None -> Fun.const None + | Some {virtual_address; pointer_to_raw_data; _} -> + fun symname -> + begin match + array_find (function {name; _} -> name = symname) symbols + with + | None -> None + | Some {address; _} -> + Some Int64.(add pointer_to_raw_data + (sub address (add virtual_address image_base))) + end + + let defines_symbol symbols symname = + Array.exists (fun {name; _} -> name = symname) symbols + + type machine_type = + | IMAGE_FILE_MACHINE_ARM + | IMAGE_FILE_MACHINE_ARM64 + | IMAGE_FILE_MACHINE_AMD64 + | IMAGE_FILE_MACHINE_I386 + + let read ic = + let e_lfanew = + seek_in ic 0x3c; + let buf = really_input_bytes ic 4 in + uint64_of_uint32 (Bytes.get_int32_le buf 0) + in + LargeFile.seek_in ic e_lfanew; + let buf = really_input_bytes ic header_size in + let magic = Bytes.sub_string buf 0 4 in + if magic <> "PE\000\000" then raise (Error (Unrecognized magic)); + let machine = + match Bytes.get_uint16_le buf 4 with + | 0x1c0 -> IMAGE_FILE_MACHINE_ARM + | 0xaa64 -> IMAGE_FILE_MACHINE_ARM64 + | 0x8664 -> IMAGE_FILE_MACHINE_AMD64 + | 0x14c -> IMAGE_FILE_MACHINE_I386 + | n -> raise (Error (Unsupported ("MACHINETYPE", Int64.of_int n))) + in + let bitness = + match machine with + | IMAGE_FILE_MACHINE_AMD64 + | IMAGE_FILE_MACHINE_ARM64 -> B64 + | IMAGE_FILE_MACHINE_I386 + | IMAGE_FILE_MACHINE_ARM -> B32 + in + let d = {ic; endianness = LE; bitness} in + let header = read_header e_lfanew d buf in + let opt_header = read_optional_header d header in + let sections = read_sections d header in + let symbols = read_symbols d opt_header sections in + let symbol_offset = symbol_offset opt_header sections symbols in + let defines_symbol = defines_symbol symbols in + {symbol_offset; defines_symbol} +end + +let read ic = + seek_in ic 0; + let magic = really_input_string ic 4 in + match magic.[0], magic.[1], magic.[2], magic.[3] with + | '\x7F', 'E', 'L', 'F' -> + ELF.read ic + | '\xFE', '\xED', '\xFA', '\xCE' + | '\xCE', '\xFA', '\xED', '\xFE' + | '\xFE', '\xED', '\xFA', '\xCF' + | '\xCF', '\xFA', '\xED', '\xFE' -> + Mach_O.read ic + | 'M', 'Z', _, _ -> + FlexDLL.read ic + | _ -> + raise (Error (Unrecognized magic)) + +let with_open_in fn f = + let ic = open_in_bin fn in + Fun.protect ~finally:(fun () -> close_in_noerr ic) (fun () -> f ic) + +let read filename = + match with_open_in filename read with + | t -> Ok t + | exception End_of_file -> + Result.Error Truncated_file + | exception Error err -> + Result.Error err + +let defines_symbol {defines_symbol; _} symname = + defines_symbol symname + +let symbol_offset {symbol_offset; _} symname = + symbol_offset symname diff --git a/upstream/ocaml_503/utils/binutils.mli b/upstream/ocaml_503/utils/binutils.mli new file mode 100644 index 000000000..44e17fec3 --- /dev/null +++ b/upstream/ocaml_503/utils/binutils.mli @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type error = + | Truncated_file + | Unrecognized of string + | Unsupported of string * int64 + | Out_of_range of string + +val error_to_string: error -> string + +type t + +val read: string -> (t, error) Result.t + +val defines_symbol: t -> string -> bool + +val symbol_offset: t -> string -> int64 option diff --git a/upstream/ocaml_503/utils/build_path_prefix_map.ml b/upstream/ocaml_503/utils/build_path_prefix_map.ml new file mode 100644 index 000000000..17cfac82e --- /dev/null +++ b/upstream/ocaml_503/utils/build_path_prefix_map.ml @@ -0,0 +1,118 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type path = string +type path_prefix = string +type error_message = string + +let errorf fmt = Printf.ksprintf (fun err -> Error err) fmt + +let encode_prefix str = + let buf = Buffer.create (String.length str) in + let push_char = function + | '%' -> Buffer.add_string buf "%#" + | '=' -> Buffer.add_string buf "%+" + | ':' -> Buffer.add_string buf "%." + | c -> Buffer.add_char buf c + in + String.iter push_char str; + Buffer.contents buf + +let decode_prefix str = + let buf = Buffer.create (String.length str) in + let rec loop i = + if i >= String.length str + then Ok (Buffer.contents buf) + else match str.[i] with + | ('=' | ':') as c -> + errorf "invalid character '%c' in key or value" c + | '%' -> + let push c = Buffer.add_char buf c; loop (i + 2) in + if i + 1 = String.length str then + errorf "invalid encoded string %S (trailing '%%')" str + else begin match str.[i + 1] with + | '#' -> push '%' + | '+' -> push '=' + | '.' -> push ':' + | c -> errorf "invalid %%-escaped character '%c'" c + end + | c -> + Buffer.add_char buf c; + loop (i + 1) + in loop 0 + +type pair = { target: path_prefix; source : path_prefix } + +let encode_pair { target; source } = + String.concat "=" [encode_prefix target; encode_prefix source] + +let decode_pair str = + match String.index str '=' with + | exception Not_found -> + errorf "invalid key/value pair %S, no '=' separator" str + | equal_pos -> + let encoded_target = String.sub str 0 equal_pos in + let encoded_source = + String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in + match decode_prefix encoded_target, decode_prefix encoded_source with + | Ok target, Ok source -> Ok { target; source } + | ((Error _ as err), _) | (_, (Error _ as err)) -> err + +type map = pair option list + +let encode_map map = + let encode_elem = function + | None -> "" + | Some pair -> encode_pair pair + in + List.map encode_elem map + |> String.concat ":" + +let decode_map str = + let exception Shortcut of error_message in + let decode_or_empty = function + | "" -> None + | pair -> + begin match decode_pair pair with + | Ok str -> Some str + | Error err -> raise (Shortcut err) + end + in + let pairs = String.split_on_char ':' str in + match List.map decode_or_empty pairs with + | exception (Shortcut err) -> Error err + | map -> Ok map + +let make_target path : pair option -> path option = function + | None -> None + | Some { target; source } -> + let is_prefix = + String.length source <= String.length path + && String.equal source (String.sub path 0 (String.length source)) in + if is_prefix then + Some (target ^ (String.sub path (String.length source) + (String.length path - String.length source))) + else None + +let rewrite_first prefix_map path = + List.find_map (make_target path) (List.rev prefix_map) + +let rewrite_all prefix_map path = + List.filter_map (make_target path) (List.rev prefix_map) + +let rewrite prefix_map path = + match rewrite_first prefix_map path with + | None -> path + | Some path -> path diff --git a/upstream/ocaml_503/utils/build_path_prefix_map.mli b/upstream/ocaml_503/utils/build_path_prefix_map.mli new file mode 100644 index 000000000..d8ec9caf4 --- /dev/null +++ b/upstream/ocaml_503/utils/build_path_prefix_map.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Rewrite paths for reproducible builds + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} +*) + + +type path = string +type path_prefix = string +type error_message = string + +val encode_prefix : path_prefix -> string +val decode_prefix : string -> (path_prefix, error_message) result + +type pair = { target: path_prefix; source : path_prefix } + +val encode_pair : pair -> string +val decode_pair : string -> (pair, error_message) result + +type map = pair option list + +val encode_map : map -> string +val decode_map : string -> (map, error_message) result + +val rewrite_first : map -> path -> path option +(** [rewrite_first map path] tries to find a source in [map] + that is a prefix of the input [path]. If it succeeds, + it replaces this prefix with the corresponding target. + If it fails, it just returns [None]. *) + +val rewrite_all : map -> path -> path list +(** [rewrite_all map path] finds all sources in [map] + that are a prefix of the input [path]. For each matching + source, in priority order, it replaces this prefix with + the corresponding target and adds the result to + the returned list. + If there are no matches, it just returns [[]]. *) + +val rewrite : map -> path -> path +(** [rewrite path] uses [rewrite_first] to try to find a + mapping for path. If found, it returns that, otherwise + it just returns [path]. *) diff --git a/upstream/ocaml_503/utils/ccomp.ml b/upstream/ocaml_503/utils/ccomp.ml new file mode 100644 index 000000000..defe4d2a4 --- /dev/null +++ b/upstream/ocaml_503/utils/ccomp.ml @@ -0,0 +1,209 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compiling C files and building C libraries *) + +let command cmdline = + if !Clflags.verbose then begin + prerr_string "+ "; + prerr_string cmdline; + prerr_newline() + end; + let res = Sys.command cmdline in + if res = 127 then raise (Sys_error cmdline); + res + +let run_command cmdline = ignore(command cmdline) + +(* Build @responsefile to work around OS limitations on + command-line length. + Under Windows, the max length is 8187 minus the length of the + COMSPEC variable (or 7 if it's not set). To be on the safe side, + we'll use a response file if we need to pass 4096 or more bytes of + arguments. + For Unix-like systems, the threshold is 2^16 (64 KiB), which is + within the lowest observed limits (2^17 per argument under Linux; + between 70000 and 80000 for macOS). +*) + +let build_response_file lst = + let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in + List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst; + close_out oc; + at_exit (fun () -> Misc.remove_file responsefile); + "@" ^ responsefile + +let quote_files ~response_files lst = + let lst = List.filter (fun f -> f <> "") lst in + let quoted = List.map Filename.quote lst in + let s = String.concat " " quoted in + if response_files && + (String.length s >= 65536 + || (String.length s >= 4096 && Sys.os_type = "Win32")) + then build_response_file quoted + else s + +let quote_prefixed ~response_files pr lst = + let lst = List.filter (fun f -> f <> "") lst in + let lst = List.map (fun f -> pr ^ f) lst in + quote_files ~response_files lst + +let quote_optfile = function + | None -> "" + | Some f -> Filename.quote f + +let display_msvc_output file name = + let c = open_in file in + try + let first = input_line c in + if first <> Filename.basename name then + print_endline first; + while true do + print_endline (input_line c) + done + with _ -> + close_in c; + Sys.remove file + +let compile_file ?output ?(opt="") ?stable_name name = + let (pipe, file) = + if Config.ccomp_type = "msvc" && not !Clflags.verbose then + try + let (t, c) = Filename.open_temp_file "msvc" "stdout" in + close_out c; + (Printf.sprintf " > %s" (Filename.quote t), t) + with _ -> + ("", "") + else + ("", "") in + let debug_prefix_map = + match stable_name with + | Some stable when Config.c_has_debug_prefix_map -> + Printf.sprintf " -fdebug-prefix-map=%s=%s" name stable + | Some _ | None -> "" in + let exit = + command + (Printf.sprintf + "%s%s %s %s -c %s %s %s %s %s%s" + (match !Clflags.c_compiler with + | Some cc -> cc + | None -> + let (cflags, cppflags) = + if !Clflags.native_code + then (Config.native_cflags, Config.native_cppflags) + else (Config.bytecode_cflags, Config.bytecode_cppflags) in + (String.concat " " [Config.c_compiler; cflags; cppflags])) + debug_prefix_map + (match output with + | None -> "" + | Some o -> Printf.sprintf "%s%s" Config.c_output_obj o) + opt + (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "") + (String.concat " " (List.rev !Clflags.all_ccopts)) + (quote_prefixed ~response_files:true "-I" + (List.map (Misc.expand_directory Config.standard_library) + (List.rev ( !Clflags.hidden_include_dirs + @ !Clflags.include_dirs)))) + (Clflags.std_include_flag "-I") + (Filename.quote name) + (* cl tediously includes the name of the C file as the first thing it + outputs (in fairness, the tedious thing is that there's no switch to + disable this behaviour). In the absence of the Unix module, use + a temporary file to filter the output (cannot pipe the output to a + filter because this removes the exit status of cl, which is wanted. + *) + pipe) in + if pipe <> "" + then display_msvc_output file name; + exit + +let create_archive archive file_list = + Misc.remove_file archive; + let quoted_archive = Filename.quote archive in + if file_list = [] then + 0 (* Don't call the archiver: #6550/#1094/#9011 *) + else + match Config.ccomp_type with + "msvc" -> + command(Printf.sprintf "link /lib /nologo /out:%s %s" + quoted_archive + (quote_files ~response_files:true file_list)) + | _ -> + assert(String.length Config.ar > 0); + command(Printf.sprintf "%s rc %s %s" + Config.ar quoted_archive + (quote_files ~response_files:Config.ar_supports_response_files + file_list)) + +let expand_libname cclibs = + cclibs |> List.map (fun cclib -> + if String.starts_with ~prefix:"-l" cclib then + let libname = + "lib" ^ String.sub cclib 2 (String.length cclib - 2) ^ Config.ext_lib in + try + Load_path.find libname + with Not_found -> + libname + else cclib) + +type link_mode = + | Exe + | Dll + | MainDll + | Partial + +let remove_Wl cclibs = + cclibs |> List.map (fun cclib -> + (* -Wl,-foo,bar -> -foo bar *) + if String.length cclib >= 4 && "-Wl," = String.sub cclib 0 4 then + String.map (function ',' -> ' ' | c -> c) + (String.sub cclib 4 (String.length cclib - 4)) + else cclib) + +let call_linker mode output_name files extra = + Profile.record_call "c-linker" (fun () -> + let cmd = + if mode = Partial then + let (l_prefix, files) = + match Config.ccomp_type with + | "msvc" -> ("/libpath:", expand_libname files) + | _ -> ("-L", files) + in + Printf.sprintf "%s%s %s %s %s" + Config.native_pack_linker + (Filename.quote output_name) + (quote_prefixed ~response_files:true + l_prefix (Load_path.get_path_list ())) + (quote_files ~response_files:true (remove_Wl files)) + extra + else + Printf.sprintf "%s -o %s %s %s %s %s %s" + (match !Clflags.c_compiler, mode with + | Some cc, _ -> cc + | None, Exe -> Config.mkexe + | None, Dll -> Config.mkdll + | None, MainDll -> Config.mkmaindll + | None, Partial -> assert false + ) + (Filename.quote output_name) + "" (*(Clflags.std_include_flag "-I")*) + (quote_prefixed ~response_files:true "-L" + (Load_path.get_path_list ())) + (String.concat " " (List.rev !Clflags.all_ccopts)) + (quote_files ~response_files:true files) + extra + in + command cmd + ) diff --git a/upstream/ocaml_503/utils/ccomp.mli b/upstream/ocaml_503/utils/ccomp.mli new file mode 100644 index 000000000..38dfd5486 --- /dev/null +++ b/upstream/ocaml_503/utils/ccomp.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Compiling C files and building C libraries + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +val command: string -> int +val run_command: string -> unit +val compile_file: + ?output:string -> ?opt:string -> ?stable_name:string -> string -> int +val create_archive: string -> string list -> int +val quote_files: response_files:bool -> string list -> string +val quote_optfile: string option -> string +(*val make_link_options: string list -> string*) + +type link_mode = + | Exe + | Dll + | MainDll + | Partial + +val call_linker: link_mode -> string -> string list -> string -> int diff --git a/upstream/ocaml_503/utils/clflags.ml b/upstream/ocaml_503/utils/clflags.ml new file mode 100644 index 000000000..566ad639d --- /dev/null +++ b/upstream/ocaml_503/utils/clflags.ml @@ -0,0 +1,774 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Command-line parameters *) + +module Int_arg_helper = Arg_helper.Make (struct + module Key = struct + include Numbers.Int + let of_string = int_of_string + end + + module Value = struct + include Numbers.Int + let of_string = int_of_string + end +end) +module Float_arg_helper = Arg_helper.Make (struct + module Key = struct + include Numbers.Int + let of_string = int_of_string + end + + module Value = struct + include Numbers.Float + let of_string = float_of_string + end +end) + +let objfiles = ref ([] : string list) (* .cmo and .cma files *) +and ccobjs = ref ([] : string list) (* .o, .a, .so and -cclib -lxxx *) +and dllibs = ref ([] : string list) (* .so and -dllib -lxxx *) + +let cmi_file = ref None + +let compile_only = ref false (* -c *) +and output_name = ref (None : string option) (* -o *) +and include_dirs = ref ([] : string list) (* -I *) +and hidden_include_dirs = ref ([] : string list) (* -H *) +and no_std_include = ref false (* -nostdlib *) +and no_cwd = ref false (* -nocwd *) +and print_types = ref false (* -i *) +and make_archive = ref false (* -a *) +and debug = ref false (* -g *) +and debug_full = ref false (* For full DWARF support *) +and unsafe = ref false (* -unsafe *) +and use_linscan = ref false (* -linscan *) +and link_everything = ref false (* -linkall *) +and custom_runtime = ref false (* -custom *) +and no_check_prims = ref false (* -no-check-prims *) +and bytecode_compatible_32 = ref false (* -compat-32 *) +and output_c_object = ref false (* -output-obj *) +and output_complete_object = ref false (* -output-complete-obj *) +and output_complete_executable = ref false (* -output-complete-exe *) +and all_ccopts = ref ([] : string list) (* -ccopt *) +and classic = ref false (* -nolabels *) +and nopervasives = ref false (* -nopervasives *) +and match_context_rows = ref 32 (* -match-context-rows *) +and safer_matching = ref false (* -safer-matching *) +and preprocessor = ref(None : string option) (* -pp *) +and all_ppx = ref ([] : string list) (* -ppx *) +let absname = ref false (* -absname *) +let annotations = ref false (* -annot *) +let binary_annotations = ref false (* -bin-annot *) +let store_occurrences = ref false (* -bin-annot-occurrences *) +and use_threads = ref false (* -thread *) +and noassert = ref false (* -noassert *) +and verbose = ref false (* -verbose *) +and noversion = ref false (* -no-version *) +and noprompt = ref false (* -noprompt *) +and nopromptcont = ref false (* -nopromptcont *) +and init_file = ref (None : string option) (* -init *) +and noinit = ref false (* -noinit *) +and open_modules = ref [] (* -open *) +and use_prims = ref "" (* -use-prims ... *) +and use_runtime = ref "" (* -use-runtime ... *) +and plugin = ref false (* -plugin ... *) +and principal = ref false (* -principal *) +and real_paths = ref true (* -short-paths *) +and recursive_types = ref false (* -rectypes *) +and strict_sequence = ref false (* -strict-sequence *) +and strict_formats = ref true (* -strict-formats *) +and applicative_functors = ref true (* -no-app-funct *) +and make_runtime = ref false (* -make-runtime *) +and c_compiler = ref (None: string option) (* -cc *) +and no_auto_link = ref false (* -noautolink *) +and dllpaths = ref ([] : string list) (* -dllpath *) +and make_package = ref false (* -pack *) +and for_package = ref (None: string option) (* -for-pack *) +and error_size = ref 500 (* -error-size *) +and float_const_prop = ref true (* -no-float-const-prop *) +and transparent_modules = ref false (* -trans-mod *) +let unique_ids = ref true (* -d(no-)unique-ds *) +let locations = ref true (* -d(no-)locations *) +let dump_source = ref false (* -dsource *) +let dump_parsetree = ref false (* -dparsetree *) +and dump_typedtree = ref false (* -dtypedtree *) +and dump_shape = ref false (* -dshape *) +and dump_matchcomp = ref false (* -dmatchcomp *) +and dump_rawlambda = ref false (* -drawlambda *) +and dump_lambda = ref false (* -dlambda *) +and dump_rawclambda = ref false (* -drawclambda *) +and dump_clambda = ref false (* -dclambda *) +and dump_rawflambda = ref false (* -drawflambda *) +and dump_flambda = ref false (* -dflambda *) +and dump_flambda_let = ref (None : int option) (* -dflambda-let=... *) +and dump_flambda_verbose = ref false (* -dflambda-verbose *) +and dump_instr = ref false (* -dinstr *) +and keep_camlprimc_file = ref false (* -dcamlprimc *) + +let keep_asm_file = ref false (* -S *) +let optimize_for_speed = ref true (* -compact *) +and opaque = ref false (* -opaque *) + +and dump_cmm = ref false (* -dcmm *) +let dump_selection = ref false (* -dsel *) +let dump_combine = ref false (* -dcombine *) +let dump_cse = ref false (* -dcse *) +let dump_live = ref false (* -dlive *) +let dump_spill = ref false (* -dspill *) +let dump_split = ref false (* -dsplit *) +let dump_interf = ref false (* -dinterf *) +let dump_prefer = ref false (* -dprefer *) +let dump_interval = ref false (* -dinterval *) +let dump_regalloc = ref false (* -dalloc *) +let dump_reload = ref false (* -dreload *) +let dump_scheduling = ref false (* -dscheduling *) +let dump_linear = ref false (* -dlinear *) +let keep_startup_file = ref false (* -dstartup *) +let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *) + +let native_code = ref false (* set to true under ocamlopt *) + +let force_slash = ref false (* for ocamldep *) +let clambda_checks = ref false (* -clambda-checks *) +let cmm_invariants = + ref Config.with_cmm_invariants (* -dcmm-invariants *) + +let flambda_invariant_checks = + ref Config.with_flambda_invariants (* -flambda-(no-)invariants *) + +let dont_write_files = ref false (* set to true under ocamldoc *) + +let insn_sched_default = true +let insn_sched = ref insn_sched_default (* -[no-]insn-sched *) + +let std_include_flag prefix = + if !no_std_include then "" + else (prefix ^ (Filename.quote Config.standard_library)) + +let std_include_dir () = + if !no_std_include then [] else [Config.standard_library] + +let shared = ref false (* -shared *) +let dlcode = ref true (* not -nodynlink *) + +let pic_code = ref (match Config.architecture with (* -fPIC *) + | "amd64" | "s390x" -> true + | _ -> false) + +let runtime_variant = ref "" + +let with_runtime = ref true (* -with-runtime *) + +let keep_docs = ref false (* -keep-docs *) +let keep_locs = ref true (* -keep-locs *) + +let classic_inlining = ref false (* -Oclassic *) +let inlining_report = ref false (* -inlining-report *) + +let afl_instrument = ref Config.afl_instrument (* -afl-instrument *) +let afl_inst_ratio = ref 100 (* -afl-inst-ratio *) + +let function_sections = ref false (* -function-sections *) + +let simplify_rounds = ref None (* -rounds *) +let default_simplify_rounds = ref 1 (* -rounds *) +let rounds () = + match !simplify_rounds with + | None -> !default_simplify_rounds + | Some r -> r + +let default_inline_threshold = if Config.flambda then 10. else 10. /. 8. +let inline_toplevel_multiplier = 16 +let default_inline_toplevel_threshold = + int_of_float ((float inline_toplevel_multiplier) *. default_inline_threshold) +let default_inline_call_cost = 5 +let default_inline_alloc_cost = 7 +let default_inline_prim_cost = 3 +let default_inline_branch_cost = 5 +let default_inline_indirect_cost = 4 +let default_inline_branch_factor = 0.1 +let default_inline_lifting_benefit = 1300 +let default_inline_max_unroll = 0 +let default_inline_max_depth = 1 + +let inline_threshold = ref (Float_arg_helper.default default_inline_threshold) +let inline_toplevel_threshold = + ref (Int_arg_helper.default default_inline_toplevel_threshold) +let inline_call_cost = ref (Int_arg_helper.default default_inline_call_cost) +let inline_alloc_cost = ref (Int_arg_helper.default default_inline_alloc_cost) +let inline_prim_cost = ref (Int_arg_helper.default default_inline_prim_cost) +let inline_branch_cost = + ref (Int_arg_helper.default default_inline_branch_cost) +let inline_indirect_cost = + ref (Int_arg_helper.default default_inline_indirect_cost) +let inline_branch_factor = + ref (Float_arg_helper.default default_inline_branch_factor) +let inline_lifting_benefit = + ref (Int_arg_helper.default default_inline_lifting_benefit) +let inline_max_unroll = + ref (Int_arg_helper.default default_inline_max_unroll) +let inline_max_depth = + ref (Int_arg_helper.default default_inline_max_depth) + + +let unbox_specialised_args = ref true (* -no-unbox-specialised-args *) +let unbox_free_vars_of_closures = ref true +let unbox_closures = ref false (* -unbox-closures *) +let default_unbox_closures_factor = 10 +let unbox_closures_factor = + ref default_unbox_closures_factor (* -unbox-closures-factor *) +let remove_unused_arguments = ref false (* -remove-unused-arguments *) + +type inlining_arguments = { + inline_call_cost : int option; + inline_alloc_cost : int option; + inline_prim_cost : int option; + inline_branch_cost : int option; + inline_indirect_cost : int option; + inline_lifting_benefit : int option; + inline_branch_factor : float option; + inline_max_depth : int option; + inline_max_unroll : int option; + inline_threshold : float option; + inline_toplevel_threshold : int option; +} + +let set_int_arg round (arg:Int_arg_helper.parsed ref) default value = + let value : int = + match value with + | None -> default + | Some value -> value + in + match round with + | None -> + arg := Int_arg_helper.set_base_default value + (Int_arg_helper.reset_base_overrides !arg) + | Some round -> + arg := Int_arg_helper.add_base_override round value !arg + +let set_float_arg round (arg:Float_arg_helper.parsed ref) default value = + let value = + match value with + | None -> default + | Some value -> value + in + match round with + | None -> + arg := Float_arg_helper.set_base_default value + (Float_arg_helper.reset_base_overrides !arg) + | Some round -> + arg := Float_arg_helper.add_base_override round value !arg + +let use_inlining_arguments_set ?round (arg:inlining_arguments) = + let set_int = set_int_arg round in + let set_float = set_float_arg round in + set_int inline_call_cost default_inline_call_cost arg.inline_call_cost; + set_int inline_alloc_cost default_inline_alloc_cost arg.inline_alloc_cost; + set_int inline_prim_cost default_inline_prim_cost arg.inline_prim_cost; + set_int inline_branch_cost + default_inline_branch_cost arg.inline_branch_cost; + set_int inline_indirect_cost + default_inline_indirect_cost arg.inline_indirect_cost; + set_int inline_lifting_benefit + default_inline_lifting_benefit arg.inline_lifting_benefit; + set_float inline_branch_factor + default_inline_branch_factor arg.inline_branch_factor; + set_int inline_max_depth + default_inline_max_depth arg.inline_max_depth; + set_int inline_max_unroll + default_inline_max_unroll arg.inline_max_unroll; + set_float inline_threshold + default_inline_threshold arg.inline_threshold; + set_int inline_toplevel_threshold + default_inline_toplevel_threshold arg.inline_toplevel_threshold + +(* o1 is the default *) +let o1_arguments = { + inline_call_cost = None; + inline_alloc_cost = None; + inline_prim_cost = None; + inline_branch_cost = None; + inline_indirect_cost = None; + inline_lifting_benefit = None; + inline_branch_factor = None; + inline_max_depth = None; + inline_max_unroll = None; + inline_threshold = None; + inline_toplevel_threshold = None; +} + +let classic_arguments = { + inline_call_cost = None; + inline_alloc_cost = None; + inline_prim_cost = None; + inline_branch_cost = None; + inline_indirect_cost = None; + inline_lifting_benefit = None; + inline_branch_factor = None; + inline_max_depth = None; + inline_max_unroll = None; + (* [inline_threshold] matches the current compiler's default. + Note that this particular fraction can be expressed exactly in + floating point. *) + inline_threshold = Some (10. /. 8.); + (* [inline_toplevel_threshold] is not used in classic mode. *) + inline_toplevel_threshold = Some 1; +} + +let o2_arguments = { + inline_call_cost = Some (2 * default_inline_call_cost); + inline_alloc_cost = Some (2 * default_inline_alloc_cost); + inline_prim_cost = Some (2 * default_inline_prim_cost); + inline_branch_cost = Some (2 * default_inline_branch_cost); + inline_indirect_cost = Some (2 * default_inline_indirect_cost); + inline_lifting_benefit = None; + inline_branch_factor = None; + inline_max_depth = Some 2; + inline_max_unroll = None; + inline_threshold = Some 25.; + inline_toplevel_threshold = Some (25 * inline_toplevel_multiplier); +} + +let o3_arguments = { + inline_call_cost = Some (3 * default_inline_call_cost); + inline_alloc_cost = Some (3 * default_inline_alloc_cost); + inline_prim_cost = Some (3 * default_inline_prim_cost); + inline_branch_cost = Some (3 * default_inline_branch_cost); + inline_indirect_cost = Some (3 * default_inline_indirect_cost); + inline_lifting_benefit = None; + inline_branch_factor = Some 0.; + inline_max_depth = Some 3; + inline_max_unroll = Some 1; + inline_threshold = Some 50.; + inline_toplevel_threshold = Some (50 * inline_toplevel_multiplier); +} + +let all_passes = ref [] +let dumped_passes_list = ref [] +let dumped_pass s = + assert(List.mem s !all_passes); + List.mem s !dumped_passes_list + +let set_dumped_pass s enabled = + if (List.mem s !all_passes) then begin + let passes_without_s = List.filter ((<>) s) !dumped_passes_list in + let dumped_passes = + if enabled then + s :: passes_without_s + else + passes_without_s + in + dumped_passes_list := dumped_passes + end + +let dump_into_file = ref false (* -dump-into-file *) +let dump_dir: string option ref = ref None (* -dump-dir *) + +type 'a env_reader = { + parse : string -> 'a option; + print : 'a -> string; + usage : string; + env_var : string; +} + +let color = ref None (* -color *) + +let color_reader = { + parse = (function + | "auto" -> Some Misc.Color.Auto + | "always" -> Some Misc.Color.Always + | "never" -> Some Misc.Color.Never + | _ -> None); + print = (function + | Misc.Color.Auto -> "auto" + | Misc.Color.Always -> "always" + | Misc.Color.Never -> "never"); + usage = "expected \"auto\", \"always\" or \"never\""; + env_var = "OCAML_COLOR"; +} + +let error_style = ref None (* -error-style *) + +let error_style_reader = { + parse = (function + | "contextual" -> Some Misc.Error_style.Contextual + | "short" -> Some Misc.Error_style.Short + | _ -> None); + print = (function + | Misc.Error_style.Contextual -> "contextual" + | Misc.Error_style.Short -> "short"); + usage = "expected \"contextual\" or \"short\""; + env_var = "OCAML_ERROR_STYLE"; +} + +let unboxed_types = ref false + +(* This is used by the -save-ir-after option. *) +module Compiler_ir = struct + type t = Linear + + let all = [ + Linear; + ] + + let extension t = + let ext = + match t with + | Linear -> "linear" + in + ".cmir-" ^ ext + + (** [extract_extension_with_pass filename] returns the IR whose extension + is a prefix of the extension of [filename], and the suffix, + which can be used to distinguish different passes on the same IR. + For example, [extract_extension_with_pass "foo.cmir-linear123"] + returns [Some (Linear, "123")]. *) + let extract_extension_with_pass filename = + let ext = Filename.extension filename in + let ext_len = String.length ext in + if ext_len <= 0 then None + else begin + let is_prefix ir = + let s = extension ir in + let s_len = String.length s in + s_len <= ext_len && s = String.sub ext 0 s_len + in + let drop_prefix ir = + let s = extension ir in + let s_len = String.length s in + String.sub ext s_len (ext_len - s_len) + in + let ir = List.find_opt is_prefix all in + match ir with + | None -> None + | Some ir -> Some (ir, drop_prefix ir) + end +end + +(* This is used by the -stop-after option. *) +module Compiler_pass = struct + (* If you add a new pass, the following must be updated: + - the variable `passes` below + - the manpages in man/ocaml{c,opt}.m + - the manual manual/src/cmds/unified-options.etex + *) + type t = Parsing | Typing | Lambda | Scheduling | Emit + + let to_string = function + | Parsing -> "parsing" + | Typing -> "typing" + | Lambda -> "lambda" + | Scheduling -> "scheduling" + | Emit -> "emit" + + let of_string = function + | "parsing" -> Some Parsing + | "typing" -> Some Typing + | "lambda" -> Some Lambda + | "scheduling" -> Some Scheduling + | "emit" -> Some Emit + | _ -> None + + let rank = function + | Parsing -> 0 + | Typing -> 1 + | Lambda -> 2 + | Scheduling -> 50 + | Emit -> 60 + + let passes = [ + Parsing; + Typing; + Lambda; + Scheduling; + Emit; + ] + let is_compilation_pass _ = true + let is_native_only = function + | Scheduling -> true + | Emit -> true + | _ -> false + + let enabled is_native t = not (is_native_only t) || is_native + let can_save_ir_after = function + | Scheduling -> true + | _ -> false + + let available_pass_names ~filter ~native = + passes + |> List.filter (enabled native) + |> List.filter filter + |> List.map to_string + + let compare a b = + compare (rank a) (rank b) + + let to_output_filename t ~prefix = + match t with + | Scheduling -> prefix ^ Compiler_ir.(extension Linear) + | _ -> Misc.fatal_error "Not supported" + + let of_input_filename name = + match Compiler_ir.extract_extension_with_pass name with + | Some (Linear, _) -> Some Emit + | None -> None +end + +let stop_after = ref None (* -stop-after *) + +let should_stop_after pass = + if Compiler_pass.(rank Typing <= rank pass) && !print_types then true + else + match !stop_after with + | None -> false + | Some stop -> Compiler_pass.rank stop <= Compiler_pass.rank pass + +let save_ir_after = ref [] + +let should_save_ir_after pass = + List.mem pass !save_ir_after + +let set_save_ir_after pass enabled = + let other_passes = List.filter ((<>) pass) !save_ir_after in + let new_passes = + if enabled then + pass :: other_passes + else + other_passes + in + save_ir_after := new_passes + +module Dump_option = struct + type t = + | Source + | Parsetree + | Typedtree + | Shape + | Match_comp + | Raw_lambda + | Lambda + | Instr + | Raw_clambda + | Clambda + | Raw_flambda + | Flambda + | Cmm + | Selection + | Combine + | CSE + | Live + | Spill + | Split + | Interf + | Prefer + | Regalloc + | Scheduling + | Linear + | Interval + + let compare (op1 : t) op2 = + Stdlib.compare op1 op2 + + let to_string = function + | Source -> "source" + | Parsetree -> "parsetree" + | Typedtree -> "typedtree" + | Shape -> "shape" + | Match_comp -> "matchcomp" + | Raw_lambda -> "rawlambda" + | Lambda -> "lambda" + | Instr -> "instr" + | Raw_clambda -> "rawclambda" + | Clambda -> "clambda" + | Raw_flambda -> "rawflambda" + | Flambda -> "flambda" + | Cmm -> "cmm" + | Selection -> "selection" + | Combine -> "combine" + | CSE -> "cse" + | Live -> "live" + | Spill -> "spill" + | Split -> "split" + | Interf -> "interf" + | Prefer -> "prefer" + | Regalloc -> "regalloc" + | Scheduling -> "scheduling" + | Linear -> "linear" + | Interval -> "interval" + + let of_string = function + | "source" -> Some Source + | "parsetree" -> Some Parsetree + | "typedtree" -> Some Typedtree + | "shape" -> Some Shape + | "matchcomp" -> Some Match_comp + | "rawlambda" -> Some Raw_lambda + | "lambda" -> Some Lambda + | "instr" -> Some Instr + | "rawclambda" -> Some Raw_clambda + | "clambda" -> Some Clambda + | "rawflambda" -> Some Raw_flambda + | "flambda" -> Some Flambda + | "cmm" -> Some Cmm + | "selection" -> Some Selection + | "combine" -> Some Combine + | "cse" -> Some CSE + | "live" -> Some Live + | "spill" -> Some Spill + | "split" -> Some Split + | "interf" -> Some Interf + | "prefer" -> Some Prefer + | "regalloc" -> Some Regalloc + | "scheduling" -> Some Scheduling + | "linear" -> Some Linear + | "interval" -> Some Interval + | _ -> None + + let flag = function + | Source -> dump_source + | Parsetree -> dump_parsetree + | Typedtree -> dump_typedtree + | Shape -> dump_shape + | Match_comp -> dump_matchcomp + | Raw_lambda -> dump_rawlambda + | Lambda -> dump_lambda + | Instr -> dump_instr + | Raw_clambda -> dump_rawclambda + | Clambda -> dump_clambda + | Raw_flambda -> dump_rawflambda + | Flambda -> dump_flambda + | Cmm -> dump_cmm + | Selection -> dump_selection + | Combine -> dump_combine + | CSE -> dump_cse + | Live -> dump_live + | Spill -> dump_spill + | Split -> dump_split + | Interf -> dump_interf + | Prefer -> dump_prefer + | Regalloc -> dump_regalloc + | Scheduling -> dump_scheduling + | Linear -> dump_linear + | Interval -> dump_interval + + type middle_end = + | Flambda + | Any + | Closure + + type class_ = + | Frontend + | Bytecode + | Middle of middle_end + | Backend + + let _ = + (* no Closure-specific dump option for now, silence a warning *) + Closure + + let classify : t -> class_ = function + | Source + | Parsetree + | Typedtree + | Shape + | Match_comp + | Raw_lambda + | Lambda + -> Frontend + | Instr + -> Bytecode + | Raw_clambda + | Clambda + -> Middle Any + | Raw_flambda + | Flambda + -> Middle Flambda + | Cmm + | Selection + | Combine + | CSE + | Live + | Spill + | Split + | Interf + | Prefer + | Regalloc + | Scheduling + | Linear + | Interval + -> Backend + + let available (option : t) : (unit, string) result = + let pass = Result.ok () in + let ( let* ) = Result.bind in + let fail descr = + Error ( + Printf.sprintf + "this compiler does not support %s-specific options" + descr + ) in + let guard descr cond = + if cond then pass + else fail descr in + let check_bytecode = guard "bytecode" (not !native_code) in + let check_native = guard "native" !native_code in + let check_middle_end = function + | Flambda -> guard "flambda" Config.flambda + | Closure -> guard "closure" (not Config.flambda) + | Any -> pass + in + match classify option with + | Frontend -> + pass + | Bytecode -> + check_bytecode + | Middle middle_end -> + let* () = check_native in + check_middle_end middle_end + | Backend -> + check_native +end + +module String = Misc.Stdlib.String + +let arg_spec = ref [] +let arg_names = ref String.Map.empty + +let reset_arguments () = + arg_spec := []; + arg_names := String.Map.empty + +let add_arguments loc args = + List.iter (function (arg_name, _, _) as arg -> + try + let loc2 = String.Map.find arg_name !arg_names in + Printf.eprintf + "Warning: compiler argument %s is already defined:\n" arg_name; + Printf.eprintf " First definition: %s\n" loc2; + Printf.eprintf " New definition: %s\n" loc; + with Not_found -> + arg_spec := !arg_spec @ [ arg ]; + arg_names := String.Map.add arg_name loc !arg_names + ) args + +let create_usage_msg program = + Printf.sprintf "Usage: %s \n\ + Try '%s --help' for more information." program program + + +let print_arguments program = + Arg.usage !arg_spec (create_usage_msg program) diff --git a/upstream/ocaml_503/utils/clflags.mli b/upstream/ocaml_503/utils/clflags.mli new file mode 100644 index 000000000..c8ac8e970 --- /dev/null +++ b/upstream/ocaml_503/utils/clflags.mli @@ -0,0 +1,317 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2005 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + + +(** Command line flags *) + +(** Optimization parameters represented as ints indexed by round number. *) +module Int_arg_helper : sig + type parsed + + val parse : string -> string -> parsed ref -> unit + + type parse_result = + | Ok + | Parse_failed of exn + val parse_no_error : string -> parsed ref -> parse_result + + val get : key:int -> parsed -> int +end + +(** Optimization parameters represented as floats indexed by round number. *) +module Float_arg_helper : sig + type parsed + + val parse : string -> string -> parsed ref -> unit + + type parse_result = + | Ok + | Parse_failed of exn + val parse_no_error : string -> parsed ref -> parse_result + + val get : key:int -> parsed -> float +end + +type inlining_arguments = { + inline_call_cost : int option; + inline_alloc_cost : int option; + inline_prim_cost : int option; + inline_branch_cost : int option; + inline_indirect_cost : int option; + inline_lifting_benefit : int option; + inline_branch_factor : float option; + inline_max_depth : int option; + inline_max_unroll : int option; + inline_threshold : float option; + inline_toplevel_threshold : int option; +} + +val classic_arguments : inlining_arguments +val o1_arguments : inlining_arguments +val o2_arguments : inlining_arguments +val o3_arguments : inlining_arguments + +(** Set all the inlining arguments for a round. + The default is set if no round is provided. *) +val use_inlining_arguments_set : ?round:int -> inlining_arguments -> unit + +val objfiles : string list ref +val ccobjs : string list ref +val dllibs : string list ref +val cmi_file : string option ref +val compile_only : bool ref +val output_name : string option ref +val include_dirs : string list ref +val hidden_include_dirs : string list ref +val no_std_include : bool ref +val no_cwd : bool ref +val print_types : bool ref +val make_archive : bool ref +val debug : bool ref +val debug_full : bool ref +val unsafe : bool ref +val use_linscan : bool ref +val link_everything : bool ref +val custom_runtime : bool ref +val no_check_prims : bool ref +val bytecode_compatible_32 : bool ref +val output_c_object : bool ref +val output_complete_object : bool ref +val output_complete_executable : bool ref +val all_ccopts : string list ref +val classic : bool ref +val nopervasives : bool ref +val match_context_rows : int ref +val safer_matching : bool ref +val open_modules : string list ref +val preprocessor : string option ref +val all_ppx : string list ref +val absname : bool ref +val annotations : bool ref +val binary_annotations : bool ref +val store_occurrences : bool ref +val use_threads : bool ref +val noassert : bool ref +val verbose : bool ref +val noprompt : bool ref +val nopromptcont : bool ref +val init_file : string option ref +val noinit : bool ref +val noversion : bool ref +val use_prims : string ref +val use_runtime : string ref +val plugin : bool ref +val principal : bool ref +val real_paths : bool ref +val recursive_types : bool ref +val strict_sequence : bool ref +val strict_formats : bool ref +val applicative_functors : bool ref +val make_runtime : bool ref +val c_compiler : string option ref +val no_auto_link : bool ref +val dllpaths : string list ref +val make_package : bool ref +val for_package : string option ref +val error_size : int ref +val float_const_prop : bool ref +val transparent_modules : bool ref +val unique_ids : bool ref +val locations : bool ref +val dump_source : bool ref +val dump_parsetree : bool ref +val dump_typedtree : bool ref +val dump_shape : bool ref +val dump_matchcomp : bool ref +val dump_rawlambda : bool ref +val dump_lambda : bool ref +val dump_rawclambda : bool ref +val dump_clambda : bool ref +val dump_rawflambda : bool ref +val dump_flambda : bool ref +val dump_flambda_let : int option ref +val dump_instr : bool ref +val keep_camlprimc_file : bool ref +val keep_asm_file : bool ref +val optimize_for_speed : bool ref +val dump_cmm : bool ref +val dump_selection : bool ref +val dump_cse : bool ref +val dump_live : bool ref +val dump_spill : bool ref +val dump_split : bool ref +val dump_interf : bool ref +val dump_prefer : bool ref +val dump_regalloc : bool ref +val dump_reload : bool ref +val dump_scheduling : bool ref +val dump_linear : bool ref +val dump_interval : bool ref +val keep_startup_file : bool ref +val dump_combine : bool ref +val native_code : bool ref +val default_inline_threshold : float +val inline_threshold : Float_arg_helper.parsed ref +val inlining_report : bool ref +val simplify_rounds : int option ref +val default_simplify_rounds : int ref +val rounds : unit -> int +val default_inline_max_unroll : int +val inline_max_unroll : Int_arg_helper.parsed ref +val default_inline_toplevel_threshold : int +val inline_toplevel_threshold : Int_arg_helper.parsed ref +val default_inline_call_cost : int +val default_inline_alloc_cost : int +val default_inline_prim_cost : int +val default_inline_branch_cost : int +val default_inline_indirect_cost : int +val default_inline_lifting_benefit : int +val inline_call_cost : Int_arg_helper.parsed ref +val inline_alloc_cost : Int_arg_helper.parsed ref +val inline_prim_cost : Int_arg_helper.parsed ref +val inline_branch_cost : Int_arg_helper.parsed ref +val inline_indirect_cost : Int_arg_helper.parsed ref +val inline_lifting_benefit : Int_arg_helper.parsed ref +val default_inline_branch_factor : float +val inline_branch_factor : Float_arg_helper.parsed ref +val dont_write_files : bool ref +val std_include_flag : string -> string +val std_include_dir : unit -> string list +val shared : bool ref +val dlcode : bool ref +val pic_code : bool ref +val runtime_variant : string ref +val with_runtime : bool ref +val force_slash : bool ref +val keep_docs : bool ref +val keep_locs : bool ref +val opaque : bool ref +val profile_columns : Profile.column list ref +val flambda_invariant_checks : bool ref +val unbox_closures : bool ref +val unbox_closures_factor : int ref +val default_unbox_closures_factor : int +val unbox_free_vars_of_closures : bool ref +val unbox_specialised_args : bool ref +val clambda_checks : bool ref +val cmm_invariants : bool ref +val default_inline_max_depth : int +val inline_max_depth : Int_arg_helper.parsed ref +val remove_unused_arguments : bool ref +val dump_flambda_verbose : bool ref +val classic_inlining : bool ref +val afl_instrument : bool ref +val afl_inst_ratio : int ref +val function_sections : bool ref + +val all_passes : string list ref +val dumped_pass : string -> bool +val set_dumped_pass : string -> bool -> unit + +val dump_into_file : bool ref +val dump_dir : string option ref + +(* Support for flags that can also be set from an environment variable *) +type 'a env_reader = { + parse : string -> 'a option; + print : 'a -> string; + usage : string; + env_var : string; +} + +val color : Misc.Color.setting option ref +val color_reader : Misc.Color.setting env_reader + +val error_style : Misc.Error_style.setting option ref +val error_style_reader : Misc.Error_style.setting env_reader + +val unboxed_types : bool ref + +val insn_sched : bool ref +val insn_sched_default : bool + +module Compiler_pass : sig + type t = Parsing | Typing | Lambda | Scheduling | Emit + val of_string : string -> t option + val to_string : t -> string + val is_compilation_pass : t -> bool + val available_pass_names : filter:(t -> bool) -> native:bool -> string list + val can_save_ir_after : t -> bool + val compare : t -> t -> int + val to_output_filename: t -> prefix:string -> string + val of_input_filename: string -> t option +end + +val stop_after : Compiler_pass.t option ref +val should_stop_after : Compiler_pass.t -> bool +val set_save_ir_after : Compiler_pass.t -> bool -> unit +val should_save_ir_after : Compiler_pass.t -> bool + +module Dump_option : sig + type t = + | Source + | Parsetree + | Typedtree + | Shape + | Match_comp + | Raw_lambda + | Lambda + | Instr + | Raw_clambda + | Clambda + | Raw_flambda + | Flambda + (* Note: no support for [-dflambda-let ] for now. *) + | Cmm + | Selection + | Combine + | CSE + | Live + | Spill + | Split + | Interf + | Prefer + | Regalloc + | Scheduling + | Linear + | Interval + + val compare : t -> t -> int + + val of_string : string -> t option + val to_string : t -> string + + val flag : t -> bool ref + + val available : t -> (unit, string) Result.t +end + +val arg_spec : (string * Arg.spec * string) list ref + +(* [add_arguments __LOC__ args] will add the arguments from [args] at + the end of [arg_spec], checking that they have not already been + added by [add_arguments] before. A warning is printed showing the + locations of the function from which the argument was previously + added. *) +val add_arguments : string -> (string * Arg.spec * string) list -> unit + +(* [create_usage_msg program] creates a usage message for [program] *) +val create_usage_msg: string -> string +(* [print_arguments usage] print the standard usage message *) +val print_arguments : string -> unit + +(* [reset_arguments ()] clear all declared arguments *) +val reset_arguments : unit -> unit diff --git a/upstream/ocaml_503/utils/compression.ml b/upstream/ocaml_503/utils/compression.ml new file mode 100644 index 000000000..384afb3b4 --- /dev/null +++ b/upstream/ocaml_503/utils/compression.ml @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, Collège de France and Inria project Cambium *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +external zstd_initialize: unit -> bool = "caml_zstd_initialize" + +let compression_supported = zstd_initialize () + +type [@warning "-unused-constructor"] extern_flags = + No_sharing (** Don't preserve sharing *) + | Closures (** Send function closures *) + | Compat_32 (** Ensure 32-bit compatibility *) + | Compression (** Optional compression *) + +external to_channel: out_channel -> 'a -> extern_flags list -> unit + = "caml_output_value" + +let output_value ch v = to_channel ch v [Compression] + +let input_value = Stdlib.input_value diff --git a/upstream/ocaml_503/utils/compression.mli b/upstream/ocaml_503/utils/compression.mli new file mode 100644 index 000000000..bdfb63da7 --- /dev/null +++ b/upstream/ocaml_503/utils/compression.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, Collège de France and Inria project Cambium *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val output_value : out_channel -> 'a -> unit +(** [Compression.output_value chan v] writes the representation + of [v] on channel [chan]. + If compression is supported, the marshaled data + representing value [v] is compressed before being written to + channel [chan]. + If compression is not supported, this function behaves like + {!Stdlib.output_value}. *) + +val input_value : in_channel -> 'a +(** [Compression.input_value chan] reads from channel [chan] the + byte representation of a structured value, as produced by + [Compression.output_value], and reconstructs and + returns the corresponding value. + If compression is not supported, this function behaves like + {!Stdlib.input_value}. *) + +val compression_supported : bool +(** Reports whether compression is supported. *) diff --git a/upstream/ocaml_503/utils/config.common.ml.in b/upstream/ocaml_503/utils/config.common.ml.in new file mode 100644 index 000000000..3603fe6c6 --- /dev/null +++ b/upstream/ocaml_503/utils/config.common.ml.in @@ -0,0 +1,163 @@ +(* @configure_input@ *) +#3 "utils/config.common.ml.in" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Portions of the Config module common to both the boot and main compiler. *) + +(* The main OCaml version string has moved to ../build-aux/ocaml_version.m4 *) +let version = Sys.ocaml_version + +let standard_library = + try + Sys.getenv "OCAMLLIB" + with Not_found -> + try + Sys.getenv "CAMLLIB" + with Not_found -> + standard_library_default + +let exec_magic_number = {magic|@EXEC_MAGIC_NUMBER@|magic} + (* exec_magic_number is duplicated in runtime/caml/exec.h *) +and cmi_magic_number = {magic|@CMI_MAGIC_NUMBER@|magic} +and cmo_magic_number = {magic|@CMO_MAGIC_NUMBER@|magic} +and cma_magic_number = {magic|@CMA_MAGIC_NUMBER@|magic} +and cmx_magic_number = {magic|@CMX_MAGIC_NUMBER@|magic} +and cmxa_magic_number = {magic|@CMXA_MAGIC_NUMBER@|magic} +and ast_impl_magic_number = {magic|@AST_IMPL_MAGIC_NUMBER@|magic} +and ast_intf_magic_number = {magic|@AST_INTF_MAGIC_NUMBER@|magic} +and cmxs_magic_number = {magic|@CMXS_MAGIC_NUMBER@|magic} +and cmt_magic_number = {magic|@CMT_MAGIC_NUMBER@|magic} +and linear_magic_number = {magic|@LINEAR_MAGIC_NUMBER@|magic} + +let safe_string = true +let default_safe_string = true +let naked_pointers = false + +let interface_suffix = ref ".mli" + +let max_tag = 243 +(* This is normally the same as in obj.ml, but we have to define it + separately because it can differ when we're in the middle of a + bootstrapping phase. *) +let lazy_tag = 246 + +let max_young_wosize = 256 +let stack_threshold = 32 (* see runtime/caml/config.h *) +let stack_safety_margin = 6 +let default_executable_name = + match Sys.os_type with + "Unix" -> "a.out" + | "Win32" | "Cygwin" -> "camlprog.exe" + | _ -> "camlprog" +type configuration_value = + | String of string + | Int of int + | Bool of bool + +let configuration_variables () = + let p x v = (x, String v) in + let p_int x v = (x, Int v) in + let p_bool x v = (x, Bool v) in +[ + p "version" version; + p "standard_library_default" standard_library_default; + p "standard_library" standard_library; + p "ccomp_type" ccomp_type; + p "c_compiler" c_compiler; + p "bytecode_cflags" bytecode_cflags; + p "ocamlc_cflags" bytecode_cflags; + p "bytecode_cppflags" bytecode_cppflags; + p "ocamlc_cppflags" bytecode_cppflags; + p "native_cflags" native_cflags; + p "ocamlopt_cflags" native_cflags; + p "native_cppflags" native_cppflags; + p "ocamlopt_cppflags" native_cppflags; + p "bytecomp_c_compiler" bytecomp_c_compiler; + p "native_c_compiler" native_c_compiler; + p "bytecomp_c_libraries" bytecomp_c_libraries; + p "native_c_libraries" native_c_libraries; + p "native_ldflags" native_ldflags; + p "native_pack_linker" native_pack_linker; + p_bool "native_compiler" native_compiler; + p "architecture" architecture; + p "model" model; + p_int "int_size" Sys.int_size; + p_int "word_size" Sys.word_size; + p "system" system; + p "asm" asm; + p_bool "asm_cfi_supported" asm_cfi_supported; + p_bool "with_frame_pointers" with_frame_pointers; + p "ext_exe" ext_exe; + p "ext_obj" ext_obj; + p "ext_asm" ext_asm; + p "ext_lib" ext_lib; + p "ext_dll" ext_dll; + p "os_type" Sys.os_type; + p "default_executable_name" default_executable_name; + p_bool "systhread_supported" systhread_supported; + p "host" host; + p "target" target; + p_bool "flambda" flambda; + p_bool "safe_string" safe_string; + p_bool "default_safe_string" default_safe_string; + p_bool "flat_float_array" flat_float_array; + p_bool "function_sections" function_sections; + p_bool "afl_instrument" afl_instrument; + p_bool "tsan" tsan; + p_bool "windows_unicode" windows_unicode; + p_bool "supports_shared_libraries" supports_shared_libraries; + p_bool "native_dynlink" native_dynlink; + p_bool "naked_pointers" naked_pointers; + + p "exec_magic_number" exec_magic_number; + p "cmi_magic_number" cmi_magic_number; + p "cmo_magic_number" cmo_magic_number; + p "cma_magic_number" cma_magic_number; + p "cmx_magic_number" cmx_magic_number; + p "cmxa_magic_number" cmxa_magic_number; + p "ast_impl_magic_number" ast_impl_magic_number; + p "ast_intf_magic_number" ast_intf_magic_number; + p "cmxs_magic_number" cmxs_magic_number; + p "cmt_magic_number" cmt_magic_number; + p "linear_magic_number" linear_magic_number; +] + +let print_config_value oc = function + | String s -> + Printf.fprintf oc "%s" s + | Int n -> + Printf.fprintf oc "%d" n + | Bool p -> + Printf.fprintf oc "%B" p + +let print_config oc = + let print (x, v) = + Printf.fprintf oc "%s: %a\n" x print_config_value v in + List.iter print (configuration_variables ()); + flush oc + +let config_var x = + match List.assoc_opt x (configuration_variables()) with + | None -> None + | Some v -> + let s = match v with + | String s -> s + | Int n -> Int.to_string n + | Bool b -> string_of_bool b + in + Some s + +let merlin = false diff --git a/upstream/ocaml_503/utils/config.fixed.ml b/upstream/ocaml_503/utils/config.fixed.ml new file mode 100644 index 000000000..807b92935 --- /dev/null +++ b/upstream/ocaml_503/utils/config.fixed.ml @@ -0,0 +1,73 @@ +#2 "utils/config.fixed.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* David Allsopp, Tarides UK. *) +(* *) +(* Copyright 2022 David Allsopp Ltd. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Configuration for the boot compiler. The compiler should refuse to bootstrap + if configured with values which would contradict the configuration below. + The values below are picked to trigger errors if accidentally used in the + compiler (e.g. for the C compiler). *) + +let boot_cannot_call s = "/ The boot compiler should not call " ^ s + +let bindir = "/tmp" +let standard_library_default = "/tmp" +let ccomp_type = "n/a" +let c_compiler = boot_cannot_call "the C compiler" +let c_output_obj = "" +let c_has_debug_prefix_map = false +let as_has_debug_prefix_map = false +let bytecode_cflags = "" +let bytecode_cppflags = "" +let native_cflags = "" +let native_cppflags = "" +let bytecomp_c_libraries = "" +let bytecomp_c_compiler = "" +let native_c_compiler = c_compiler +let native_c_libraries = "" +let native_ldflags = "" +let native_pack_linker = boot_cannot_call "the linker" +let default_rpath = "" +let mksharedlibrpath = "" +let ar = boot_cannot_call "ar" +let supports_shared_libraries = false +let native_dynlink = false +let mkdll = native_pack_linker +let mkexe = native_pack_linker +let mkmaindll = native_pack_linker +let flambda = false +let with_flambda_invariants = false +let with_cmm_invariants = false +let windows_unicode = false +let flat_float_array = true +let function_sections = false +let afl_instrument = false +let native_compiler = false +let tsan = false +let architecture = "none" +let model = "default" +let system = "unknown" +let asm = boot_cannot_call "the assembler" +let asm_cfi_supported = false +let with_frame_pointers = false +let reserved_header_bits = 0 +let ext_exe = ".ex_The boot compiler should not be using Config.ext_exe" +let ext_obj = ".o_The boot compiler cannot process C objects" +let ext_asm = ".s_The boot compiler should not be using Config.ext_asm" +let ext_lib = ".a_The boot compiler cannot process C libraries" +let ext_dll = ".so_The boot compiler cannot load DLLs" +let host = "zinc-boot-ocaml" +let target = host +let systhread_supported = false +let flexdll_dirs = [] +let ar_supports_response_files = true diff --git a/upstream/ocaml_503/utils/config.generated.ml.in b/upstream/ocaml_503/utils/config.generated.ml.in new file mode 100644 index 000000000..aa0345540 --- /dev/null +++ b/upstream/ocaml_503/utils/config.generated.ml.in @@ -0,0 +1,94 @@ +(* @configure_input@ *) +#2 "utils/config.generated.ml.in" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* This file is included in config_main.ml during the build rather + than compiled on its own *) + +let bindir = {@QS@|@ocaml_bindir@|@QS@} + +let standard_library_default = {@QS@|@ocaml_libdir@|@QS@} + +let ccomp_type = {@QS@|@ccomptype@|@QS@} +let c_compiler = {@QS@|@CC@|@QS@} +let c_output_obj = {@QS@|@outputobj@|@QS@} +let c_has_debug_prefix_map = @cc_has_debug_prefix_map@ +let as_has_debug_prefix_map = @as_has_debug_prefix_map@ +let bytecode_cflags = {@QS@|@bytecode_cflags@|@QS@} +let bytecode_cppflags = {@QS@|@bytecode_cppflags@|@QS@} +let native_cflags = {@QS@|@native_cflags@|@QS@} +let native_cppflags = {@QS@|@native_cppflags@|@QS@} + +let bytecomp_c_libraries = {@QS@|@zstd_libs@ @cclibs@|@QS@} +(* bytecomp_c_compiler and native_c_compiler have been supported for a + long time and are retained for backwards compatibility. + For programs that don't need compatibility with older OCaml releases + the recommended approach is to use the constituent variables + c_compiler, {bytecode,native}_c[pp]flags etc. directly. +*) +let bytecomp_c_compiler = + c_compiler ^ " " ^ bytecode_cflags ^ " " ^ bytecode_cppflags +let native_c_compiler = + c_compiler ^ " " ^ native_cflags ^ " " ^ native_cppflags +let native_c_libraries = {@QS@|@cclibs@|@QS@} +let native_ldflags = {@QS@|@native_ldflags@|@QS@} +let native_pack_linker = {@QS@|@PACKLD@|@QS@} +let default_rpath = {@QS@|@rpath@|@QS@} +let mksharedlibrpath = {@QS@|@mksharedlibrpath@|@QS@} +let ar = {@QS@|@AR@|@QS@} +let supports_shared_libraries = @supports_shared_libraries@ +let native_dynlink = @natdynlink@ +let mkdll = {@QS@|@mkdll_exp@|@QS@} +let mkexe = {@QS@|@mkexe_exp@|@QS@} +let mkmaindll = {@QS@|@mkmaindll_exp@|@QS@} + +let flambda = @flambda@ +let with_flambda_invariants = @flambda_invariants@ +let with_cmm_invariants = @cmm_invariants@ +let windows_unicode = @windows_unicode@ != 0 + +let flat_float_array = @flat_float_array@ + +let function_sections = @function_sections@ +let afl_instrument = @afl@ + +let native_compiler = @native_compiler@ + +let architecture = {@QS@|@arch@|@QS@} +let model = {@QS@|@model@|@QS@} +let system = {@QS@|@system@|@QS@} + +let asm = {@QS@|@AS@|@QS@} +let asm_cfi_supported = @asm_cfi_supported@ +let with_frame_pointers = @frame_pointers@ +let reserved_header_bits = @reserved_header_bits@ + +let ext_exe = {@QS@|@exeext@|@QS@} +let ext_obj = "." ^ {@QS@|@OBJEXT@|@QS@} +let ext_asm = "." ^ {@QS@|@S@|@QS@} +let ext_lib = "." ^ {@QS@|@libext@|@QS@} +let ext_dll = "." ^ {@QS@|@SO@|@QS@} + +let host = {@QS@|@host@|@QS@} +let target = {@QS@|@target@|@QS@} + +let systhread_supported = @systhread_support@ + +let flexdll_dirs = [@flexdll_dir@] + +let ar_supports_response_files = @ar_supports_response_files@ + +let tsan = @tsan@ diff --git a/upstream/ocaml_503/utils/config.mli b/upstream/ocaml_503/utils/config.mli new file mode 100644 index 000000000..51e31a372 --- /dev/null +++ b/upstream/ocaml_503/utils/config.mli @@ -0,0 +1,266 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** System configuration + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +val version: string +(** The current version number of the system *) + +val bindir: string +(** The directory containing the binary programs *) + +val standard_library: string +(** The directory containing the standard libraries *) + +val ccomp_type: string +(** The "kind" of the C compiler, assembler and linker used: one of + "cc" (for Unix-style C compilers) + "msvc" (for Microsoft Visual C++ and MASM) *) + +val c_compiler: string +(** The compiler to use for compiling C files *) + +val c_output_obj: string +(** Name of the option of the C compiler for specifying the output + file *) + +val c_has_debug_prefix_map : bool +(** Whether the C compiler supports -fdebug-prefix-map *) + +val as_has_debug_prefix_map : bool +(** Whether the assembler supports --debug-prefix-map *) + +val bytecode_cflags : string +(** The flags ocamlc should pass to the C compiler *) + +val bytecode_cppflags : string +(** The flags ocamlc should pass to the C preprocessor *) + +val native_cflags : string +(** The flags ocamlopt should pass to the C compiler *) + +val native_cppflags : string +(** The flags ocamlopt should pass to the C preprocessor *) + +val bytecomp_c_libraries: string +(** The C libraries to link with custom runtimes *) + +val native_c_libraries: string +(** The C libraries to link with native-code programs *) + +val native_ldflags : string +(* Flags to pass to the system linker *) + +val native_pack_linker: string +(** The linker to use for packaging (ocamlopt -pack) and for partial + links (ocamlopt -output-obj). *) + +val mkdll: string +(** The linker command line to build dynamic libraries. *) + +val mkexe: string +(** The linker command line to build executables. *) + +val mkmaindll: string +(** The linker command line to build main programs as dlls. *) + +val default_rpath: string +(** Option to add a directory to be searched for libraries at runtime + (used by ocamlmklib) *) + +val mksharedlibrpath: string +(** Option to add a directory to be searched for shared libraries at runtime + (used by ocamlmklib) *) + +val ar: string +(** Name of the ar command, or "" if not needed (MSVC) *) + +val interface_suffix: string ref +(** Suffix for interface file names *) + +val exec_magic_number: string +(** Magic number for bytecode executable files *) + +val cmi_magic_number: string +(** Magic number for compiled interface files *) + +val cmo_magic_number: string +(** Magic number for object bytecode files *) + +val cma_magic_number: string +(** Magic number for archive files *) + +val cmx_magic_number: string +(** Magic number for compilation unit descriptions *) + +val cmxa_magic_number: string +(** Magic number for libraries of compilation unit descriptions *) + +val ast_intf_magic_number: string +(** Magic number for file holding an interface syntax tree *) + +val ast_impl_magic_number: string +(** Magic number for file holding an implementation syntax tree *) + +val cmxs_magic_number: string +(** Magic number for dynamically-loadable plugins *) + +val cmt_magic_number: string +(** Magic number for compiled interface files *) + +val linear_magic_number: string +(** Magic number for Linear internal representation files *) + +val max_tag: int +(** Biggest tag that can be stored in the header of a regular block. *) + +val lazy_tag : int +(** Normally the same as Obj.lazy_tag. Separate definition because + of technical reasons for bootstrapping. *) + +val max_young_wosize: int +(** Maximal size of arrays that are directly allocated in the + minor heap *) + +val stack_threshold: int +(** Size in words of safe area at bottom of VM stack, + see runtime/caml/config.h *) + +val stack_safety_margin: int +(** Size in words of the safety margin between the bottom of + the stack and the stack pointer. This margin can be used by + intermediate computations of some instructions, or the event + handler. *) + +val native_compiler: bool +(** Whether the native compiler is available or not + + @since 5.1 *) + +val architecture: string +(** Name of processor type for the native-code compiler *) + +val model: string +(** Name of processor submodel for the native-code compiler *) + +val system: string +(** Name of operating system for the native-code compiler *) + +val asm: string +(** The assembler (and flags) to use for assembling + ocamlopt-generated code. *) + +val asm_cfi_supported: bool +(** Whether assembler understands CFI directives *) + +val with_frame_pointers : bool +(** Whether assembler should maintain frame pointers *) + +val ext_obj: string +(** Extension for object files, e.g. [.o] under Unix. *) + +val ext_asm: string +(** Extension for assembler files, e.g. [.s] under Unix. *) + +val ext_lib: string +(** Extension for library files, e.g. [.a] under Unix. *) + +val ext_dll: string +(** Extension for dynamically-loaded libraries, e.g. [.so] under Unix.*) + +val ext_exe: string +(** Extension for executable programs, e.g. [.exe] under Windows. + + @since 4.12 *) + +val default_executable_name: string +(** Name of executable produced by linking if none is given with -o, + e.g. [a.out] under Unix. *) + +val systhread_supported : bool +(** Whether the system thread library is implemented *) + +val flexdll_dirs : string list +(** Directories needed for the FlexDLL objects *) + +val host : string +(** Whether the compiler is a cross-compiler *) + +val target : string +(** Whether the compiler is a cross-compiler *) + +val flambda : bool +(** Whether the compiler was configured for flambda *) + +val with_flambda_invariants : bool +(** Whether the invariants checks for flambda are enabled *) + +val with_cmm_invariants : bool +(** Whether the invariants checks for Cmm are enabled *) + +val reserved_header_bits : int +(** How many bits of a block's header are reserved *) + +val flat_float_array : bool +(** Whether the compiler and runtime automagically flatten float + arrays *) + +val function_sections : bool +(** Whether the compiler was configured to generate + each function in a separate section *) + +val windows_unicode: bool +(** Whether Windows Unicode runtime is enabled *) + +val naked_pointers : bool +(** Whether the runtime supports naked pointers + + @since 4.14 *) + +val supports_shared_libraries: bool +(** Whether shared libraries are supported + + @since 4.08 *) + +val native_dynlink: bool +(** Whether native shared libraries are supported + + @since 5.1 *) + +val afl_instrument : bool +(** Whether afl-fuzz instrumentation is generated by default *) + +val ar_supports_response_files: bool +(** Whether ar supports @FILE arguments. *) + +val tsan : bool +(** Whether ThreadSanitizer instrumentation is enabled *) + +(** Access to configuration values *) +val print_config : out_channel -> unit + +val config_var : string -> string option +(** the configuration value of a variable, if it exists *) + +(**/**) + +val merlin : bool + +(**/**) diff --git a/upstream/ocaml_503/utils/consistbl.ml b/upstream/ocaml_503/utils/consistbl.ml new file mode 100644 index 000000000..29289201f --- /dev/null +++ b/upstream/ocaml_503/utils/consistbl.ml @@ -0,0 +1,95 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Consistency tables: for checking consistency of module CRCs *) + +open Misc + +module Make (Module_name : sig + type t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t + module Tbl : Hashtbl.S with type key = t + val compare : t -> t -> int +end) = struct + type t = (Digest.t * filepath) Module_name.Tbl.t + + let create () = Module_name.Tbl.create 13 + + let clear = Module_name.Tbl.clear + + exception Inconsistency of { + unit_name : Module_name.t; + inconsistent_source : string; + original_source : string; + } + + exception Not_available of Module_name.t + + let check_ tbl name crc source = + let (old_crc, old_source) = Module_name.Tbl.find tbl name in + if crc <> old_crc then raise(Inconsistency { + unit_name = name; + inconsistent_source = source; + original_source = old_source; + }) + + let check tbl name crc source = + try check_ tbl name crc source + with Not_found -> + Module_name.Tbl.add tbl name (crc, source) + + let check_noadd tbl name crc source = + try check_ tbl name crc source + with Not_found -> + raise (Not_available name) + + let source tbl name = snd (Module_name.Tbl.find tbl name) + + let extract l tbl = + let l = List.sort_uniq Module_name.compare l in + List.fold_left + (fun assc name -> + try + let (crc, _) = Module_name.Tbl.find tbl name in + (name, Some crc) :: assc + with Not_found -> + (name, None) :: assc) + [] l + + let extract_map mod_names tbl = + Module_name.Set.fold + (fun name result -> + try + let (crc, _) = Module_name.Tbl.find tbl name in + Module_name.Map.add name (Some crc) result + with Not_found -> + Module_name.Map.add name None result) + mod_names + Module_name.Map.empty + + let filter p tbl = + let to_remove = ref [] in + Module_name.Tbl.iter + (fun name _ -> + if not (p name) then to_remove := name :: !to_remove) + tbl; + List.iter + (fun name -> + while Module_name.Tbl.mem tbl name do + Module_name.Tbl.remove tbl name + done) + !to_remove +end diff --git a/upstream/ocaml_503/utils/consistbl.mli b/upstream/ocaml_503/utils/consistbl.mli new file mode 100644 index 000000000..acc89eb31 --- /dev/null +++ b/upstream/ocaml_503/utils/consistbl.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Consistency tables: for checking consistency of module CRCs + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Misc + +module Make (Module_name : sig + type t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t + module Tbl : Hashtbl.S with type key = t + val compare : t -> t -> int +end) : sig + type t + + val create: unit -> t + + val clear: t -> unit + + val check: t -> Module_name.t -> Digest.t -> filepath -> unit + (* [check tbl name crc source] + checks consistency of ([name], [crc]) with infos previously + stored in [tbl]. If no CRC was previously associated with + [name], record ([name], [crc]) in [tbl]. + [source] is the name of the file from which the information + comes from. This is used for error reporting. *) + + val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit + (* Same as [check], but raise [Not_available] if no CRC was previously + associated with [name]. *) + + val source: t -> Module_name.t -> filepath + (* [source tbl name] returns the file name associated with [name] + if the latter has an associated CRC in [tbl]. + Raise [Not_found] otherwise. *) + + val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list + (* [extract tbl names] returns an associative list mapping each string + in [names] to the CRC associated with it in [tbl]. If no CRC is + associated with a name then it is mapped to [None]. *) + + val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t + (* Like [extract] but with a more sophisticated type. *) + + val filter: (Module_name.t -> bool) -> t -> unit + (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs + such that [pred name] is [false]. *) + + exception Inconsistency of { + unit_name : Module_name.t; + inconsistent_source : string; + original_source : string; + } + (* Raised by [check] when a CRC mismatch is detected. *) + + exception Not_available of Module_name.t + (* Raised by [check_noadd] when a name doesn't have an associated + CRC. *) +end diff --git a/upstream/ocaml_503/utils/diffing.ml b/upstream/ocaml_503/utils/diffing.ml new file mode 100644 index 000000000..f2c336d9c --- /dev/null +++ b/upstream/ocaml_503/utils/diffing.ml @@ -0,0 +1,463 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Radanne, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@warning "-16"] + +(* This module implements a modified version of Wagner-Fischer + See + for preliminary reading. + + The main extensions is that: + - State is computed based on the optimal patch so far. + - The lists can be extended at each state computation. + + We add the constraint that extensions can only be in one side + (either the left or right list). This is enforced by the external API. + +*) + +(** Shared types *) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation + +let style = function + | Preservation -> Misc.Style.[ FG Green ] + | Deletion -> Misc.Style.[ FG Red; Bold] + | Insertion -> Misc.Style.[ FG Red; Bold] + | Modification -> Misc.Style.[ FG Magenta; Bold] + +let prefix ppf (pos, p) = + let open Format_doc in + let sty = style p in + pp_open_stag ppf (Misc.Style.Style sty); + fprintf ppf "%i. " pos; + pp_close_stag ppf () + + +let (let*) = Option.bind +let (let+) x f = Option.map f x +let (let*!) x f = Option.iter f x + +module type Defs = sig + type left + type right + type eq + type diff + type state +end + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +let classify = function + | Delete _ -> Deletion + | Insert _ -> Insertion + | Change _ -> Modification + | Keep _ -> Preservation + +module Define(D:Defs) = struct + open D + +type nonrec change = (left,right,eq,diff) change + +type patch = change list +module type S = sig + val diff: state -> left array -> right array -> patch +end + + +type full_state = { + line: left array; + column: right array; + state: state +} + +(* The matrix supporting our dynamic programming implementation. + + Each cell contains: + - The diff and its weight + - The state computed so far + - The lists, potentially extended locally. + + The matrix can also be reshaped. +*) +module Matrix : sig + + type shape = { l : int ; c : int } + + type t + + val make : shape -> t + val reshape : shape -> t -> t + + (** accessor functions *) + val diff : t -> int -> int -> change option + val state : t -> int -> int -> full_state option + val weight : t -> int -> int -> int + + val line : t -> int -> int -> left option + val column : t -> int -> int -> right option + + val set : + t -> int -> int -> + diff:change option -> + weight:int -> + state:full_state -> + unit + + (** the shape when starting filling the matrix *) + val shape : t -> shape + + (** [shape m i j] is the shape as seen from the state at position (i,j) + after some possible extensions + *) + val shape_at : t -> int -> int -> shape option + + (** the maximal shape on the whole matrix *) + val real_shape : t -> shape + + (** debugging printer *) + val[@warning "-32"] pp : Format.formatter -> t -> unit + +end = struct + + type shape = { l : int ; c : int } + + type t = + { states: full_state option array array; + weight: int array array; + diff: change option array array; + columns: int; + lines: int; + } + let opt_get a n = + if n < Array.length a then Some (Array.unsafe_get a n) else None + let line m i j = let* st = m.states.(i).(j) in opt_get st.line i + let column m i j = let* st = m.states.(i).(j) in opt_get st.column j + let diff m i j = m.diff.(i).(j) + let weight m i j = m.weight.(i).(j) + let state m i j = m.states.(i).(j) + let shape m = { l = m.lines ; c = m.columns } + + let set m i j ~diff ~weight ~state = + m.weight.(i).(j) <- weight; + m.states.(i).(j) <- Some state; + m.diff.(i).(j) <- diff; + () + + let shape_at tbl i j = + let+ st = tbl.states.(i).(j) in + let l = Array.length st.line in + let c = Array.length st.column in + { l ; c } + + let real_shape tbl = + let lines = ref tbl.lines in + let columns = ref tbl.columns in + for i = 0 to tbl.lines do + for j = 0 to tbl.columns do + let*! {l; c} = shape_at tbl i j in + if l > !lines then lines := l; + if c > !columns then columns := c + done; + done; + { l = !lines ; c = !columns } + + let make { l = lines ; c = columns } = + { states = Array.make_matrix (lines + 1) (columns + 1) None; + weight = Array.make_matrix (lines + 1) (columns + 1) max_int; + diff = Array.make_matrix (lines + 1) (columns + 1) None; + lines; + columns; + } + + let reshape { l = lines ; c = columns } m = + let copy default a = + Array.init (1+lines) (fun i -> Array.init (1+columns) (fun j -> + if i <= m.lines && j <= m.columns then + a.(i).(j) + else default) ) in + { states = copy None m.states; + weight = copy max_int m.weight; + diff = copy None m.diff; + lines; + columns + } + + let pp ppf m = + let { l ; c } = shape m in + Format.eprintf "Shape : %i, %i@." l c; + for i = 0 to l do + for j = 0 to c do + let d = diff m i j in + match d with + | None -> + Format.fprintf ppf " " + | Some diff -> + let sdiff = match diff with + | Insert _ -> "\u{2190}" + | Delete _ -> "\u{2191}" + | Keep _ -> "\u{2196}" + | Change _ -> "\u{21F1}" + in + let w = weight m i j in + Format.fprintf ppf "%s%i " sdiff w + done; + Format.pp_print_newline ppf () + done + +end + + +(* Building the patch. + + We first select the best final cell. A potential final cell + is a cell where the local shape (i.e., the size of the strings) correspond + to its position in the matrix. In other words: it's at the end of both its + strings. We select the final cell with the smallest weight. + + We then build the patch by walking backward from the final cell to the + origin. +*) + +let select_final_state m0 = + let maybe_final i j = + match Matrix.shape_at m0 i j with + | Some shape_here -> shape_here.l = i && shape_here.c = j + | None -> false + in + let best_state (i0,j0,weigth0) (i,j) = + let weight = Matrix.weight m0 i j in + if weight < weigth0 then (i,j,weight) else (i0,j0,weigth0) + in + let res = ref (0,0,max_int) in + let shape = Matrix.shape m0 in + for i = 0 to shape.l do + for j = 0 to shape.c do + if maybe_final i j then + res := best_state !res (i,j) + done + done; + let i_final, j_final, _ = !res in + assert (i_final <> 0 || j_final <> 0); + (i_final, j_final) + +let construct_patch m0 = + let rec aux acc (i, j) = + if i = 0 && j = 0 then + acc + else + match Matrix.diff m0 i j with + | None -> assert false + | Some d -> + let next = match d with + | Keep _ | Change _ -> (i-1, j-1) + | Delete _ -> (i-1, j) + | Insert _ -> (i, j-1) + in + aux (d::acc) next + in + aux [] (select_final_state m0) + +(* Computation of new cells *) + +let select_best_proposition l = + let compare_proposition curr prop = + match curr, prop with + | None, o | o, None -> o + | Some (curr_m, curr_res), Some (m, res) -> + Some (if curr_m <= m then curr_m, curr_res else m,res) + in + List.fold_left compare_proposition None l + + module type Full_core = sig + type update_result + type update_state + val weight: change -> int + val test: state -> left -> right -> (eq, diff) result + val update: change -> update_state -> update_result + end + +module Generic + (X: Full_core + with type update_result := full_state + and type update_state := full_state) = struct + open X + + (* Boundary cell update *) + let compute_column0 tbl i = + let*! st = Matrix.state tbl (i-1) 0 in + let*! line = Matrix.line tbl (i-1) 0 in + let diff = Delete line in + Matrix.set tbl i 0 + ~weight:(weight diff + Matrix.weight tbl (i-1) 0) + ~state:(update diff st) + ~diff:(Some diff) + + let compute_line0 tbl j = + let*! st = Matrix.state tbl 0 (j-1) in + let*! column = Matrix.column tbl 0 (j-1) in + let diff = Insert column in + Matrix.set tbl 0 j + ~weight:(weight diff + Matrix.weight tbl 0 (j-1)) + ~state:(update diff st) + ~diff:(Some diff) + +let compute_inner_cell tbl i j = + let compute_proposition i j diff = + let* diff = diff in + let+ localstate = Matrix.state tbl i j in + weight diff + Matrix.weight tbl i j, (diff, localstate) + in + let del = + let diff = let+ x = Matrix.line tbl (i-1) j in Delete x in + compute_proposition (i-1) j diff + in + let insert = + let diff = let+ x = Matrix.column tbl i (j-1) in Insert x in + compute_proposition i (j-1) diff + in + let diag = + let diff = + let* state = Matrix.state tbl (i-1) (j-1) in + let* line = Matrix.line tbl (i-1) (j-1) in + let* column = Matrix.column tbl (i-1) (j-1) in + match test state.state line column with + | Ok ok -> Some (Keep (line, column, ok)) + | Error err -> Some (Change (line, column, err)) + in + compute_proposition (i-1) (j-1) diff + in + let*! newweight, (diff, localstate) = + (* The order of propositions is important here: + the call [select_best_proposition [P_0, ...; P_n]] keeps the first + proposition with minimal weight as the representative path for this + weight class at the current matrix position. + + By induction, the representative path for the minimal weight class will + be the smallest path according to the reverse lexical order induced by + the element order [[P_0;...; P_n]]. + + This is why we choose to start with the [Del] case since path ending with + [Del+] suffix are likely to correspond to parital application in the + functor application case. + Similarly, large block of deletions or insertions at the end of the + definitions might point toward incomplete definitions. + Thus this seems a good overall setting. *) + select_best_proposition [del;insert;diag] + in + let state = update diff localstate in + Matrix.set tbl i j ~weight:newweight ~state ~diff:(Some diff) + +let compute_cell m i j = + match i, j with + | _ when Matrix.diff m i j <> None -> () + | 0,0 -> () + | 0,j -> compute_line0 m j + | i,0 -> compute_column0 m i; + | _ -> compute_inner_cell m i j + +(* Filling the matrix + + We fill the whole matrix, as in vanilla Wagner-Fischer. + At this point, the lists in some states might have been extended. + If any list have been extended, we need to reshape the matrix + and repeat the process +*) +let compute_matrix state0 = + let m0 = Matrix.make { l = 0 ; c = 0 } in + Matrix.set m0 0 0 ~weight:0 ~state:state0 ~diff:None; + let rec loop m = + let shape = Matrix.shape m in + let new_shape = Matrix.real_shape m in + if new_shape.l > shape.l || new_shape.c > shape.c then + let m = Matrix.reshape new_shape m in + for i = 0 to new_shape.l do + for j = 0 to new_shape.c do + compute_cell m i j + done + done; + loop m + else + m + in + loop m0 + end + + + module type Parameters = Full_core with type update_state := state + + module Simple(X:Parameters with type update_result := state) = struct + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = { fs with state = X.update d fs.state } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + + let may_append x = function + | [||] -> x + | y -> Array.append x y + + + module Left_variadic + (X:Parameters with type update_result := state * left array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; line = may_append fs.line a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + module Right_variadic + (X:Parameters with type update_result := state * right array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; column = may_append fs.column a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + +end diff --git a/upstream/ocaml_503/utils/diffing.mli b/upstream/ocaml_503/utils/diffing.mli new file mode 100644 index 000000000..79c51fbba --- /dev/null +++ b/upstream/ocaml_503/utils/diffing.mli @@ -0,0 +1,147 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Radanne, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Parametric diffing + + This module implements diffing over lists of arbitrary content. + It is parameterized by + - The content of the two lists + - The equality witness when an element is kept + - The diffing witness when an element is changed + + Diffing is extended to maintain state depending on the + computed changes while walking through the two lists. + + The underlying algorithm is a modified Wagner-Fischer algorithm + (see ). + + We provide the following guarantee: + Given two lists [l] and [r], if different patches result in different + states, we say that the state diverges. + - We always return the optimal patch on prefixes of [l] and [r] + on which state does not diverge. + - Otherwise, we return a correct but non-optimal patch where subpatches + with no divergent states are optimal for the given initial state. + + More precisely, the optimality of Wagner-Fischer depends on the property + that the edit-distance between a k-prefix of the left input and a l-prefix + of the right input d(k,l) satisfies + + d(k,l) = min ( + del_cost + d(k-1,l), + insert_cost + d(k,l-1), + change_cost + d(k-1,l-1) + ) + + Under this hypothesis, it is optimal to choose greedily the state of the + minimal patch transforming the left k-prefix into the right l-prefix as a + representative of the states of all possible patches transforming the left + k-prefix into the right l-prefix. + + If this property is not satisfied, we can still choose greedily a + representative state. However, the computed patch is no more guaranteed to + be globally optimal. + Nevertheless, it is still a correct patch, which is even optimal among all + explored patches. + +*) + +(** The core types of a diffing implementation *) +module type Defs = sig + type left + type right + type eq + (** Detailed equality trace *) + + type diff + (** Detailed difference trace *) + + type state + (** environment of a partial patch *) +end + +(** The kind of changes which is used to share printing and styling + across implementation*) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation +val prefix: (int * change_kind) Format_doc.printer +val style: change_kind -> Misc.Style.style list + + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +val classify: _ change -> change_kind + +(** [Define(Defs)] creates the diffing types from the types + defined in [Defs] and the functors that need to be instantatied + with the diffing algorithm parameters +*) +module Define(D:Defs): sig + open D + + (** The type of potential changes on a list. *) + type nonrec change = (left,right,eq,diff) change + type patch = change list + (** A patch is an ordered list of changes. *) + + module type Parameters = sig + type update_result + + val weight: change -> int + (** [weight ch] returns the weight of the change [ch]. + Used to find the smallest patch. *) + + val test: state -> left -> right -> (eq, diff) result + (** + [test st xl xr] tests if the elements [xl] and [xr] are + co mpatible ([Ok]) or not ([Error]). + *) + + val update: change -> state -> update_result + (** [update ch st] returns the new state after applying a change. + The [update_result] type also contains expansions in the variadic + case. + *) + end + + module type S = sig + val diff: state -> left array -> right array -> patch + (** [diff state l r] computes the optimal patch between [l] and [r], + using the initial state [state]. + *) + end + + + module Simple: (Parameters with type update_result := state) -> S + + (** {1 Variadic diffing} + + Variadic diffing allows to expand the lists being diffed during diffing. + in one specific direction. + *) + module Left_variadic: + (Parameters with type update_result := state * left array) -> S + + module Right_variadic: + (Parameters with type update_result := state * right array) -> S + +end diff --git a/upstream/ocaml_503/utils/diffing_with_keys.ml b/upstream/ocaml_503/utils/diffing_with_keys.ml new file mode 100644 index 000000000..b56db5a06 --- /dev/null +++ b/upstream/ocaml_503/utils/diffing_with_keys.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +type 'a with_pos = {pos:int; data:'a} +let with_pos l = List.mapi (fun n data -> {pos=n+1; data}) l + +(** Composite change and mismatches *) +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +let prefix ppf x = + let kind = match x with + | Change _ | Swap _ | Move _ -> Diffing.Modification + | Insert _ -> Diffing.Insertion + | Delete _ -> Diffing.Deletion + in + let style k ppf inner = + let sty = Diffing.style k in + Format_doc.pp_open_stag ppf (Misc.Style.Style sty); + Format_doc.kfprintf (fun ppf -> Format_doc.pp_close_stag ppf () ) ppf inner + in + match x with + | Change (Name {pos; _ } | Type {pos; _}) + | Insert { pos; _ } | Delete { pos; _ } -> + style kind ppf "%i. " pos + | Swap { pos = left, right; _ } -> + style kind ppf "%i<->%i. " left right + | Move { got; expected; _ } -> + style kind ppf "%i->%i. " expected got + + + +(** To detect [move] and [swaps], we are using the fact that + there are 2-cycles in the graph of name renaming. + - [Change (x,y,_)] is then an edge from + [key_left x] to [key_right y]. + - [Insert x] is an edge between the special node epsilon and + [key_left x] + - [Delete x] is an edge between [key_right] and the epsilon node + Since for 2-cycle, knowing one edge is enough to identify the cycle + it might belong to, we are using maps of partial 2-cycles. +*) +module Two_cycle: sig + type t = private (string * string) + val create: string -> string -> t +end = struct + type t = string * string + let create kx ky = + if kx <= ky then kx, ky else ky, kx +end +module Swap = Map.Make(struct + type t = Two_cycle.t + let compare: t -> t -> int = Stdlib.compare + end) +module Move = Misc.Stdlib.String.Map + + +module Define(D:Diffing.Defs with type eq := unit) = struct + + module Internal_defs = struct + type left = D.left with_pos + type right = D.right with_pos + type diff = (D.left, D.right, D.diff) mismatch + type eq = unit + type state = D.state + end + module Diff = Diffing.Define(Internal_defs) + + type left = Internal_defs.left + type right = Internal_defs.right + type diff = (D.left, D.right, D.diff) mismatch + type composite_change = (D.left,D.right,D.diff) change + type nonrec change = (left, right, unit, diff) Diffing.change + type patch = composite_change list + + module type Parameters = sig + include Diff.Parameters with type update_result := D.state + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple(Impl:Parameters) = struct + open Impl + + (** Partial 2-cycles *) + type ('l,'r) partial_cycle = + | Left of int * D.state * 'l + | Right of int * D.state * 'r + | Both of D.state * 'l * 'r + + (** Compute the partial cycle and edge associated to an edge *) + let edge state (x:left) (y:right) = + let kx, ky = key_left x.data, key_right y.data in + let edge = + if kx <= ky then + Left (x.pos, state, (x,y)) + else + Right (x.pos,state, (x,y)) + in + Two_cycle.create kx ky, edge + + let merge_edge ex ey = match ex, ey with + | ex, None -> Some ex + | Left (lpos, lstate, l), Some Right (rpos, rstate,r) + | Right (rpos, rstate,r), Some Left (lpos, lstate, l) -> + let state = if lpos < rpos then rstate else lstate in + Some (Both (state,l,r)) + | Both _ as b, _ | _, Some (Both _ as b) -> Some b + | l, _ -> Some l + + let two_cycles state changes = + let add (state,(swaps,moves)) (d:change) = + update d state, + match d with + | Change (x,y,_) -> + let k, edge = edge state x y in + Swap.update k (merge_edge edge) swaps, moves + | Insert nx -> + let k = key_right nx.data in + let edge = Right (nx.pos, state,nx) in + swaps, Move.update k (merge_edge edge) moves + | Delete nx -> + let k, edge = key_left nx.data, Left (nx.pos, state, nx) in + swaps, Move.update k (merge_edge edge) moves + | _ -> swaps, moves + in + List.fold_left add (state,(Swap.empty,Move.empty)) changes + + (** Check if an edge belongs to a known 2-cycle *) + let swap swaps x y = + let kx, ky = key_left x.data, key_right y.data in + let key = Two_cycle.create kx ky in + match Swap.find_opt key swaps with + | None | Some (Left _ | Right _)-> None + | Some Both (state, (ll,lr),(rl,rr)) -> + match test state ll rr, test state rl lr with + | Ok _, Ok _ -> + Some ({pos=ll.pos; data=kx}, {pos=rl.pos; data=ky}) + | Error _, _ | _, Error _ -> None + + let move moves x = + let name = + match x with + | Either.Left x -> key_left x.data + | Either.Right x -> key_right x.data + in + match Move.find_opt name moves with + | None | Some (Left _ | Right _)-> None + | Some Both (state,got,expected) -> + match test state got expected with + | Ok _ -> + Some (Move {name; got=got.pos; expected=expected.pos}) + | Error _ -> None + + let refine state patch = + let _, (swaps, moves) = two_cycles state patch in + let filter: change -> composite_change option = function + | Keep _ -> None + | Insert x -> + begin match move moves (Either.Right x) with + | Some _ as move -> move + | None -> Some (Insert {pos=x.pos;insert=x.data}) + end + | Delete x -> + begin match move moves (Either.Left x) with + | Some _ -> None + | None -> Some (Delete {pos=x.pos; delete=x.data}) + end + | Change(x,y, reason) -> + match swap swaps x y with + | Some ({pos=pos1; data=first}, {pos=pos2; data=last}) -> + if x.pos = pos1 then + Some (Swap { pos = pos1, pos2; first; last}) + else None + | None -> Some (Change reason) + in + List.filter_map filter patch + + let diff state left right = + let left = with_pos left in + let right = with_pos right in + let module Raw = Diff.Simple(Impl) in + let raw = Raw.diff state (Array.of_list left) (Array.of_list right) in + refine state raw + + end +end diff --git a/upstream/ocaml_503/utils/diffing_with_keys.mli b/upstream/ocaml_503/utils/diffing_with_keys.mli new file mode 100644 index 000000000..94e56fb72 --- /dev/null +++ b/upstream/ocaml_503/utils/diffing_with_keys.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** + + When diffing lists where each element has a distinct key, we can refine + the diffing patch by introducing two composite edit moves: swaps and moves. + + [Swap]s exchange the position of two elements. [Swap] cost is set to + [2 * change - epsilon]. + [Move]s change the position of one element. [Move] cost is set to + [delete + addition - epsilon]. + + When the cost [delete + addition] is greater than [change] and with those + specific weights, the optimal patch with [Swap]s and [Move]s can be computed + directly and cheaply from the original optimal patch. + +*) + +type 'a with_pos = {pos: int; data:'a} +val with_pos: 'a list -> 'a with_pos list + +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +(** This specialized version of changes introduces two composite + changes: [Move] and [Swap] +*) +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +val prefix: ('l,'r,'diff) change Format_doc.printer + +module Define(D:Diffing.Defs with type eq := unit): sig + + type diff = (D.left, D.right, D.diff) mismatch + type left = D.left with_pos + type right = D.right with_pos + + (** Composite changes and patches *) + type composite_change = (D.left,D.right,D.diff) change + type patch = composite_change list + + (** Atomic changes *) + type change = (left,right,unit,diff) Diffing.change + + module type Parameters = sig + val weight: change -> int + val test: D.state -> left -> right -> (unit, diff) result + val update: change -> D.state -> D.state + + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple: Parameters -> sig + val diff: D.state -> D.left list -> D.right list -> patch + end + +end diff --git a/upstream/ocaml_503/utils/domainstate.ml.c b/upstream/ocaml_503/utils/domainstate.ml.c new file mode 100644 index 000000000..6dbae1d07 --- /dev/null +++ b/upstream/ocaml_503/utils/domainstate.ml.c @@ -0,0 +1,38 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* KC Sivaramakrishnan, Indian Institute of Technology, Madras */ +/* Stephen Dolan, University of Cambridge */ +/* */ +/* Copyright 2019 Indian Institute of Technology, Madras */ +/* Copyright 2019 University of Cambridge */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_CONFIG_H_NO_TYPEDEFS +#include "config.h" +let stack_ctx_words = Stack_ctx_words + +type t = +#define DOMAIN_STATE(type, name) | Domain_##name +#include "domain_state.tbl" +#undef DOMAIN_STATE + +let idx_of_field = + let curr = 0 in +#define DOMAIN_STATE(type, name) \ + let idx__##name = curr in \ + let curr = curr + 1 in +#include "domain_state.tbl" +#undef DOMAIN_STATE + let _ = curr in + function +#define DOMAIN_STATE(type, name) \ + | Domain_##name -> idx__##name +#include "domain_state.tbl" +#undef DOMAIN_STATE diff --git a/upstream/ocaml_503/utils/domainstate.mli.c b/upstream/ocaml_503/utils/domainstate.mli.c new file mode 100644 index 000000000..66a4750d4 --- /dev/null +++ b/upstream/ocaml_503/utils/domainstate.mli.c @@ -0,0 +1,24 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* KC Sivaramakrishnan, Indian Institute of Technology, Madras */ +/* Stephen Dolan, University of Cambridge */ +/* */ +/* Copyright 2019 Indian Institute of Technology, Madras */ +/* Copyright 2019 University of Cambridge */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +val stack_ctx_words : int + +type t = +#define DOMAIN_STATE(type, name) | Domain_##name +#include "domain_state.tbl" +#undef DOMAIN_STATE + +val idx_of_field : t -> int diff --git a/upstream/ocaml_503/utils/format_doc.ml b/upstream/ocaml_503/utils/format_doc.ml new file mode 100644 index 000000000..1530c69da --- /dev/null +++ b/upstream/ocaml_503/utils/format_doc.ml @@ -0,0 +1,481 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Doc = struct + + type box_type = + | H + | V + | HV + | HoV + | B + + type stag = Format.stag + + type element = + | Text of string + | With_size of int + | Open_box of { kind: box_type ; indent:int } + | Close_box + | Open_tag of Format.stag + | Close_tag + | Open_tbox + | Tab_break of { width : int; offset : int } + | Set_tab + | Close_tbox + | Simple_break of { spaces : int; indent: int } + | Break of { fits : string * int * string as 'a; breaks : 'a } + | Flush of { newline:bool } + | Newline + | If_newline + + | Deprecated of (Format.formatter -> unit) + + type t = { rev:element list } [@@unboxed] + + let empty = { rev = [] } + + let to_list doc = List.rev doc.rev + let add doc x = { rev = x :: doc.rev } + let fold f acc doc = List.fold_left f acc (to_list doc) + let append left right = { rev = right.rev @ left.rev } + + let format_open_box_gen ppf kind indent = + match kind with + | H-> Format.pp_open_hbox ppf () + | V -> Format.pp_open_vbox ppf indent + | HV -> Format.pp_open_hvbox ppf indent + | HoV -> Format.pp_open_hovbox ppf indent + | B -> Format.pp_open_box ppf indent + + let interpret_elt ppf = function + | Text x -> Format.pp_print_string ppf x + | Open_box { kind; indent } -> format_open_box_gen ppf kind indent + | Close_box -> Format.pp_close_box ppf () + | Open_tag tag -> Format.pp_open_stag ppf tag + | Close_tag -> Format.pp_close_stag ppf () + | Open_tbox -> Format.pp_open_tbox ppf () + | Tab_break {width;offset} -> Format.pp_print_tbreak ppf width offset + | Set_tab -> Format.pp_set_tab ppf () + | Close_tbox -> Format.pp_close_tbox ppf () + | Simple_break {spaces;indent} -> Format.pp_print_break ppf spaces indent + | Break {fits;breaks} -> Format.pp_print_custom_break ppf ~fits ~breaks + | Flush {newline=true} -> Format.pp_print_newline ppf () + | Flush {newline=false} -> Format.pp_print_flush ppf () + | Newline -> Format.pp_force_newline ppf () + | If_newline -> Format.pp_print_if_newline ppf () + | With_size _ -> () + | Deprecated pr -> pr ppf + + let rec interpret ppf = function + | [] -> () + | With_size size :: Text text :: l -> + Format.pp_print_as ppf size text; + interpret ppf l + | x :: l -> + interpret_elt ppf x; + interpret ppf l + + let format ppf doc = interpret ppf (to_list doc) + + + + let open_box kind indent doc = add doc (Open_box {kind;indent}) + let close_box doc = add doc Close_box + + let string s doc = add doc (Text s) + let bytes b doc = add doc (Text (Bytes.to_string b)) + let with_size size doc = add doc (With_size size) + + let int n doc = add doc (Text (string_of_int n)) + let float f doc = add doc (Text (string_of_float f)) + let char c doc = add doc (Text (String.make 1 c)) + let bool c doc = add doc (Text (Bool.to_string c)) + + let break ~spaces ~indent doc = add doc (Simple_break {spaces; indent}) + let space doc = break ~spaces:1 ~indent:0 doc + let cut = break ~spaces:0 ~indent:0 + + let custom_break ~fits ~breaks doc = add doc (Break {fits;breaks}) + + let force_newline doc = add doc Newline + let if_newline doc = add doc If_newline + + let flush doc = add doc (Flush {newline=false}) + let force_stop doc = add doc (Flush {newline=true}) + + let open_tbox doc = add doc Open_tbox + let set_tab doc = add doc Set_tab + let tab_break ~width ~offset doc = add doc (Tab_break {width;offset}) + let tab doc = tab_break ~width:0 ~offset:0 doc + let close_tbox doc = add doc Close_tbox + + let open_tag stag doc = add doc (Open_tag stag) + let close_tag doc = add doc Close_tag + + let iter ?(sep=Fun.id) ~iter:iterator elt l doc = + let first = ref true in + let rdoc = ref doc in + let print x = + if !first then (first := false; rdoc := elt x !rdoc) + else rdoc := !rdoc |> sep |> elt x + in + iterator print l; + !rdoc + + let rec list ?(sep=Fun.id) elt l doc = match l with + | [] -> doc + | [a] -> elt a doc + | a :: ((_ :: _) as q) -> + doc |> elt a |> sep |> list ~sep elt q + + let array ?sep elt a doc = iter ?sep ~iter:Array.iter elt a doc + let seq ?sep elt s doc = iter ?sep ~iter:Seq.iter elt s doc + + let option ?(none=Fun.id) elt o doc = match o with + | None -> none doc + | Some x -> elt x doc + + let either ~left ~right x doc = match x with + | Either.Left x -> left x doc + | Either.Right x -> right x doc + + let result ~ok ~error x doc = match x with + | Ok x -> ok x doc + | Error x -> error x doc + + (* To format free-flowing text *) + let rec subtext len left right s doc = + let flush doc = + doc |> string (String.sub s left (right - left)) + in + let after_flush doc = subtext len (right+1) (right+1) s doc in + if right = len then + if left <> len then flush doc else doc + else + match s.[right] with + | '\n' -> + doc |> flush |> force_newline |> after_flush + | ' ' -> + doc |> flush |> space |> after_flush + (* there is no specific support for '\t' + as it is unclear what a right semantics would be *) + | _ -> subtext len left (right + 1) s doc + + let text s doc = + subtext (String.length s) 0 0 s doc + + type ('a,'b) fmt = ('a, t, t, 'b) format4 + type printer0 = t -> t + type 'a printer = 'a -> printer0 + + let output_formatting_lit fmting_lit doc = + let open CamlinternalFormatBasics in + match fmting_lit with + | Close_box -> close_box doc + | Close_tag -> close_tag doc + | Break (_, width, offset) -> break ~spaces:width ~indent:offset doc + | FFlush -> flush doc + | Force_newline -> force_newline doc + | Flush_newline -> force_stop doc + | Magic_size (_, n) -> with_size n doc + | Escaped_at -> char '@' doc + | Escaped_percent -> char '%' doc + | Scan_indic c -> doc |> char '@' |> char c + + let to_string doc = + let b = Buffer.create 20 in + let convert = function + | Text s -> Buffer.add_string b s + | _ -> () + in + fold (fun () x -> convert x) () doc; + Buffer.contents b + + let box_type = + let open CamlinternalFormatBasics in + function + | Pp_fits -> H + | Pp_hbox -> H + | Pp_vbox -> V + | Pp_hovbox -> HoV + | Pp_hvbox -> HV + | Pp_box -> B + + let rec compose_acc acc doc = + let open CamlinternalFormat in + match acc with + | CamlinternalFormat.Acc_formatting_lit (p, f) -> + doc |> compose_acc p |> output_formatting_lit f + | Acc_formatting_gen (p, Acc_open_tag acc') -> + let tag = to_string (compose_acc acc' empty) in + let doc = compose_acc p doc in + doc |> open_tag (Format.String_tag tag) + | Acc_formatting_gen (p, Acc_open_box acc') -> + let doc = compose_acc p doc in + let box = to_string (compose_acc acc' empty) in + let (indent, bty) = CamlinternalFormat.open_box_of_string box in + doc |> open_box (box_type bty) indent + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> + doc |> compose_acc p |> string s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> doc |> compose_acc p |> char c + | Acc_delay (p, f) -> doc |> compose_acc p |> f + | Acc_flush p -> doc |> compose_acc p |> flush + | Acc_invalid_arg (_p, msg) -> invalid_arg msg; + | End_of_acc -> doc + + let kprintf k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc doc -> doc |> compose_acc acc |> k ) + End_of_acc fmt + + let printf doc = kprintf Fun.id doc + let kmsg k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> k (compose_acc acc empty)) + End_of_acc fmt + + let msg fmt = kmsg Fun.id fmt + +end + +(** Compatibility interface *) + +type doc = Doc.t +type t = doc +type formatter = doc ref +type 'a printer = formatter -> 'a -> unit + +let formatter d = d + +(** {1 Primitive functions }*) + +let pp_print_string ppf s = ppf := Doc.string s !ppf + +let pp_print_as ppf size s = + ppf := !ppf |> Doc.with_size size |> Doc.string s + +let pp_print_substring ~pos ~len ppf s = + ppf := Doc.string (String.sub s pos len) !ppf + +let pp_print_substring_as ~pos ~len ppf size s = + ppf := + !ppf + |> Doc.with_size size + |> Doc.string (String.sub s pos len) + +let pp_print_bytes ppf s = ppf := Doc.string (Bytes.to_string s) !ppf +let pp_print_text ppf s = ppf := Doc.text s !ppf +let pp_print_char ppf c = ppf := Doc.char c !ppf +let pp_print_int ppf c = ppf := Doc.int c !ppf +let pp_print_float ppf f = ppf := Doc.float f !ppf +let pp_print_bool ppf b = ppf := Doc.bool b !ppf +let pp_print_nothing _ _ = () + +let pp_close_box ppf () = ppf := Doc.close_box !ppf +let pp_close_stag ppf () = ppf := Doc.close_tag !ppf + +let pp_print_break ppf spaces indent = ppf := Doc.break ~spaces ~indent !ppf + +let pp_print_custom_break ppf ~fits ~breaks = + ppf := Doc.custom_break ~fits ~breaks !ppf + +let pp_print_space ppf () = pp_print_break ppf 1 0 +let pp_print_cut ppf () = pp_print_break ppf 0 0 + +let pp_print_flush ppf () = ppf := Doc.flush !ppf +let pp_force_newline ppf () = ppf := Doc.force_newline !ppf +let pp_print_newline ppf () = ppf := Doc.force_stop !ppf +let pp_print_if_newline ppf () =ppf := Doc.if_newline !ppf + +let pp_open_stag ppf stag = ppf := !ppf |> Doc.open_tag stag + +let pp_open_box_gen ppf indent bxty = + let box_type = Doc.box_type bxty in + ppf := !ppf |> Doc.open_box box_type indent + +let pp_open_box ppf indent = pp_open_box_gen ppf indent Pp_box + + +let pp_open_tbox ppf () = ppf := !ppf |> Doc.open_tbox + +let pp_close_tbox ppf () = ppf := !ppf |> Doc.close_tbox + +let pp_set_tab ppf () = ppf := !ppf |> Doc.set_tab + +let pp_print_tab ppf () = ppf := !ppf |> Doc.tab + +let pp_print_tbreak ppf width offset = + ppf := !ppf |> Doc.tab_break ~width ~offset + +let pp_doc ppf doc = ppf := Doc.append !ppf doc + +module Driver = struct + (* Interpret a formatting entity on a formatter. *) + let output_formatting_lit ppf + (fmting_lit:CamlinternalFormatBasics.formatting_lit) + = match fmting_lit with + | Close_box -> pp_close_box ppf () + | Close_tag -> pp_close_stag ppf () + | Break (_, width, offset) -> pp_print_break ppf width offset + | FFlush -> pp_print_flush ppf () + | Force_newline -> pp_force_newline ppf () + | Flush_newline -> pp_print_newline ppf () + | Magic_size (_, _) -> () + | Escaped_at -> pp_print_char ppf '@' + | Escaped_percent -> pp_print_char ppf '%' + | Scan_indic c -> pp_print_char ppf '@'; pp_print_char ppf c + + + + let compute_tag output tag_acc = + let buf = Buffer.create 16 in + let buf_fmt = Format.formatter_of_buffer buf in + let ppf = ref Doc.empty in + output ppf tag_acc; + pp_print_flush ppf (); + Doc.format buf_fmt !ppf; + let len = Buffer.length buf in + if len < 2 then Buffer.contents buf + else Buffer.sub buf 1 (len - 2) + + (* Recursively output an "accumulator" containing a reversed list of + printing entities (string, char, flus, ...) in an output_stream. *) + (* Differ from Printf.output_acc by the interpretation of formatting. *) + (* Used as a continuation of CamlinternalFormat.make_printf. *) + let rec output_acc ppf (acc: _ CamlinternalFormat.acc) = + match acc with + | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s) + | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> + output_acc ppf p; + pp_print_as ppf size s; + | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c) + | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> + output_acc ppf p; + pp_print_as ppf size (String.make 1 c); + | Acc_formatting_lit (p, f) -> + output_acc ppf p; + output_formatting_lit ppf f; + | Acc_formatting_gen (p, Acc_open_tag acc') -> + output_acc ppf p; + pp_open_stag ppf (Format.String_tag (compute_tag output_acc acc')) + | Acc_formatting_gen (p, Acc_open_box acc') -> + output_acc ppf p; + let (indent, bty) = + let box_info = compute_tag output_acc acc' in + CamlinternalFormat.open_box_of_string box_info + in + pp_open_box_gen ppf indent bty + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> output_acc ppf p; pp_print_string ppf s; + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> output_acc ppf p; pp_print_char ppf c; + | Acc_delay (p, f) -> output_acc ppf p; f ppf; + | Acc_flush p -> output_acc ppf p; pp_print_flush ppf (); + | Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg; + | End_of_acc -> () +end + +let kfprintf k ppf (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> Driver.output_acc ppf acc; k ppf) + End_of_acc fmt +let fprintf doc fmt = kfprintf ignore doc fmt + + +let kdprintf k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> k (fun ppf -> Driver.output_acc ppf acc)) + End_of_acc fmt + +let dprintf fmt = kdprintf (fun i -> i) fmt + +let doc_printf fmt = + let ppf = ref Doc.empty in + kfprintf (fun _ -> let doc = !ppf in ppf := Doc.empty; doc) ppf fmt + +let kdoc_printf k fmt = + let ppf = ref Doc.empty in + kfprintf (fun ppf -> + let doc = !ppf in + ppf := Doc.empty; + k doc + ) + ppf fmt + +let doc_printer f x doc = + let r = ref doc in + f r x; + !r + +type 'a format_printer = Format.formatter -> 'a -> unit + +let format_printer f ppf x = + let doc = doc_printer f x Doc.empty in + Doc.format ppf doc +let compat = format_printer +let compat1 f p1 = compat (f p1) +let compat2 f p1 p2 = compat (f p1 p2) + +let kasprintf k fmt = + kdoc_printf (fun doc -> k (Format.asprintf "%a" Doc.format doc)) fmt +let asprintf fmt = kasprintf Fun.id fmt + +let pp_print_iter ?(pp_sep=pp_print_cut) iter elt ppf c = + let sep = doc_printer pp_sep () in + ppf:= Doc.iter ~sep ~iter (doc_printer elt) c !ppf + +let pp_print_list ?(pp_sep=pp_print_cut) elt ppf l = + ppf := Doc.list ~sep:(doc_printer pp_sep ()) (doc_printer elt) l !ppf + +let pp_print_array ?pp_sep elt ppf a = + pp_print_iter ?pp_sep Array.iter elt ppf a +let pp_print_seq ?pp_sep elt ppf s = pp_print_iter ?pp_sep Seq.iter elt ppf s + +let pp_print_option ?(none=fun _ () -> ()) elt ppf o = + ppf := Doc.option ~none:(doc_printer none ()) (doc_printer elt) o !ppf + +let pp_print_result ~ok ~error ppf r = + ppf := Doc.result ~ok:(doc_printer ok) ~error:(doc_printer error) r !ppf + +let pp_print_either ~left ~right ppf e = + ppf := Doc.either ~left:(doc_printer left) ~right:(doc_printer right) e !ppf + +let comma ppf () = fprintf ppf ",@ " + +let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) = + let left_column_size = + List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines in + let lines_nb = List.length lines in + let ellipsed_first, ellipsed_last = + match max_lines with + | Some max_lines when lines_nb > max_lines -> + let printed_lines = max_lines - 1 in (* the ellipsis uses one line *) + let lines_before = printed_lines / 2 + printed_lines mod 2 in + let lines_after = printed_lines / 2 in + (lines_before, lines_nb - lines_after - 1) + | _ -> (-1, -1) + in + fprintf ppf "@["; + List.iteri (fun k (line_l, line_r) -> + if k = ellipsed_first then fprintf ppf "...@,"; + if ellipsed_first <= k && k <= ellipsed_last then () + else fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r + ) lines; + fprintf ppf "@]" + +let deprecated_printer pr ppf = ppf := Doc.add !ppf (Doc.Deprecated pr) diff --git a/upstream/ocaml_503/utils/format_doc.mli b/upstream/ocaml_503/utils/format_doc.mli new file mode 100644 index 000000000..77d9d11cc --- /dev/null +++ b/upstream/ocaml_503/utils/format_doc.mli @@ -0,0 +1,297 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Composable document for the {!Format} formatting engine. *) + +(** This module introduces a pure and immutable document type which represents a + sequence of formatting instructions to be printed by a formatting engine at + later point. At the same time, it also provides format string interpreter + which produces this document type from format string and their associated + printers. + + The module is designed to be source compatible with code defining format + printers: replacing `Format` by `Format_doc` in your code will convert + `Format` printers to `Format_doc` printers. +*) + +(** Definitions and immutable API for composing documents *) +module Doc: sig + + (** {2 Type definitions and core functions }*) + + (** Format box types *) + type box_type = + | H + | V + | HV + | HoV + | B + + type stag = Format.stag + + (** Base formatting instruction recognized by {!Format} *) + type element = + | Text of string + | With_size of int + | Open_box of { kind: box_type ; indent:int } + | Close_box + | Open_tag of Format.stag + | Close_tag + | Open_tbox + | Tab_break of { width : int; offset : int } + | Set_tab + | Close_tbox + | Simple_break of { spaces : int; indent : int } + | Break of { fits : string * int * string as 'a; breaks : 'a } + | Flush of { newline:bool } + | Newline + | If_newline + + | Deprecated of (Format.formatter -> unit) + (** Escape hatch: a {!Format} printer used to provide backward-compatibility + for user-defined printer (from the [#install_printer] toplevel directive + for instance). *) + + (** Immutable document type*) + type t + + type ('a,'b) fmt = ('a, t, t,'b) format4 + + type printer0 = t -> t + type 'a printer = 'a -> printer0 + + + (** Empty document *) + val empty: t + + (** [format ppf doc] sends the format instruction of [doc] to the Format's + formatter [doc]. *) + val format: Format.formatter -> t -> unit + + (** Fold over a document as a sequence of instructions *) + val fold: ('acc -> element -> 'acc) -> 'acc -> t -> 'acc + + (** {!msg} and {!kmsg} produce a document from a format string and its + argument *) + val msg: ('a,t) fmt -> 'a + val kmsg: (t -> 'b) -> ('a,'b) fmt -> 'a + + (** {!printf} and {!kprintf} produce a printer from a format string and its + argument*) + val printf: ('a, printer0) fmt -> 'a + val kprintf: (t -> 'b) -> ('a, t -> 'b) fmt -> 'a + + (** The functions below mirror {!Format} printers, without the [pp_print_] + prefix naming convention *) + val open_box: box_type -> int -> printer0 + val close_box: printer0 + + val text: string printer + val string: string printer + val bytes: bytes printer + val with_size: int printer + + val int: int printer + val float: float printer + val char: char printer + val bool: bool printer + + val space: printer0 + val cut: printer0 + val break: spaces:int -> indent:int -> printer0 + + val custom_break: + fits:(string * int * string as 'a) -> breaks:'a -> printer0 + val force_newline: printer0 + val if_newline: printer0 + + val flush: printer0 + val force_stop: printer0 + + val open_tbox: printer0 + val set_tab: printer0 + val tab: printer0 + val tab_break: width:int -> offset:int -> printer0 + val close_tbox: printer0 + + val open_tag: stag printer + val close_tag: printer0 + + val list: ?sep:printer0 -> 'a printer -> 'a list printer + val iter: + ?sep:printer0 -> iter:(('a -> unit) -> 'b -> unit) -> 'a printer + ->'b printer + val array: ?sep:printer0 -> 'a printer -> 'a array printer + val seq: ?sep:printer0 -> 'a printer -> 'a Seq.t printer + + val option: ?none:printer0 -> 'a printer -> 'a option printer + val result: ok:'a printer -> error:'e printer -> ('a,'e) result printer + val either: left:'a printer -> right:'b printer -> ('a,'b) Either.t printer + +end + +(** {1 Compatibility API} *) + +(** The functions and types below provides source compatibility with format +printers and conversion function from {!Format_doc} printers to {!Format} +printers. The reverse direction is implemented using an escape hatch in the +formatting instruction and should only be used to preserve backward +compatibility. *) + +type doc = Doc.t +type t = doc +type formatter +type 'a printer = formatter -> 'a -> unit + +val formatter: doc ref -> formatter +(** [formatter rdoc] creates a {!formatter} that updates the [rdoc] reference *) + +(** Translate a {!Format_doc} printer to a {!Format} one. *) +type 'a format_printer = Format.formatter -> 'a -> unit +val compat: 'a printer -> 'a format_printer +val compat1: ('p1 -> 'a printer) -> ('p1 -> 'a format_printer) +val compat2: ('p1 -> 'p2 -> 'a printer) -> ('p1 -> 'p2 -> 'a format_printer) + +(** If necessary, embbed a {!Format} printer inside a formatting instruction + stream. This breaks every guarantees provided by {!Format_doc}. *) +val deprecated_printer: (Format.formatter -> unit) -> formatter -> unit + + +(** {2 Format string interpreters }*) + +val fprintf : formatter -> ('a, formatter,unit) format -> 'a +val kfprintf: + (formatter -> 'a) -> formatter -> + ('b, formatter, unit, 'a) format4 -> 'b + +val asprintf : ('a, formatter, unit, string) format4 -> 'a +val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b + + +val dprintf : ('a, formatter, unit, formatter -> unit) format4 -> 'a +val kdprintf: + ((formatter -> unit) -> 'a) -> + ('b, formatter, unit, 'a) format4 -> 'b + +(** {!doc_printf} and {!kdoc_printf} creates a document directly *) +val doc_printf: ('a, formatter, unit, doc) format4 -> 'a +val kdoc_printf: (doc -> 'r) -> ('a, formatter, unit, 'r) format4 -> 'a + +(** {2 Compatibility with {!Doc} }*) + +val doc_printer: 'a printer -> 'a Doc.printer +val pp_doc: doc printer + +(** {2 Source compatibility with Format}*) + +(** {3 String printers } *) + +val pp_print_string: string printer +val pp_print_substring: pos:int -> len:int -> string printer +val pp_print_text: string printer +val pp_print_bytes: bytes printer + +val pp_print_as: formatter -> int -> string -> unit +val pp_print_substring_as: + pos:int -> len:int -> formatter -> int -> string -> unit + +(** {3 Primitive type printers }*) + +val pp_print_char: char printer +val pp_print_int: int printer +val pp_print_float: float printer +val pp_print_bool: bool printer +val pp_print_nothing: unit printer + +(** {3 Printer combinators }*) + +val pp_print_iter: + ?pp_sep:unit printer -> (('a -> unit) -> 'b -> unit) -> + 'a printer -> 'b printer + +val pp_print_list: ?pp_sep:unit printer -> 'a printer -> 'a list printer +val pp_print_array: ?pp_sep:unit printer -> 'a printer -> 'a array printer +val pp_print_seq: ?pp_sep:unit printer -> 'a printer -> 'a Seq.t printer + +val pp_print_option: ?none:unit printer -> 'a printer -> 'a option printer +val pp_print_result: ok:'a printer -> error:'e printer -> ('a,'e) result printer +val pp_print_either: + left:'a printer -> right:'b printer -> ('a,'b) Either.t printer + + +(** {3 Boxes and tags }*) + +val pp_open_stag: Format.stag printer +val pp_close_stag: unit printer + +val pp_open_box: int printer +val pp_close_box: unit printer + +(** {3 Break hints} *) + +val pp_print_space: unit printer +val pp_print_cut: unit printer +val pp_print_break: formatter -> int -> int -> unit +val pp_print_custom_break: + formatter -> fits:(string * int * string as 'c) -> breaks:'c -> unit + +(** {3 Tabulations }*) + +val pp_open_tbox: unit printer +val pp_close_tbox: unit printer +val pp_set_tab: unit printer +val pp_print_tab: unit printer +val pp_print_tbreak: formatter -> int -> int -> unit + +(** {3 Newlines and flushing }*) + +val pp_print_if_newline: unit printer +val pp_force_newline: unit printer +val pp_print_flush: unit printer +val pp_print_newline: unit printer + +(** {1 Compiler specific functions }*) + +(** {2 Separators }*) + +val comma: unit printer + +(** {2 Compiler output} *) + +val pp_two_columns : + ?sep:string -> ?max_lines:int -> + formatter -> (string * string) list -> unit +(** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two + columns separated by [sep] ("|" by default). [max_lines] can be used to + indicate a maximum number of lines to print -- an ellipsis gets inserted at + the middle if the input has too many lines. + + Example: + + {v pp_two_columns ~max_lines:3 Format.std_formatter [ + "abc", "hello"; + "def", "zzz"; + "a" , "bllbl"; + "bb" , "dddddd"; + ] v} + + prints + + {v + abc | hello + ... + bb | dddddd + v} +*) diff --git a/upstream/ocaml_503/utils/identifiable.ml b/upstream/ocaml_503/utils/identifiable.ml new file mode 100644 index 000000000..9bbfb6573 --- /dev/null +++ b/upstream/ocaml_503/utils/identifiable.ml @@ -0,0 +1,249 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module type Thing = sig + type t + + include Hashtbl.HashedType with type t := t + include Map.OrderedType with type t := t + + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +end + +module type Set = sig + module T : Set.OrderedType + include Set.S + with type elt = T.t + and type t = Set.Make (T).t + + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit + val to_string : t -> string + val of_list : elt list -> t + val map : (elt -> elt) -> t -> t +end + +module type Map = sig + module T : Map.OrderedType + include Map.S + with type key = T.t + and type 'a t = 'a Map.Make (T).t + + val of_list : (key * 'a) list -> 'a t + + val disjoint_union : + ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> + 'a t -> 'a t + + val union_right : 'a t -> 'a t -> 'a t + + val union_left : 'a t -> 'a t -> 'a t + + val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t + val rename : key t -> key -> key + val map_keys : (key -> key) -> 'a t -> 'a t + val keys : 'a t -> Set.Make(T).t + val data : 'a t -> 'a list + val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t + val transpose_keys_and_data : key t -> key t + val transpose_keys_and_data_set : key t -> Set.Make(T).t t + val print : + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit +end + +module type Tbl = sig + module T : sig + type t + include Map.OrderedType with type t := t + include Hashtbl.HashedType with type t := t + end + include Hashtbl.S + with type key = T.t + and type 'a t = 'a Hashtbl.Make (T).t + + val to_list : 'a t -> (T.t * 'a) list + val of_list : (T.t * 'a) list -> 'a t + + val to_map : 'a t -> 'a Map.Make(T).t + val of_map : 'a Map.Make(T).t -> 'a t + val memoize : 'a t -> (key -> 'a) -> key -> 'a + val map : 'a t -> ('a -> 'b) -> 'b t +end + +module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct + type t = A.t * B.t + + let compare (a1, b1) (a2, b2) = + let c = A.compare a1 a2 in + if c <> 0 then c + else B.compare b1 b2 + + let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b + let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b) + let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2 + let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b +end + +module Make_map (T : Thing) = struct + include Map.Make (T) + + let of_list l = + List.fold_left (fun map (id, v) -> add id v map) empty l + + let disjoint_union ?eq ?print m1 m2 = + union (fun id v1 v2 -> + let ok = match eq with + | None -> false + | Some eq -> eq v1 v2 + in + if not ok then + let err = + match print with + | None -> + Format.asprintf "Map.disjoint_union %a" T.print id + | Some print -> + Format.asprintf "Map.disjoint_union %a => %a <> %a" + T.print id print v1 print v2 + in + Misc.fatal_error err + else Some v1) + m1 m2 + + let union_right m1 m2 = + merge (fun _id x y -> match x, y with + | None, None -> None + | None, Some v + | Some v, None + | Some _, Some v -> Some v) + m1 m2 + + let union_left m1 m2 = union_right m2 m1 + + let union_merge f m1 m2 = + let aux _ m1 m2 = + match m1, m2 with + | None, m | m, None -> m + | Some m1, Some m2 -> Some (f m1 m2) + in + merge aux m1 m2 + + let rename m v = + try find v m + with Not_found -> v + + let map_keys f m = + of_list (List.map (fun (k, v) -> f k, v) (bindings m)) + + let print f ppf s = + let elts ppf s = iter (fun id v -> + Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in + Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s + + module T_set = Set.Make (T) + + let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty + + let data t = List.map snd (bindings t) + + let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty + + let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty + let transpose_keys_and_data_set map = + fold (fun k v m -> + let set = + match find v m with + | exception Not_found -> + T_set.singleton k + | set -> + T_set.add k set + in + add v set m) + map empty +end + +module Make_set (T : Thing) = struct + include Set.Make (T) + + let output oc s = + Printf.fprintf oc " ( "; + iter (fun v -> Printf.fprintf oc "%a " T.output v) s; + Printf.fprintf oc ")" + + let print ppf s = + let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in + Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s + + let to_string s = Format.asprintf "%a" print s + + let of_list l = match l with + | [] -> empty + | [t] -> singleton t + | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q + + let map f s = of_list (List.map f (elements s)) +end + +module Make_tbl (T : Thing) = struct + include Hashtbl.Make (T) + + module T_map = Make_map (T) + + let to_list t = + fold (fun key datum elts -> (key, datum)::elts) t [] + + let of_list elts = + let t = create 42 in + List.iter (fun (key, datum) -> add t key datum) elts; + t + + let to_map v = fold T_map.add v T_map.empty + + let of_map m = + let t = create (T_map.cardinal m) in + T_map.iter (fun k v -> add t k v) m; + t + + let memoize t f = fun key -> + try find t key with + | Not_found -> + let r = f key in + add t key r; + r + + let map t f = + of_map (T_map.map f (to_map t)) +end + +module type S = sig + type t + + module T : Thing with type t = t + include Thing with type t := T.t + + module Set : Set with module T := T + module Map : Map with module T := T + module Tbl : Tbl with module T := T +end + +module Make (T : Thing) = struct + module T = T + include T + + module Set = Make_set (T) + module Map = Make_map (T) + module Tbl = Make_tbl (T) +end diff --git a/upstream/ocaml_503/utils/identifiable.mli b/upstream/ocaml_503/utils/identifiable.mli new file mode 100644 index 000000000..0da5a6619 --- /dev/null +++ b/upstream/ocaml_503/utils/identifiable.mli @@ -0,0 +1,113 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Uniform interface for common data structures over various things. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +module type Thing = sig + type t + + include Hashtbl.HashedType with type t := t + include Map.OrderedType with type t := t + + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +end + +module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t + +module type Set = sig + module T : Set.OrderedType + include Set.S + with type elt = T.t + and type t = Set.Make (T).t + + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit + val to_string : t -> string + val of_list : elt list -> t + val map : (elt -> elt) -> t -> t +end + +module type Map = sig + module T : Map.OrderedType + include Map.S + with type key = T.t + and type 'a t = 'a Map.Make (T).t + + val of_list : (key * 'a) list -> 'a t + + (** [disjoint_union m1 m2] contains all bindings from [m1] and + [m2]. If some binding is present in both and the associated + value is not equal, a Fatal_error is raised *) + val disjoint_union : + ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> + 'a t -> 'a t + + (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If + some binding is present in both, the one from [m2] is taken *) + val union_right : 'a t -> 'a t -> 'a t + + (** [union_left m1 m2 = union_right m2 m1] *) + val union_left : 'a t -> 'a t -> 'a t + + val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t + val rename : key t -> key -> key + val map_keys : (key -> key) -> 'a t -> 'a t + val keys : 'a t -> Set.Make(T).t + val data : 'a t -> 'a list + val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t + val transpose_keys_and_data : key t -> key t + val transpose_keys_and_data_set : key t -> Set.Make(T).t t + val print : + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit +end + +module type Tbl = sig + module T : sig + type t + include Map.OrderedType with type t := t + include Hashtbl.HashedType with type t := t + end + include Hashtbl.S + with type key = T.t + and type 'a t = 'a Hashtbl.Make (T).t + + val to_list : 'a t -> (T.t * 'a) list + val of_list : (T.t * 'a) list -> 'a t + + val to_map : 'a t -> 'a Map.Make(T).t + val of_map : 'a Map.Make(T).t -> 'a t + val memoize : 'a t -> (key -> 'a) -> key -> 'a + val map : 'a t -> ('a -> 'b) -> 'b t +end + +module type S = sig + type t + + module T : Thing with type t = t + include Thing with type t := T.t + + module Set : Set with module T := T + module Map : Map with module T := T + module Tbl : Tbl with module T := T +end + +module Make (T : Thing) : S with type t := T.t diff --git a/upstream/ocaml_503/utils/int_replace_polymorphic_compare.ml b/upstream/ocaml_503/utils/int_replace_polymorphic_compare.ml new file mode 100644 index 000000000..7cd6bf109 --- /dev/null +++ b/upstream/ocaml_503/utils/int_replace_polymorphic_compare.ml @@ -0,0 +1,8 @@ +let ( = ) : int -> int -> bool = Stdlib.( = ) +let ( <> ) : int -> int -> bool = Stdlib.( <> ) +let ( < ) : int -> int -> bool = Stdlib.( < ) +let ( > ) : int -> int -> bool = Stdlib.( > ) +let ( <= ) : int -> int -> bool = Stdlib.( <= ) +let ( >= ) : int -> int -> bool = Stdlib.( >= ) + +let compare : int -> int -> int = Stdlib.compare diff --git a/upstream/ocaml_503/utils/int_replace_polymorphic_compare.mli b/upstream/ocaml_503/utils/int_replace_polymorphic_compare.mli new file mode 100644 index 000000000..689e741b6 --- /dev/null +++ b/upstream/ocaml_503/utils/int_replace_polymorphic_compare.mli @@ -0,0 +1,8 @@ +val ( = ) : int -> int -> bool +val ( <> ) : int -> int -> bool +val ( < ) : int -> int -> bool +val ( > ) : int -> int -> bool +val ( <= ) : int -> int -> bool +val ( >= ) : int -> int -> bool + +val compare : int -> int -> int diff --git a/upstream/ocaml_503/utils/lazy_backtrack.ml b/upstream/ocaml_503/utils/lazy_backtrack.ml new file mode 100644 index 000000000..13e4eb440 --- /dev/null +++ b/upstream/ocaml_503/utils/lazy_backtrack.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type ('a,'b) t = ('a,'b) eval ref + +and ('a,'b) eval = + | Done of 'b + | Raise of exn + | Thunk of 'a + +type undo = + | Nil + | Cons : ('a, 'b) t * 'a * undo -> undo + +type log = undo ref + +let force f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e + +let get_arg x = + match !x with Thunk a -> Some a | _ -> None + +let get_contents x = + match !x with + | Thunk a -> Either.Left a + | Done b -> Either.Right b + | Raise e -> raise e + +let create x = + ref (Thunk x) + +let create_forced y = + ref (Done y) + +let create_failed e = + ref (Raise e) + +let log () = + ref Nil + +let force_logged log f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | (Error _ as err : _ result) -> + x := Done err; + log := Cons(x, e, !log); + err + | Ok _ as res -> + x := Done res; + res + | exception e -> + x := Raise e; + raise e + +let backtrack log = + let rec loop = function + | Nil -> () + | Cons(x, e, rest) -> + x := Thunk e; + loop rest + in + loop !log diff --git a/upstream/ocaml_503/utils/lazy_backtrack.mli b/upstream/ocaml_503/utils/lazy_backtrack.mli new file mode 100644 index 000000000..4e2fbd380 --- /dev/null +++ b/upstream/ocaml_503/utils/lazy_backtrack.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type ('a,'b) t + +type log + +val force : ('a -> 'b) -> ('a,'b) t -> 'b +val create : 'a -> ('a,'b) t +val get_arg : ('a,'b) t -> 'a option +val get_contents : ('a,'b) t -> ('a,'b) Either.t +val create_forced : 'b -> ('a, 'b) t +val create_failed : exn -> ('a, 'b) t + +(* [force_logged log f t] is equivalent to [force f t] but if [f] + returns [Error _] then [t] is recorded in [log]. [backtrack log] + will then reset all the recorded [t]s back to their original + state. *) +val log : unit -> log +val force_logged : + log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result +val backtrack : log -> unit diff --git a/upstream/ocaml_503/utils/linkdeps.ml b/upstream/ocaml_503/utils/linkdeps.ml new file mode 100644 index 000000000..824c898e0 --- /dev/null +++ b/upstream/ocaml_503/utils/linkdeps.ml @@ -0,0 +1,142 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Hugo Heuzard *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Style = Misc.Style + +type compunit = string + +type filename = string + +type compunit_and_source = { + compunit : compunit; + filename : filename; +} + +module Compunit_and_source = struct + type t = compunit_and_source + module Set = Set.Make(struct type nonrec t = t let compare = compare end) +end + +type refs = Compunit_and_source.Set.t + +type t = { + complete : bool; + missing_compunits : (compunit, refs) Hashtbl.t; + provided_compunits : (compunit, filename list) Hashtbl.t; + badly_ordered_deps : (Compunit_and_source.t, refs) Hashtbl.t; +} + +type error = + | Missing_implementations of (compunit * compunit_and_source list) list + | Wrong_link_order of (compunit_and_source * compunit_and_source list) list + | Multiple_definitions of (compunit * filename list) list + +let create ~complete = { + complete; + missing_compunits = Hashtbl.create 17; + provided_compunits = Hashtbl.create 17; + badly_ordered_deps = Hashtbl.create 17; +} + +let required t compunit = Hashtbl.mem t.missing_compunits compunit + +let update t k f = + let v = Hashtbl.find_opt t k in + Hashtbl.replace t k (f v) + +let add_required t by (name : string) = + let add s = + Compunit_and_source.Set.add by + (Option.value s ~default:Compunit_and_source.Set.empty) in + (try + let filename = List.hd (Hashtbl.find t.provided_compunits name) in + update t.badly_ordered_deps {compunit = name; filename } add + with Not_found -> ()); + update t.missing_compunits name add + +let add t ~filename ~compunit ~provides ~requires = + List.iter (add_required t {compunit; filename}) requires; + List.iter (fun p -> + Hashtbl.remove t.missing_compunits p; + let l = Option.value ~default:[] + (Hashtbl.find_opt t.provided_compunits p) in + Hashtbl.replace t.provided_compunits p (filename :: l)) provides + +let check t = + let of_seq s = + Seq.map (fun (k,v) -> k, Compunit_and_source.Set.elements v) s + |> List.of_seq + in + let missing = of_seq (Hashtbl.to_seq t.missing_compunits) in + let badly_ordered_deps = of_seq (Hashtbl.to_seq t.badly_ordered_deps) in + let duplicated = + Hashtbl.to_seq t.provided_compunits + |> Seq.filter (fun (_, files) -> List.compare_length_with files 1 > 0) + |> List.of_seq + in + match duplicated, badly_ordered_deps, missing with + | [], [], [] -> None + | [], [], l -> + if t.complete + then Some (Missing_implementations l) + else None + | [], l, _ -> + Some (Wrong_link_order l) + | l, _, _ -> + Some (Multiple_definitions l) + +(* Error report *) + +open Format_doc + +let print_reference print_fname ppf {compunit; filename} = + fprintf ppf "%a (%a)" Style.inline_code compunit print_fname filename + +let pp_list_comma f = + pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") f + +let report_error_doc ~print_filename ppf = function + | Missing_implementations l -> + let print_modules ppf = + List.iter + (fun (md, rq) -> + fprintf ppf "@ @[%a referenced from %a@]" + Style.inline_code md + (pp_list_comma (print_reference print_filename)) rq) + in + fprintf ppf + "@[No implementation provided for the following modules:%a@]" + print_modules l + | Wrong_link_order l -> + let depends_on ppf (dep, depending) = + fprintf ppf "@ @[%a depends on %a@]" + (pp_list_comma (print_reference print_filename)) depending + (print_reference print_filename) dep + in + fprintf ppf "@[Wrong link order:%a@]" + (pp_list_comma depends_on) l + | Multiple_definitions l -> + let print ppf (compunit, files) = + fprintf ppf + "@ @[Multiple definitions of module %a in files %a@]" + Style.inline_code compunit + (pp_list_comma (Style.as_inline_code print_filename)) files + + in + fprintf ppf "@[ Duplicated implementations:%a@]" + (pp_list_comma print) l + +let report_error ~print_filename = + Format_doc.compat (report_error_doc ~print_filename) diff --git a/upstream/ocaml_503/utils/linkdeps.mli b/upstream/ocaml_503/utils/linkdeps.mli new file mode 100644 index 000000000..070b0e538 --- /dev/null +++ b/upstream/ocaml_503/utils/linkdeps.mli @@ -0,0 +1,64 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Hugo Heuzard *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t +(** The state of the linking check. + It keeps track of compilation units provided and required so far. *) + +type compunit = string + +type filename = string + +val create : complete:bool -> t +(** [create ~complete] returns an empty state. If [complete] is + [true], missing compilation units will be treated as errors. *) + +val add : t + -> filename:filename -> compunit:compunit + -> provides:compunit list -> requires:compunit list -> unit +(** [add t ~filename ~compunit ~provides ~requires] registers the + compilation unit [compunit] found in [filename] to [t]. + - [provides] are units and sub-units provided by [compunit] + - [requires] are units required by [compunit] + + [add] should be called in reverse topological order. *) + +val required : t -> compunit -> bool +(** [required t compunit] returns [true] if [compunit] is a dependency of + previously added compilation units. *) + +type compunit_and_source = { + compunit : compunit; + filename : filename; +} + +type error = + | Missing_implementations of (compunit * compunit_and_source list) list + | Wrong_link_order of (compunit_and_source * compunit_and_source list) list + | Multiple_definitions of (compunit * filename list) list + +val check : t -> error option +(** [check t] should be called once all the compilation units to be linked + have been added. It returns some error if: + - There are some missing implementations + and [complete] is [true] + - Some implementation appear + before their dependencies *) + + +val report_error : + print_filename:string Format_doc.printer -> error Format_doc.format_printer +val report_error_doc : + print_filename:string Format_doc.printer -> error Format_doc.printer diff --git a/upstream/ocaml_503/utils/load_path.ml b/upstream/ocaml_503/utils/load_path.ml new file mode 100644 index 000000000..49f593f98 --- /dev/null +++ b/upstream/ocaml_503/utils/load_path.ml @@ -0,0 +1,239 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Local_store + +module STbl = Misc.Stdlib.String.Tbl + +(* Mapping from basenames to full filenames *) +type registry = string STbl.t + +let visible_files : registry ref = s_table STbl.create 42 +let visible_files_uncap : registry ref = s_table STbl.create 42 + +let hidden_files : registry ref = s_table STbl.create 42 +let hidden_files_uncap : registry ref = s_table STbl.create 42 + +module Dir = struct + type t = { + path : string; + files : string list; + hidden : bool; + } + + let path t = t.path + let files t = t.files + let hidden t = t.hidden + + let find t fn = + if List.mem fn t.files then + Some (Filename.concat t.path fn) + else + None + + let find_normalized t fn = + let fn = Misc.normalized_unit_filename fn in + let search base = + if Misc.normalized_unit_filename base = fn then + Some (Filename.concat t.path base) + else + None + in + List.find_map search t.files + + (* For backward compatibility reason, simulate the behavior of + [Misc.find_in_path]: silently ignore directories that don't exist + + treat [""] as the current directory. *) + let readdir_compat dir = + try + Sys.readdir (if dir = "" then Filename.current_dir_name else dir) + with Sys_error _ -> + [||] + + let create ~hidden path = + { path; files = Array.to_list (readdir_compat path); hidden } +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string + +let visible_dirs = s_ref [] +let hidden_dirs = s_ref [] +let no_auto_include _ _ = raise Not_found +let auto_include_callback = ref no_auto_include + +let reset () = + assert (not Config.merlin || Local_store.is_bound ()); + STbl.clear !hidden_files; + STbl.clear !hidden_files_uncap; + STbl.clear !visible_files; + STbl.clear !visible_files_uncap; + hidden_dirs := []; + visible_dirs := []; + auto_include_callback := no_auto_include + +let get_visible () = List.rev !visible_dirs + +let get_path_list () = + Misc.rev_map_end Dir.path !visible_dirs (List.rev_map Dir.path !hidden_dirs) + +type paths = + { visible : string list; + hidden : string list } + +let get_paths () = + { visible = List.rev_map Dir.path !visible_dirs; + hidden = List.rev_map Dir.path !hidden_dirs } + +let get_visible_path_list () = List.rev_map Dir.path !visible_dirs +let get_hidden_path_list () = List.rev_map Dir.path !hidden_dirs + +(* Optimized version of [add] below, for use in [init] and [remove_dir]: since + we are starting from an empty cache, we can avoid checking whether a unit + name already exists in the cache simply by adding entries in reverse + order. *) +let prepend_add dir = + List.iter (fun base -> + Result.iter (fun filename -> + let fn = Filename.concat dir.Dir.path base in + if dir.Dir.hidden then begin + STbl.replace !hidden_files base fn; + STbl.replace !hidden_files_uncap filename fn + end else begin + STbl.replace !visible_files base fn; + STbl.replace !visible_files_uncap filename fn + end) + (Misc.normalized_unit_filename base) + ) dir.Dir.files + +let init ~auto_include ~visible ~hidden = + reset (); + visible_dirs := List.rev_map (Dir.create ~hidden:false) visible; + hidden_dirs := List.rev_map (Dir.create ~hidden:true) hidden; + List.iter prepend_add !hidden_dirs; + List.iter prepend_add !visible_dirs; + auto_include_callback := auto_include + +let remove_dir dir = + assert (not Config.merlin || Local_store.is_bound ()); + let visible = List.filter (fun d -> Dir.path d <> dir) !visible_dirs in + let hidden = List.filter (fun d -> Dir.path d <> dir) !hidden_dirs in + if List.compare_lengths visible !visible_dirs <> 0 + || List.compare_lengths hidden !hidden_dirs <> 0 then begin + reset (); + visible_dirs := visible; + hidden_dirs := hidden; + List.iter prepend_add hidden; + List.iter prepend_add visible + end + +(* General purpose version of function to add a new entry to load path: We only + add a basename to the cache if it is not already present, in order to enforce + left-to-right precedence. *) +let add (dir : Dir.t) = + assert (not Config.merlin || Local_store.is_bound ()); + let update base fn visible_files hidden_files = + if dir.hidden && not (STbl.mem !hidden_files base) then + STbl.replace !hidden_files base fn + else if not (STbl.mem !visible_files base) then + STbl.replace !visible_files base fn + in + List.iter + (fun base -> + Result.iter (fun ubase -> + let fn = Filename.concat dir.Dir.path base in + update base fn visible_files hidden_files; + update ubase fn visible_files_uncap hidden_files_uncap + ) + (Misc.normalized_unit_filename base) + ) + dir.files; + if dir.hidden then + hidden_dirs := dir :: !hidden_dirs + else + visible_dirs := dir :: !visible_dirs + +let append_dir = add + +let add_dir ~hidden dir = add (Dir.create ~hidden dir) + +(* Add the directory at the start of load path - so basenames are + unconditionally added. *) +let prepend_dir (dir : Dir.t) = + assert (not Config.merlin || Local_store.is_bound ()); + prepend_add dir; + if dir.hidden then + hidden_dirs := !hidden_dirs @ [dir] + else + visible_dirs := !visible_dirs @ [dir] + +let is_basename fn = Filename.basename fn = fn + +let auto_include_libs libs alert find_in_dir fn = + let scan (lib, lazy dir) = + let file = find_in_dir dir fn in + let alert_and_add_dir _ = + alert lib; + append_dir dir + in + Option.iter alert_and_add_dir file; + file + in + match List.find_map scan libs with + | Some base -> base + | None -> raise Not_found + +let auto_include_otherlibs = + (* Ensure directories are only ever scanned once *) + let expand = Misc.expand_directory Config.standard_library in + let otherlibs = + let read_lib lib = lazy (Dir.create ~hidden:false (expand ("+" ^ lib))) in + List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in + auto_include_libs otherlibs + +type visibility = Visible | Hidden + +let find_file_in_cache fn visible_files hidden_files = + try (STbl.find !visible_files fn, Visible) with + | Not_found -> (STbl.find !hidden_files fn, Hidden) + +let find fn = + assert (not Config.merlin || Local_store.is_bound ()); + try + if is_basename fn && not !Sys.interactive then + fst (find_file_in_cache fn visible_files hidden_files) + else + Misc.find_in_path (get_path_list ()) fn + with Not_found -> + !auto_include_callback Dir.find fn + +let find_normalized_with_visibility fn = + assert (not Config.merlin || Local_store.is_bound ()); + match Misc.normalized_unit_filename fn with + | Error _ -> raise Not_found + | Ok fn_uncap -> + try + if is_basename fn && not !Sys.interactive then + find_file_in_cache fn_uncap + visible_files_uncap hidden_files_uncap + else + try + (Misc.find_in_path_normalized (get_visible_path_list ()) fn, Visible) + with + | Not_found -> + (Misc.find_in_path_normalized (get_hidden_path_list ()) fn, Hidden) + with Not_found -> + (!auto_include_callback Dir.find_normalized fn_uncap, Visible) + +let find_normalized fn = fst (find_normalized_with_visibility fn) diff --git a/upstream/ocaml_503/utils/load_path.mli b/upstream/ocaml_503/utils/load_path.mli new file mode 100644 index 000000000..488b75f76 --- /dev/null +++ b/upstream/ocaml_503/utils/load_path.mli @@ -0,0 +1,120 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Management of include directories. + + This module offers a high level interface to locating files in the load + path, which is constructed from [-I] and [-H] command line flags and a few + other parameters. + + It makes the assumption that the contents of include directories + doesn't change during the execution of the compiler. +*) + +val add_dir : hidden:bool -> string -> unit +(** Add a directory to the end of the load path (i.e. at lowest priority.) *) + +val remove_dir : string -> unit +(** Remove a directory from the load path *) + +val reset : unit -> unit +(** Remove all directories *) + +module Dir : sig + type t + (** Represent one directory in the load path. *) + + val create : hidden:bool -> string -> t + + val path : t -> string + + val files : t -> string list + (** All the files in that directory. This doesn't include files in + sub-directories of this directory. *) + + val hidden : t -> bool + (** If the modules in this directory should not be bound in the initial + scope *) + + val find : t -> string -> string option + (** [find dir fn] returns the full path to [fn] in [dir]. *) + + val find_normalized : t -> string -> string option + (** As {!find}, but search also for uncapitalized name, i.e. if name is + Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string +(** The type of callback functions on for [init ~auto_include] *) + +val no_auto_include : auto_include_callback +(** No automatic directory inclusion: misses in the load path raise [Not_found] + as normal. *) + +val init : + auto_include:auto_include_callback -> visible:string list -> + hidden:string list -> unit +(** [init ~visible ~hidden] is the same as + [reset (); + List.iter add_dir (List.rev hidden); + List.iter add_dir (List.rev visible)] *) + +val auto_include_otherlibs : + (string -> unit) -> auto_include_callback +(** [auto_include_otherlibs alert] is a callback function to be passed to + {!Load_path.init} and automatically adds [-I +lib] to the load path after + calling [alert lib]. *) + +val get_path_list : unit -> string list +(** Return the list of directories passed to [add_dir] so far. *) + +type paths = + { visible : string list; + hidden : string list } + +val get_paths : unit -> paths +(** Return the directories passed to [add_dir] so far. *) + +val find : string -> string +(** Locate a file in the load path. Raise [Not_found] if the file + cannot be found. This function is optimized for the case where the + filename is a basename, i.e. doesn't contain a directory + separator. *) + +val find_normalized : string -> string +(** Same as [find], but search also for normalized unit name (see + {!Misc.normalized_unit_filename}), i.e. if name is [Foo.ml], allow + [/path/Foo.ml] and [/path/foo.ml] to match. *) + +type visibility = Visible | Hidden + +val find_normalized_with_visibility : string -> string * visibility +(** Same as [find_normalized], but also reports whether the cmi was found in a + -I directory (Visible) or a -H directory (Hidden) *) + +val[@deprecated] add : Dir.t -> unit +(** Old name for {!append_dir} *) + +val append_dir : Dir.t -> unit +(** [append_dir d] adds [d] to the end of the load path (i.e. at lowest + priority. *) + +val prepend_dir : Dir.t -> unit +(** [prepend_dir d] adds [d] to the start of the load path (i.e. at highest + priority. *) + +val get_visible : unit -> Dir.t list +(** Same as [get_paths ()], except that it returns a [Dir.t list], and doesn't + include the -H paths. *) diff --git a/upstream/ocaml_503/utils/local_store.ml b/upstream/ocaml_503/utils/local_store.ml new file mode 100644 index 000000000..4babf61d8 --- /dev/null +++ b/upstream/ocaml_503/utils/local_store.ml @@ -0,0 +1,74 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Frederic Bour, Tarides *) +(* Thomas Refis, Tarides *) +(* *) +(* Copyright 2020 Tarides *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type ref_and_reset = + | Table : { ref: 'a ref; init: unit -> 'a } -> ref_and_reset + | Ref : { ref: 'a ref; mutable snapshot: 'a } -> ref_and_reset + +type bindings = { + mutable refs: ref_and_reset list; + mutable frozen : bool; + mutable is_bound: bool; +} + +let global_bindings = + { refs = []; is_bound = false; frozen = false } + +let is_bound () = global_bindings.is_bound + +let reset () = + assert (is_bound ()); + List.iter (function + | Table { ref; init } -> ref := init () + | Ref { ref; snapshot } -> ref := snapshot + ) global_bindings.refs + +let s_table create size = + let init () = create size in + let ref = ref (init ()) in + assert (not global_bindings.frozen); + global_bindings.refs <- (Table { ref; init }) :: global_bindings.refs; + ref + +let s_ref k = + let ref = ref k in + assert (not global_bindings.frozen); + global_bindings.refs <- + (Ref { ref; snapshot = k }) :: global_bindings.refs; + ref + +type slot = Slot : { ref : 'a ref; mutable value : 'a } -> slot +type store = slot list + +let fresh () = + let slots = + List.map (function + | Table { ref; init } -> Slot {ref; value = init ()} + | Ref r -> + if not global_bindings.frozen then r.snapshot <- !(r.ref); + Slot { ref = r.ref; value = r.snapshot } + ) global_bindings.refs + in + global_bindings.frozen <- true; + slots + +let with_store slots f = + assert (not global_bindings.is_bound); + global_bindings.is_bound <- true; + List.iter (fun (Slot {ref;value}) -> ref := value) slots; + Fun.protect f ~finally:(fun () -> + List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots; + global_bindings.is_bound <- false; + ) diff --git a/upstream/ocaml_503/utils/local_store.mli b/upstream/ocaml_503/utils/local_store.mli new file mode 100644 index 000000000..545cf71e0 --- /dev/null +++ b/upstream/ocaml_503/utils/local_store.mli @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Frederic Bour, Tarides *) +(* Thomas Refis, Tarides *) +(* *) +(* Copyright 2020 Tarides *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module provides some facilities for creating references (and hash + tables) which can easily be snapshotted and restored to an arbitrary + version. + + It is used throughout the frontend (read: typechecker), to register all + (well, hopefully) the global state. Thus making it easy for tools like + Merlin to go back and forth typechecking different files. *) + +(** {1 Creators} *) + +val s_ref : 'a -> 'a ref +(** Similar to {!val:Stdlib.ref}, except the allocated reference is registered + into the store. *) + +val s_table : ('a -> 'b) -> 'a -> 'b ref +(** Used to register hash tables. Those also need to be placed into refs to be + easily swapped out, but one can't just "snapshot" the initial value to + create fresh instances, so instead an initializer is required. + + Use it like this: + {[ + let my_table = s_table Hashtbl.create 42 + ]} +*) + +(** {1 State management} + + Note: all the following functions are currently unused inside the compiler + codebase. Merlin is their only user at the moment. *) + +type store + +val fresh : unit -> store +(** Returns a fresh instance of the store. + + The first time this function is called, it snapshots the value of all the + registered references, later calls to [fresh] will return instances + initialized to those values. *) + +val with_store : store -> (unit -> 'a) -> 'a +(** [with_store s f] resets all the registered references to the value they have + in [s] for the run of [f]. + If [f] updates any of the registered refs, [s] is updated to remember those + changes. *) + +val reset : unit -> unit +(** Resets all the references to the initial snapshot (i.e. to the same values + that new instances start with). *) + +val is_bound : unit -> bool +(** Returns [true] when a store is active (i.e. when called from the callback + passed to {!with_store}), [false] otherwise. *) diff --git a/upstream/ocaml_503/utils/misc.ml b/upstream/ocaml_503/utils/misc.ml new file mode 100644 index 000000000..b3d75dbb8 --- /dev/null +++ b/upstream/ocaml_503/utils/misc.ml @@ -0,0 +1,1392 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Errors *) + +exception Fatal_error + +let fatal_errorf fmt = + Format.kfprintf + (fun _ -> raise Fatal_error) + Format.err_formatter + ("@?>> Fatal error: " ^^ fmt ^^ "@.") + +let fatal_error msg = fatal_errorf "%s" msg + +(* Exceptions *) + +let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work = + match work () with + | result -> + begin match always () with + | () -> result + | exception always_exn -> + let always_bt = Printexc.get_raw_backtrace () in + exceptionally (); + Printexc.raise_with_backtrace always_exn always_bt + end + | exception work_exn -> + let work_bt = Printexc.get_raw_backtrace () in + begin match always () with + | () -> + exceptionally (); + Printexc.raise_with_backtrace work_exn work_bt + | exception always_exn -> + let always_bt = Printexc.get_raw_backtrace () in + exceptionally (); + Printexc.raise_with_backtrace always_exn always_bt + end + +let reraise_preserving_backtrace e f = + let bt = Printexc.get_raw_backtrace () in + f (); + Printexc.raise_with_backtrace e bt + +type ref_and_value = R : 'a ref * 'a -> ref_and_value + +let protect_refs = + let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in + fun refs f -> + let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in + set_refs refs; + Fun.protect ~finally:(fun () -> set_refs backup) f + +(* List functions *) + +let rec map_end f l1 l2 = + match l1 with + [] -> l2 + | hd::tl -> f hd :: map_end f tl l2 + +let rev_map_end f l1 l2 = + let rec rmap_f accu = function + | [] -> accu + | hd::tl -> rmap_f (f hd :: accu) tl + in + rmap_f l2 l1 + +let rec map_left_right f = function + [] -> [] + | hd::tl -> let res = f hd in res :: map_left_right f tl + +let rec for_all2 pred l1 l2 = + match (l1, l2) with + ([], []) -> true + | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2 + | (_, _) -> false + +let rec replicate_list elem n = + if n <= 0 then [] else elem :: replicate_list elem (n-1) + +let rec list_remove x = function + [] -> [] + | hd :: tl -> + if hd = x then tl else hd :: list_remove x tl + +let rec split_last = function + [] -> assert false + | [x] -> ([], x) + | hd :: tl -> + let (lst, last) = split_last tl in + (hd :: lst, last) + +module Stdlib = struct + module List = struct + type 'a t = 'a list + + let rec compare cmp l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = cmp h1 h2 in + if c <> 0 then c + else compare cmp t1 t2 + + let rec equal eq l1 l2 = + match l1, l2 with + | ([], []) -> true + | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2 + | (_, _) -> false + + let map2_prefix f l1 l2 = + let rec aux acc l1 l2 = + match l1, l2 with + | [], _ -> (List.rev acc, l2) + | _ :: _, [] -> raise (Invalid_argument "map2_prefix") + | h1::t1, h2::t2 -> + let h = f h1 h2 in + aux (h :: acc) t1 t2 + in + aux [] l1 l2 + + let rec iteri2 i f l1 l2 = + match (l1, l2) with + ([], []) -> () + | (a1::l1, a2::l2) -> f i a1 a2; iteri2 (i + 1) f l1 l2 + | (_, _) -> raise (Invalid_argument "iteri2") + + let iteri2 f l1 l2 = iteri2 0 f l1 l2 + + let some_if_all_elements_are_some l = + let rec aux acc l = + match l with + | [] -> Some (List.rev acc) + | None :: _ -> None + | Some h :: t -> aux (h :: acc) t + in + aux [] l + + let split_at n l = + let rec aux n acc l = + if n = 0 + then List.rev acc, l + else + match l with + | [] -> raise (Invalid_argument "split_at") + | t::q -> aux (n-1) (t::acc) q + in + aux n [] l + + let chunks_of n l = + if n <= 0 then raise (Invalid_argument "chunks_of"); + (* Invariant: List.length l = remaining *) + let rec aux n acc l ~remaining = + match remaining with + | 0 -> List.rev acc + | _ when remaining <= n -> List.rev (l :: acc) + | _ -> + let chunk, rest = split_at n l in + aux n (chunk :: acc) rest ~remaining:(remaining - n) + in + aux n [] l ~remaining:(List.length l) + + let rec is_prefix ~equal t ~of_ = + match t, of_ with + | [], [] -> true + | _::_, [] -> false + | [], _::_ -> true + | x1::t, x2::of_ -> equal x1 x2 && is_prefix ~equal t ~of_ + + type 'a longest_common_prefix_result = { + longest_common_prefix : 'a list; + first_without_longest_common_prefix : 'a list; + second_without_longest_common_prefix : 'a list; + } + + let find_and_chop_longest_common_prefix ~equal ~first ~second = + let rec find_prefix ~longest_common_prefix_rev l1 l2 = + match l1, l2 with + | elt1 :: l1, elt2 :: l2 when equal elt1 elt2 -> + let longest_common_prefix_rev = elt1 :: longest_common_prefix_rev in + find_prefix ~longest_common_prefix_rev l1 l2 + | l1, l2 -> + { longest_common_prefix = List.rev longest_common_prefix_rev; + first_without_longest_common_prefix = l1; + second_without_longest_common_prefix = l2; + } + in + find_prefix ~longest_common_prefix_rev:[] first second + end + + module Option = struct + type 'a t = 'a option + + let print print_contents ppf t = + match t with + | None -> Format.pp_print_string ppf "None" + | Some contents -> + Format.fprintf ppf "@[(Some@ %a)@]" print_contents contents + end + + module Array = struct + let exists2 p a1 a2 = + let n = Array.length a1 in + if Array.length a2 <> n then invalid_arg "Misc.Stdlib.Array.exists2"; + let rec loop i = + if i = n then false + else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true + else loop (succ i) in + loop 0 + + let for_alli p a = + let n = Array.length a in + let rec loop i = + if i = n then true + else if p i (Array.unsafe_get a i) then loop (succ i) + else false in + loop 0 + + let all_somes a = + try + Some (Array.map (function None -> raise_notrace Exit | Some x -> x) a) + with + | Exit -> None + end + + module String = struct + include String + module Set = Set.Make(String) + module Map = Map.Make(String) + module Tbl = Hashtbl.Make(struct + include String + let hash = Hashtbl.hash + end) + + let for_all f t = + let len = String.length t in + let rec loop i = + i = len || (f t.[i] && loop (i + 1)) + in + loop 0 + + let print ppf t = + Format.pp_print_string ppf t + end + + external compare : 'a -> 'a -> int = "%compare" +end + +(** {1 Minimal support for Unicode characters in identifiers} *) + +module Utf8_lexeme = struct + + type t = string + + (* Non-ASCII letters that are allowed in identifiers (currently: Latin-9) *) + + type case = Upper of Uchar.t | Lower of Uchar.t + let known_chars : (Uchar.t, case) Hashtbl.t = Hashtbl.create 32 + + let _ = + List.iter + (fun (upper, lower) -> + let upper = Uchar.of_int upper and lower = Uchar.of_int lower in + Hashtbl.add known_chars upper (Upper lower); + Hashtbl.add known_chars lower (Lower upper)) + [ + (0xc0, 0xe0); (* À, à *) (0xc1, 0xe1); (* Á, á *) + (0xc2, 0xe2); (* Â, â *) (0xc3, 0xe3); (* Ã, ã *) + (0xc4, 0xe4); (* Ä, ä *) (0xc5, 0xe5); (* Å, å *) + (0xc6, 0xe6); (* Æ, æ *) (0xc7, 0xe7); (* Ç, ç *) + (0xc8, 0xe8); (* È, è *) (0xc9, 0xe9); (* É, é *) + (0xca, 0xea); (* Ê, ê *) (0xcb, 0xeb); (* Ë, ë *) + (0xcc, 0xec); (* Ì, ì *) (0xcd, 0xed); (* Í, í *) + (0xce, 0xee); (* Î, î *) (0xcf, 0xef); (* Ï, ï *) + (0xd0, 0xf0); (* Ð, ð *) (0xd1, 0xf1); (* Ñ, ñ *) + (0xd2, 0xf2); (* Ò, ò *) (0xd3, 0xf3); (* Ó, ó *) + (0xd4, 0xf4); (* Ô, ô *) (0xd5, 0xf5); (* Õ, õ *) + (0xd6, 0xf6); (* Ö, ö *) (0xd8, 0xf8); (* Ø, ø *) + (0xd9, 0xf9); (* Ù, ù *) (0xda, 0xfa); (* Ú, ú *) + (0xdb, 0xfb); (* Û, û *) (0xdc, 0xfc); (* Ü, ü *) + (0xdd, 0xfd); (* Ý, ý *) (0xde, 0xfe); (* Þ, þ *) + (0x160, 0x161); (* Š, š *) (0x17d, 0x17e); (* Ž, ž *) + (0x152, 0x153); (* Œ, œ *) (0x178, 0xff); (* Ÿ, ÿ *) + (0x1e9e, 0xdf); (* ẞ, ß *) + ] + + (* NFD to NFC conversion table for the letters above *) + + let known_pairs : (Uchar.t * Uchar.t, Uchar.t) Hashtbl.t = Hashtbl.create 32 + + let _ = + List.iter + (fun (c1, n2, n) -> + Hashtbl.add known_pairs + (Uchar.of_char c1, Uchar.of_int n2) (Uchar.of_int n)) + [ + ('A', 0x300, 0xc0); (* À *) ('A', 0x301, 0xc1); (* Á *) + ('A', 0x302, 0xc2); (*  *) ('A', 0x303, 0xc3); (* à *) + ('A', 0x308, 0xc4); (* Ä *) ('A', 0x30a, 0xc5); (* Å *) + ('C', 0x327, 0xc7); (* Ç *) ('E', 0x300, 0xc8); (* È *) + ('E', 0x301, 0xc9); (* É *) ('E', 0x302, 0xca); (* Ê *) + ('E', 0x308, 0xcb); (* Ë *) ('I', 0x300, 0xcc); (* Ì *) + ('I', 0x301, 0xcd); (* Í *) ('I', 0x302, 0xce); (* Î *) + ('I', 0x308, 0xcf); (* Ï *) ('N', 0x303, 0xd1); (* Ñ *) + ('O', 0x300, 0xd2); (* Ò *) ('O', 0x301, 0xd3); (* Ó *) + ('O', 0x302, 0xd4); (* Ô *) ('O', 0x303, 0xd5); (* Õ *) + ('O', 0x308, 0xd6); (* Ö *) + ('U', 0x300, 0xd9); (* Ù *) ('U', 0x301, 0xda); (* Ú *) + ('U', 0x302, 0xdb); (* Û *) ('U', 0x308, 0xdc); (* Ü *) + ('Y', 0x301, 0xdd); (* Ý *) ('Y', 0x308, 0x178); (* Ÿ *) + ('S', 0x30c, 0x160); (* Š *) ('Z', 0x30c, 0x17d); (* Ž *) + ('a', 0x300, 0xe0); (* à *) ('a', 0x301, 0xe1); (* á *) + ('a', 0x302, 0xe2); (* â *) ('a', 0x303, 0xe3); (* ã *) + ('a', 0x308, 0xe4); (* ä *) ('a', 0x30a, 0xe5); (* å *) + ('c', 0x327, 0xe7); (* ç *) ('e', 0x300, 0xe8); (* è *) + ('e', 0x301, 0xe9); (* é *) ('e', 0x302, 0xea); (* ê *) + ('e', 0x308, 0xeb); (* ë *) ('i', 0x300, 0xec); (* ì *) + ('i', 0x301, 0xed); (* í *) ('i', 0x302, 0xee); (* î *) + ('i', 0x308, 0xef); (* ï *) ('n', 0x303, 0xf1); (* ñ *) + ('o', 0x300, 0xf2); (* ò *) ('o', 0x301, 0xf3); (* ó *) + ('o', 0x302, 0xf4); (* ô *) ('o', 0x303, 0xf5); (* õ *) + ('o', 0x308, 0xf6); (* ö *) + ('u', 0x300, 0xf9); (* ù *) ('u', 0x301, 0xfa); (* ú *) + ('u', 0x302, 0xfb); (* û *) ('u', 0x308, 0xfc); (* ü *) + ('y', 0x301, 0xfd); (* ý *) ('y', 0x308, 0xff); (* ÿ *) + ('s', 0x30c, 0x161); (* š *) ('z', 0x30c, 0x17e); (* ž *) + ] + + let normalize_generic ~keep_ascii transform s = + let rec norm check buf prev i = + if i >= String.length s then begin + Buffer.add_utf_8_uchar buf (transform prev) + end else begin + let d = String.get_utf_8_uchar s i in + let u = Uchar.utf_decode_uchar d in + check d u; + let i' = i + Uchar.utf_decode_length d in + match Hashtbl.find_opt known_pairs (prev, u) with + | Some u' -> + norm check buf u' i' + | None -> + Buffer.add_utf_8_uchar buf (transform prev); + norm check buf u i' + end in + let ascii_limit = 128 in + if s = "" + || keep_ascii && String.for_all (fun x -> Char.code x < ascii_limit) s + then Ok s + else + let buf = Buffer.create (String.length s) in + let valid = ref true in + let check d u = + valid := !valid && Uchar.utf_decode_is_valid d && u <> Uchar.rep + in + let d = String.get_utf_8_uchar s 0 in + let u = Uchar.utf_decode_uchar d in + check d u; + norm check buf u (Uchar.utf_decode_length d); + let contents = Buffer.contents buf in + if !valid then + Ok contents + else + Error contents + + let normalize s = + normalize_generic ~keep_ascii:true (fun u -> u) s + + (* Capitalization *) + + let uchar_is_uppercase u = + let c = Uchar.to_int u in + if c < 0x80 then c >= 65 && c <= 90 else + match Hashtbl.find_opt known_chars u with + | Some(Upper _) -> true + | _ -> false + + let uchar_lowercase u = + let c = Uchar.to_int u in + if c < 0x80 then + if c >= 65 && c <= 90 then Uchar.of_int (c + 32) else u + else + match Hashtbl.find_opt known_chars u with + | Some(Upper u') -> u' + | _ -> u + + let uchar_uppercase u = + let c = Uchar.to_int u in + if c < 0x80 then + if c >= 97 && c <= 122 then Uchar.of_int (c - 32) else u + else + match Hashtbl.find_opt known_chars u with + | Some(Lower u') -> u' + | _ -> u + + let capitalize s = + let first = ref true in + normalize_generic ~keep_ascii:false + (fun u -> if !first then (first := false; uchar_uppercase u) else u) + s + + let uncapitalize s = + let first = ref true in + normalize_generic ~keep_ascii:false + (fun u -> if !first then (first := false; uchar_lowercase u) else u) + s + + let is_capitalized s = + s <> "" && + uchar_is_uppercase (Uchar.utf_decode_uchar (String.get_utf_8_uchar s 0)) + + (* Characters allowed in identifiers after normalization is applied. + Currently: + - ASCII letters, underscore + - Latin-9 letters, represented in NFC + - ASCII digits, single quote (but not as first character) + - dot if [with_dot] = true + *) + let uchar_valid_in_identifier ~with_dot u = + let c = Uchar.to_int u in + if c < 0x80 then + c >= 97 (* a *) && c <= 122 (* z *) + || c >= 65 (* A *) && c <= 90 (* Z *) + || c >= 48 (* 0 *) && c <= 57 (* 9 *) + || c = 95 (* underscore *) + || c = 39 (* single quote *) + || (with_dot && c = 46) (* dot *) + else + Hashtbl.mem known_chars u + + let uchar_not_identifier_start u = + let c = Uchar.to_int u in + c >= 48 (* 0 *) && c <= 57 (* 9 *) + || c = 39 (* single quote *) + + (* Check whether a normalized string is a valid OCaml identifier. *) + + type validation_result = + | Valid + | Invalid_character of Uchar.t (** Character not allowed *) + | Invalid_beginning of Uchar.t (** Character not allowed as first char *) + + let validate_identifier ?(with_dot=false) s = + let rec check i = + if i >= String.length s then Valid else begin + let d = String.get_utf_8_uchar s i in + let u = Uchar.utf_decode_uchar d in + let i' = i + Uchar.utf_decode_length d in + if not (uchar_valid_in_identifier ~with_dot u) then + Invalid_character u + else if i = 0 && uchar_not_identifier_start u then + Invalid_beginning u + else + check i' + end + in check 0 + + let is_valid_identifier s = + validate_identifier s = Valid + + let starts_like_a_valid_identifier s = + s <> "" && + (let u = Uchar.utf_decode_uchar (String.get_utf_8_uchar s 0) in + uchar_valid_in_identifier ~with_dot:false u + && not (uchar_not_identifier_start u)) + + let is_lowercase s = + let rec is_lowercase_at len s n = + if n >= len then true + else + let d = String.get_utf_8_uchar s n in + let u = Uchar.utf_decode_uchar d in + (uchar_valid_in_identifier ~with_dot:false u) + && not (uchar_is_uppercase u) + && is_lowercase_at len s (n+Uchar.utf_decode_length d) + in + is_lowercase_at (String.length s) s 0 +end + +(* File functions *) + +let find_in_path path name = + if not (Filename.is_implicit name) then + if Sys.file_exists name then name else raise Not_found + else begin + let rec try_dir = function + [] -> raise Not_found + | dir::rem -> + let fullname = Filename.concat dir name in + if Sys.file_exists fullname then fullname else try_dir rem + in try_dir path + end + +let find_in_path_rel path name = + let rec simplify s = + let open Filename in + let base = basename s in + let dir = dirname s in + if dir = s then dir + else if base = current_dir_name then simplify dir + else concat (simplify dir) base + in + let rec try_dir = function + [] -> raise Not_found + | dir::rem -> + let fullname = simplify (Filename.concat dir name) in + if Sys.file_exists fullname then fullname else try_dir rem + in try_dir path + +let normalized_unit_filename = Utf8_lexeme.uncapitalize + +let find_in_path_normalized path name = + match normalized_unit_filename name with + | Error _ -> raise Not_found + | Ok uname -> + let rec try_dir = function + [] -> raise Not_found + | dir::rem -> + let fullname = Filename.concat dir name + and ufullname = Filename.concat dir uname in + if Sys.file_exists ufullname then ufullname + else if Sys.file_exists fullname then fullname + else try_dir rem + in try_dir path + +let remove_file filename = + try + if Sys.is_regular_file filename + then Sys.remove filename + with Sys_error _msg -> + () + +(* Expand a -I option: if it starts with +, make it relative to the standard + library directory *) + +let expand_directory alt s = + if String.length s > 0 && s.[0] = '+' + then Filename.concat alt + (String.sub s 1 (String.length s - 1)) + else s + +let path_separator = + match Sys.os_type with + | "Win32" -> ';' + | _ -> ':' + +let split_path_contents ?(sep = path_separator) = function + | "" -> [] + | s -> String.split_on_char sep s + +(* Hashtable functions *) + +let create_hashtable size init = + let tbl = Hashtbl.create size in + List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; + tbl + +(* File copy *) + +let copy_file ic oc = + let buff = Bytes.create 0x1000 in + let rec copy () = + let n = input ic buff 0 0x1000 in + if n = 0 then () else (output oc buff 0 n; copy()) + in copy() + +let copy_file_chunk ic oc len = + let buff = Bytes.create 0x1000 in + let rec copy n = + if n <= 0 then () else begin + let r = input ic buff 0 (Int.min n 0x1000) in + if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r)) + end + in copy len + +let string_of_file ic = + let b = Buffer.create 0x10000 in + let buff = Bytes.create 0x1000 in + let rec copy () = + let n = input ic buff 0 0x1000 in + if n = 0 then Buffer.contents b else + (Buffer.add_subbytes b buff 0 n; copy()) + in copy() + +let output_to_file_via_temporary ?(mode = [Open_text]) filename fn = + let (temp_filename, oc) = + Filename.open_temp_file + ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename) + (Filename.basename filename) ".tmp" in + (* The 0o666 permissions will be modified by the umask. It's just + like what [open_out] and [open_out_bin] do. + With temp_dir = dirname filename, we ensure that the returned + temp file is in the same directory as filename itself, making + it safe to rename temp_filename to filename later. + With prefix = basename filename, we are almost certain that + the first generated name will be unique. A fixed prefix + would work too but might generate more collisions if many + files are being produced simultaneously in the same directory. *) + match fn temp_filename oc with + | res -> + close_out oc; + begin try + Sys.rename temp_filename filename; res + with exn -> + remove_file temp_filename; raise exn + end + | exception exn -> + close_out oc; remove_file temp_filename; raise exn + +let protect_writing_to_file ~filename ~f = + let outchan = open_out_bin filename in + try_finally ~always:(fun () -> close_out outchan) + ~exceptionally:(fun () -> remove_file filename) + (fun () -> f outchan) + +(* Integer operations *) + +let rec log2 n = + if n <= 1 then 0 else 1 + log2(n asr 1) + +let align n a = + if n >= 0 then (n + a - 1) land (-a) else n land (-a) + +let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0 + +let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0 + +(* Taken from Hacker's Delight, chapter "Overflow Detection" *) +let no_overflow_mul a b = + not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a)) + +let no_overflow_lsl a k = + 0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k + +let letter_of_int n = + let letter = String.make 1 (Char.chr (Char.code 'a' + n mod 26)) in + let num = n / 26 in + if num = 0 then letter + else letter ^ Int.to_string num + +module Int_literal_converter = struct + (* To convert integer literals, allowing max_int + 1 (PR#4210) *) + let cvt_int_aux str neg of_string = + if String.length str = 0 || str.[0]= '-' + then of_string str + else neg (of_string ("-" ^ str)) + let int s = cvt_int_aux s (~-) int_of_string + let int32 s = cvt_int_aux s Int32.neg Int32.of_string + let int64 s = cvt_int_aux s Int64.neg Int64.of_string + let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string +end + +(* [find_first_mono p] assumes that there exists a natural number + N such that [p] is false on [0; N[ and true on [N; max_int], and + returns this N. (See misc.mli for the detailed specification.) *) +let find_first_mono = + let rec find p ~low ~jump ~high = + (* Invariants: + [low, jump, high] are non-negative with [low < high], + [p low = false], + [p high = true]. *) + if low + 1 = high then high + (* ensure that [low + jump] is in ]low; high[ *) + else if jump < 1 then find p ~low ~jump:1 ~high + else if jump >= high - low then find p ~low ~jump:((high - low) / 2) ~high + else if p (low + jump) then + (* We jumped too high: continue with a smaller jump and lower limit *) + find p ~low:low ~jump:(jump / 2) ~high:(low + jump) + else + (* we jumped too low: + continue from [low + jump] with a larger jump *) + let next_jump = max jump (2 * jump) (* avoid overflows *) in + find p ~low:(low + jump) ~jump:next_jump ~high + in + fun p -> + if p 0 then 0 + else find p ~low:0 ~jump:1 ~high:max_int + +(* String operations *) + +let split_null_terminated s = + let[@tail_mod_cons] rec discard_last_sep = function + | [] | [""] -> [] + | x :: xs -> x :: discard_last_sep xs + in + discard_last_sep (String.split_on_char '\000' s) + +let concat_null_terminated = function + | [] -> "" + | l -> String.concat "\000" (l @ [""]) + +let chop_extensions file = + let dirname = Filename.dirname file and basename = Filename.basename file in + try + let pos = String.index basename '.' in + let basename = String.sub basename 0 pos in + if Filename.is_implicit file && dirname = Filename.current_dir_name then + basename + else + Filename.concat dirname basename + with Not_found -> file + +let search_substring pat str start = + let rec search i j = + if j >= String.length pat then i + else if i + j >= String.length str then raise Not_found + else if str.[i + j] = pat.[j] then search i (j+1) + else search (i+1) 0 + in search start 0 + +let replace_substring ~before ~after str = + let rec search acc curr = + match search_substring before str curr with + | next -> + let prefix = String.sub str curr (next - curr) in + search (prefix :: acc) (next + String.length before) + | exception Not_found -> + let suffix = String.sub str curr (String.length str - curr) in + List.rev (suffix :: acc) + in String.concat after (search [] 0) + +let rev_split_words s = + let rec split1 res i = + if i >= String.length s then res else begin + match s.[i] with + ' ' | '\t' | '\r' | '\n' -> split1 res (i+1) + | _ -> split2 res i (i+1) + end + and split2 res i j = + if j >= String.length s then String.sub s i (j-i) :: res else begin + match s.[j] with + ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1) + | _ -> split2 res i (j+1) + end + in split1 [] 0 + +let get_ref r = + let v = !r in + r := []; v + +let set_or_ignore f opt x = + match f x with + | None -> () + | Some y -> opt := Some y + +let fst3 (x, _, _) = x +let snd3 (_,x,_) = x +let thd3 (_,_,x) = x + +let fst4 (x, _, _, _) = x +let snd4 (_,x,_, _) = x +let thd4 (_,_,x,_) = x +let for4 (_,_,_,x) = x + + +let cut_at s c = + let pos = String.index s c in + String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1) + +let ordinal_suffix n = + let teen = (n mod 100)/10 = 1 in + match n mod 10 with + | 1 when not teen -> "st" + | 2 when not teen -> "nd" + | 3 when not teen -> "rd" + | _ -> "th" + +(* Color support handling *) +module Color = struct + external isatty : out_channel -> bool = "caml_sys_isatty" + + (* reasonable heuristic on whether colors should be enabled *) + let should_enable_color () = + let term = try Sys.getenv "TERM" with Not_found -> "" in + term <> "dumb" + && term <> "" + && isatty stderr + + type setting = Auto | Always | Never + + let default_setting = Auto + let enabled = ref true + +end + +(* Terminal styling handling *) +module Style = struct + (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) + type color = + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + + type style = + | FG of color (* foreground *) + | BG of color (* background *) + | Bold + | Reset + + let ansi_of_color = function + | Black -> "0" + | Red -> "1" + | Green -> "2" + | Yellow -> "3" + | Blue -> "4" + | Magenta -> "5" + | Cyan -> "6" + | White -> "7" + + let code_of_style = function + | FG c -> "3" ^ ansi_of_color c + | BG c -> "4" ^ ansi_of_color c + | Bold -> "1" + | Reset -> "0" + + let ansi_of_style_l l = + let s = match l with + | [] -> code_of_style Reset + | [s] -> code_of_style s + | _ -> String.concat ";" (List.map code_of_style l) + in + "\x1b[" ^ s ^ "m" + + + type Format.stag += Style of style list + + type tag_style ={ + ansi: style list; + text_open:string; + text_close:string + } + + type styles = { + error: tag_style; + warning: tag_style; + loc: tag_style; + hint: tag_style; + inline_code: tag_style; + } + + let no_markup stl = { ansi = stl; text_close = ""; text_open = "" } + + let default_styles = { + warning = no_markup [Bold; FG Magenta]; + error = no_markup [Bold; FG Red]; + loc = no_markup [Bold]; + hint = no_markup [Bold; FG Blue]; + inline_code= { ansi=[Bold]; text_open = {|"|}; text_close = {|"|} } + } + + let cur_styles = ref default_styles + let get_styles () = !cur_styles + let set_styles s = cur_styles := s + + (* map a tag to a style, if the tag is known. + @raise Not_found otherwise *) + let style_of_tag s = match s with + | Format.String_tag "error" -> (!cur_styles).error + | Format.String_tag "warning" ->(!cur_styles).warning + | Format.String_tag "loc" -> (!cur_styles).loc + | Format.String_tag "hint" -> (!cur_styles).hint + | Format.String_tag "inline_code" -> (!cur_styles).inline_code + | Style s -> no_markup s + | _ -> raise Not_found + + + let as_inline_code printer ppf x = + let open Format_doc in + pp_open_stag ppf (Format.String_tag "inline_code"); + printer ppf x; + pp_close_stag ppf () + + let inline_code ppf s = as_inline_code Format_doc.pp_print_string ppf s + + (* either prints the tag of [s] or delegates to [or_else] *) + let mark_open_tag ~or_else s = + try + let style = style_of_tag s in + if !Color.enabled then ansi_of_style_l style.ansi else style.text_open + with Not_found -> or_else s + + let mark_close_tag ~or_else s = + try + let style = style_of_tag s in + if !Color.enabled then ansi_of_style_l [Reset] else style.text_close + with Not_found -> or_else s + + (* add tag handling to formatter [ppf] *) + let set_tag_handling ppf = + let open Format in + let functions = pp_get_formatter_stag_functions ppf () in + let functions' = {functions with + mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag); + mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag); + } in + pp_set_mark_tags ppf true; (* enable tags *) + pp_set_formatter_stag_functions ppf functions'; + () + + let setup = + let first = ref true in (* initialize only once *) + let formatter_l = + [Format.std_formatter; Format.err_formatter; Format.str_formatter] + in + let enable_color = function + | Color.Auto -> Color.should_enable_color () + | Color.Always -> true + | Color.Never -> false + in + fun o -> + if !first then ( + first := false; + Format.set_mark_tags true; + List.iter set_tag_handling formatter_l; + Color.enabled := (match o with + | Some s -> enable_color s + | None -> enable_color Color.default_setting) + ); + () +end + +let edit_distance a b cutoff = + let la, lb = String.length a, String.length b in + let cutoff = + (* using max_int for cutoff would cause overflows in (i + cutoff + 1); + we bring it back to the (max la lb) worstcase *) + Int.min (Int.max la lb) cutoff in + if abs (la - lb) > cutoff then None + else begin + (* initialize with 'cutoff + 1' so that not-yet-written-to cases have + the worst possible cost; this is useful when computing the cost of + a case just at the boundary of the cutoff diagonal. *) + let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in + m.(0).(0) <- 0; + for i = 1 to la do + m.(i).(0) <- i; + done; + for j = 1 to lb do + m.(0).(j) <- j; + done; + for i = 1 to la do + for j = Int.max 1 (i - cutoff - 1) to Int.min lb (i + cutoff + 1) do + let cost = if a.[i-1] = b.[j-1] then 0 else 1 in + let best = + (* insert, delete or substitute *) + Int.min (1 + Int.min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost) + in + let best = + (* swap two adjacent letters; we use "cost" again in case of + a swap between two identical letters; this is slightly + redundant as this is a double-substitution case, but it + was done this way in most online implementations and + imitation has its virtues *) + if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1]) + then best + else Int.min best (m.(i-2).(j-2) + cost) + in + m.(i).(j) <- best + done; + done; + let result = m.(la).(lb) in + if result > cutoff + then None + else Some result + end + +let spellcheck env name = + let cutoff = + match String.length name with + | 1 | 2 -> 0 + | 3 | 4 -> 1 + | 5 | 6 -> 2 + | _ -> 3 + in + let compare target acc head = + match edit_distance target head cutoff with + | None -> acc + | Some dist -> + let (best_choice, best_dist) = acc in + if dist < best_dist then ([head], dist) + else if dist = best_dist then (head :: best_choice, dist) + else acc + in + let env = List.sort_uniq (fun s1 s2 -> String.compare s2 s1) env in + fst (List.fold_left (compare name) ([], max_int) env) + + +let did_you_mean ppf get_choices = + let open Format_doc in + (* flush now to get the error report early, in the (unheard of) case + where the search in the get_choices function would take a bit of + time; in the worst case, the user has seen the error, she can + interrupt the process before the spell-checking terminates. *) + fprintf ppf "@?"; + match get_choices () with + | [] -> () + | choices -> + let rest, last = split_last choices in + fprintf ppf "@\n@[@{Hint@}: Did you mean %a%s%a?@]" + (pp_print_list ~pp_sep:comma Style.inline_code) rest + (if rest = [] then "" else " or ") + Style.inline_code last + +module Error_style = struct + type setting = + | Contextual + | Short + + let default_setting = Contextual +end + +let normalise_eol s = + let b = Buffer.create 80 in + for i = 0 to String.length s - 1 do + if s.[i] <> '\r' then Buffer.add_char b s.[i] + done; + Buffer.contents b + +let delete_eol_spaces src = + let len_src = String.length src in + let dst = Bytes.create len_src in + let rec loop i_src i_dst = + if i_src = len_src then + i_dst + else + match src.[i_src] with + | ' ' | '\t' -> + loop_spaces 1 (i_src + 1) i_dst + | c -> + Bytes.set dst i_dst c; + loop (i_src + 1) (i_dst + 1) + and loop_spaces spaces i_src i_dst = + if i_src = len_src then + i_dst + else + match src.[i_src] with + | ' ' | '\t' -> + loop_spaces (spaces + 1) (i_src + 1) i_dst + | '\n' -> + Bytes.set dst i_dst '\n'; + loop (i_src + 1) (i_dst + 1) + | _ -> + for n = 0 to spaces do + Bytes.set dst (i_dst + n) src.[i_src - spaces + n] + done; + loop (i_src + 1) (i_dst + spaces + 1) + in + let stop = loop 0 0 in + Bytes.sub_string dst 0 stop + +(* showing configuration and configuration variables *) +let show_config_and_exit () = + Config.print_config stdout; + exit 0 + +let show_config_variable_and_exit x = + match Config.config_var x with + | Some v -> + (* we intentionally don't print a newline to avoid Windows \r + issues: bash only strips the trailing \n when using a command + substitution $(ocamlc -config-var foo), so a trailing \r would + remain if printing a newline under Windows and scripts would + have to use $(ocamlc -config-var foo | tr -d '\r') + for portability. Ugh. *) + print_string v; + exit 0 + | None -> + exit 2 + +let get_build_path_prefix_map = + let init = ref false in + let map_cache = ref None in + fun () -> + if not !init then begin + init := true; + match Sys.getenv "BUILD_PATH_PREFIX_MAP" with + | exception Not_found -> () + | encoded_map -> + match Build_path_prefix_map.decode_map encoded_map with + | Error err -> + fatal_errorf + "Invalid value for the environment variable \ + BUILD_PATH_PREFIX_MAP: %s" err + | Ok map -> map_cache := Some map + end; + !map_cache + +let debug_prefix_map_flags () = + if not Config.as_has_debug_prefix_map then + [] + else begin + match get_build_path_prefix_map () with + | None -> [] + | Some map -> + List.fold_right + (fun map_elem acc -> + match map_elem with + | None -> acc + | Some { Build_path_prefix_map.target; source; } -> + (Printf.sprintf "--debug-prefix-map %s=%s" + (Filename.quote source) + (Filename.quote target)) :: acc) + map + [] + end + +let print_see_manual ppf manual_section = + let open Format_doc in + fprintf ppf "(see manual section %a)" + (pp_print_list ~pp_sep:(fun f () -> pp_print_char f '.') pp_print_int) + manual_section + +let print_if ppf flag printer arg = + if !flag then Format.fprintf ppf "%a@." printer arg; + arg + + +type filepath = string +type modname = string +type crcs = (modname * Digest.t option) list + +type alerts = string Stdlib.String.Map.t + +module Magic_number = struct + type native_obj_config = { + flambda : bool; + } + let native_obj_config = { + flambda = Config.flambda; + } + + type version = int + + type kind = + | Exec + | Cmi | Cmo | Cma + | Cmx of native_obj_config | Cmxa of native_obj_config + | Cmxs + | Cmt + | Ast_impl | Ast_intf + + (* please keep up-to-date, this is used for sanity checking *) + let all_native_obj_configs = [ + {flambda = true}; + {flambda = false}; + ] + let all_kinds = [ + Exec; + Cmi; Cmo; Cma; + ] + @ List.map (fun conf -> Cmx conf) all_native_obj_configs + @ List.map (fun conf -> Cmxa conf) all_native_obj_configs + @ [ + Cmt; + Ast_impl; Ast_intf; + ] + + type raw = string + type info = { + kind: kind; + version: version; + } + + type raw_kind = string + + let parse_kind : raw_kind -> kind option = function + | "Caml1999X" -> Some Exec + | "Caml1999I" -> Some Cmi + | "Caml1999O" -> Some Cmo + | "Caml1999A" -> Some Cma + | "Caml1999y" -> Some (Cmx {flambda = true}) + | "Caml1999Y" -> Some (Cmx {flambda = false}) + | "Caml1999z" -> Some (Cmxa {flambda = true}) + | "Caml1999Z" -> Some (Cmxa {flambda = false}) + + (* Caml2007D and Caml2012T were used instead of the common Caml1999 prefix + between the introduction of those magic numbers and October 2017 + (8ba70ff194b66c0a50ffb97d41fe9c4bdf9362d6). + + We accept them here, but will always produce/show kind prefixes + that follow the current convention, Caml1999{D,T}. *) + | "Caml2007D" | "Caml1999D" -> Some Cmxs + | "Caml2012T" | "Caml1999T" -> Some Cmt + + | "Caml1999M" -> Some Ast_impl + | "Caml1999N" -> Some Ast_intf + | _ -> None + + (* note: over time the magic kind number has changed for certain kinds; + this function returns them as they are produced by the current compiler, + but [parse_kind] accepts older formats as well. *) + let raw_kind : kind -> raw = function + | Exec -> "Caml1999X" + | Cmi -> "Caml1999I" + | Cmo -> "Caml1999O" + | Cma -> "Caml1999A" + | Cmx config -> + if config.flambda + then "Caml1999y" + else "Caml1999Y" + | Cmxa config -> + if config.flambda + then "Caml1999z" + else "Caml1999Z" + | Cmxs -> "Caml1999D" + | Cmt -> "Caml1999T" + | Ast_impl -> "Caml1999M" + | Ast_intf -> "Caml1999N" + + let string_of_kind : kind -> string = function + | Exec -> "exec" + | Cmi -> "cmi" + | Cmo -> "cmo" + | Cma -> "cma" + | Cmx _ -> "cmx" + | Cmxa _ -> "cmxa" + | Cmxs -> "cmxs" + | Cmt -> "cmt" + | Ast_impl -> "ast_impl" + | Ast_intf -> "ast_intf" + + let human_description_of_native_obj_config : native_obj_config -> string = + fun[@warning "+9"] {flambda} -> + if flambda then "flambda" else "non flambda" + + let human_name_of_kind : kind -> string = function + | Exec -> "executable" + | Cmi -> "compiled interface file" + | Cmo -> "bytecode object file" + | Cma -> "bytecode library" + | Cmx config -> + Printf.sprintf "native compilation unit description (%s)" + (human_description_of_native_obj_config config) + | Cmxa config -> + Printf.sprintf "static native library (%s)" + (human_description_of_native_obj_config config) + | Cmxs -> "dynamic native library" + | Cmt -> "compiled typedtree file" + | Ast_impl -> "serialized implementation AST" + | Ast_intf -> "serialized interface AST" + + let kind_length = 9 + let version_length = 3 + let magic_length = + kind_length + version_length + + type parse_error = + | Truncated of string + | Not_a_magic_number of string + + let explain_parse_error kind_opt error = + Printf.sprintf + "We expected a valid %s, but the file %s." + (Option.fold ~none:"object file" ~some:human_name_of_kind kind_opt) + (match error with + | Truncated "" -> "is empty" + | Truncated _ -> "is truncated" + | Not_a_magic_number _ -> "has a different format") + + let parse s : (info, parse_error) result = + if String.length s = magic_length then begin + let raw_kind = String.sub s 0 kind_length in + let raw_version = String.sub s kind_length version_length in + match parse_kind raw_kind with + | None -> Error (Not_a_magic_number s) + | Some kind -> + begin match int_of_string raw_version with + | exception _ -> Error (Truncated s) + | version -> Ok { kind; version } + end + end + else begin + (* a header is "truncated" if it starts like a valid magic number, + that is if its longest segment of length at most [kind_length] + is a prefix of [raw_kind kind] for some kind [kind] *) + let sub_length = Int.min kind_length (String.length s) in + let starts_as kind = + String.sub s 0 sub_length = String.sub (raw_kind kind) 0 sub_length + in + if List.exists starts_as all_kinds then Error (Truncated s) + else Error (Not_a_magic_number s) + end + + let read_info ic = + let header = Buffer.create magic_length in + begin + try Buffer.add_channel header ic magic_length + with End_of_file -> () + end; + parse (Buffer.contents header) + + let raw { kind; version; } = + Printf.sprintf "%s%03d" (raw_kind kind) version + + let current_raw kind = + let open Config in + match[@warning "+9"] kind with + | Exec -> exec_magic_number + | Cmi -> cmi_magic_number + | Cmo -> cmo_magic_number + | Cma -> cma_magic_number + | Cmx config -> + (* the 'if' guarantees that in the common case + we return the "trusted" value from Config. *) + let reference = cmx_magic_number in + if config = native_obj_config then reference + else + (* otherwise we stitch together the magic number + for a different configuration by concatenating + the right magic kind at this configuration + and the rest of the current raw number for our configuration. *) + let raw_kind = raw_kind kind in + let len = String.length raw_kind in + raw_kind ^ String.sub reference len (String.length reference - len) + | Cmxa config -> + let reference = cmxa_magic_number in + if config = native_obj_config then reference + else + let raw_kind = raw_kind kind in + let len = String.length raw_kind in + raw_kind ^ String.sub reference len (String.length reference - len) + | Cmxs -> cmxs_magic_number + | Cmt -> cmt_magic_number + | Ast_intf -> ast_intf_magic_number + | Ast_impl -> ast_impl_magic_number + + (* it would seem more direct to define current_version with the + correct numbers and current_raw on top of it, but for now we + consider the Config.foo values to be ground truth, and don't want + to trust the present module instead. *) + let current_version kind = + let raw = current_raw kind in + try int_of_string (String.sub raw kind_length version_length) + with _ -> assert false + + type 'a unexpected = { expected : 'a; actual : 'a } + type unexpected_error = + | Kind of kind unexpected + | Version of kind * version unexpected + + let explain_unexpected_error = function + | Kind { actual; expected } -> + Printf.sprintf "We expected a %s (%s) but got a %s (%s) instead." + (human_name_of_kind expected) (string_of_kind expected) + (human_name_of_kind actual) (string_of_kind actual) + | Version (kind, { actual; expected }) -> + Printf.sprintf "This seems to be a %s (%s) for %s version of OCaml." + (human_name_of_kind kind) (string_of_kind kind) + (if actual < expected then "an older" else "a newer") + + let check_current expected_kind { kind; version } : _ result = + if kind <> expected_kind then begin + let actual, expected = kind, expected_kind in + Error (Kind { actual; expected }) + end else begin + let actual, expected = version, current_version kind in + if actual <> expected + then Error (Version (kind, { actual; expected })) + else Ok () + end + + type error = + | Parse_error of parse_error + | Unexpected_error of unexpected_error + + let read_current_info ~expected_kind ic = + match read_info ic with + | Error err -> Error (Parse_error err) + | Ok info -> + let kind = Option.value ~default:info.kind expected_kind in + match check_current kind info with + | Error err -> Error (Unexpected_error err) + | Ok () -> Ok info +end diff --git a/upstream/ocaml_503/utils/misc.mli b/upstream/ocaml_503/utils/misc.mli new file mode 100644 index 000000000..54354eba5 --- /dev/null +++ b/upstream/ocaml_503/utils/misc.mli @@ -0,0 +1,832 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Miscellaneous useful types and functions + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +(** {1 Reporting fatal errors} *) + +val fatal_error: string -> 'a + (** Raise the [Fatal_error] exception with the given string. *) + +val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a + (** Format the arguments according to the given format string + and raise [Fatal_error] with the resulting string. *) + +exception Fatal_error + +(** {1 Exceptions and finalization} *) + +val try_finally : + ?always:(unit -> unit) -> + ?exceptionally:(unit -> unit) -> + (unit -> 'a) -> 'a +(** [try_finally work ~always ~exceptionally] is designed to run code + in [work] that may fail with an exception, and has two kind of + cleanup routines: [always], that must be run after any execution + of the function (typically, freeing system resources), and + [exceptionally], that should be run only if [work] or [always] + failed with an exception (typically, undoing user-visible state + changes that would only make sense if the function completes + correctly). For example: + + {[ + let objfile = outputprefix ^ ".cmo" in + let oc = open_out_bin objfile in + Misc.try_finally + (fun () -> + bytecode + ++ Timings.(accumulate_time (Generate sourcefile)) + (Emitcode.to_file oc modulename objfile); + Warnings.check_fatal ()) + ~always:(fun () -> close_out oc) + ~exceptionally:(fun _exn -> remove_file objfile); + ]} + + If [exceptionally] fail with an exception, it is propagated as + usual. + + If [always] or [exceptionally] use exceptions internally for + control-flow but do not raise, then [try_finally] is careful to + preserve any exception backtrace coming from [work] or [always] + for easier debugging. +*) + +val reraise_preserving_backtrace : exn -> (unit -> unit) -> 'a +(** [reraise_preserving_backtrace e f] is (f (); raise e) except that the + current backtrace is preserved, even if [f] uses exceptions internally. *) + +(** {1 List operations} *) + +val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list + (** [map_end f l t] is [map f l @ t], just more efficient. *) + +val rev_map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list + (** [map_end f l t] is [map f (rev l) @ t], just more efficient. *) + +val map_left_right: ('a -> 'b) -> 'a list -> 'b list + (** Like [List.map], with guaranteed left-to-right evaluation order *) + +val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + (** Same as [List.for_all] but for a binary predicate. + In addition, this [for_all2] never fails: given two lists + with different lengths, it returns false. *) + +val replicate_list: 'a -> int -> 'a list + (** [replicate_list elem n] is the list with [n] elements + all identical to [elem]. *) + +val list_remove: 'a -> 'a list -> 'a list + (** [list_remove x l] returns a copy of [l] with the first + element equal to [x] removed. *) + +val split_last: 'a list -> 'a list * 'a + (** Return the last element and the other elements of the given list. *) + +(** {1 Hash table operations} *) + +val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t + (** Create a hashtable with the given initial size and fills it + with the given bindings. *) + +(** {1 Extensions to the standard library} *) + +module Stdlib : sig + +(** {2 Extensions to the List module} *) + module List : sig + type 'a t = 'a list + + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** The lexicographic order supported by the provided order. + There is no constraint on the relative lengths of the lists. *) + + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + (** Returns [true] if and only if the given lists have the same length and + content with respect to the given equality function. *) + + val some_if_all_elements_are_some : 'a option t -> 'a t option + (** If all elements of the given list are [Some _] then [Some xs] + is returned with the [xs] being the contents of those [Some]s, with + order preserved. Otherwise return [None]. *) + + val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t) + (** [let r1, r2 = map2_prefix f l1 l2] + If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n, + r1 is [List.map2 f l1 h1] and r2 is t2. *) + + val iteri2 : (int -> 'a -> 'b -> unit) -> 'a list -> 'b list -> unit + (** Same as {!List.iter2}, but the function is applied to the index of + the element as first argument (counting from 0) *) + + val split_at : int -> 'a t -> 'a t * 'a t + (** [split_at n l] returns the pair [before, after] where [before] is + the [n] first elements of [l] and [after] the remaining ones. + If [l] has less than [n] elements, raises Invalid_argument. *) + + val chunks_of : int -> 'a t -> 'a t t + (** [chunks_of n t] returns a list of nonempty lists whose + concatenation is equal to the original list. Every list has [n] + elements, except for possibly the last list, which may have fewer. + [chunks_of] raises if [n <= 0]. *) + + val is_prefix + : equal:('a -> 'a -> bool) + -> 'a list + -> of_:'a list + -> bool + (** Returns [true] if and only if the given list, with respect to the given + equality function on list members, is a prefix of the list [of_]. *) + + type 'a longest_common_prefix_result = private { + longest_common_prefix : 'a list; + first_without_longest_common_prefix : 'a list; + second_without_longest_common_prefix : 'a list; + } + + val find_and_chop_longest_common_prefix + : equal:('a -> 'a -> bool) + -> first:'a list + -> second:'a list + -> 'a longest_common_prefix_result + (** Returns the longest list that, with respect to the provided equality + function, is a prefix of both of the given lists. The input lists, + each with such longest common prefix removed, are also returned. *) + end + +(** {2 Extensions to the Option module} *) + module Option : sig + type 'a t = 'a option + + val print + : (Format.formatter -> 'a -> unit) + -> Format.formatter + -> 'a t + -> unit + end + +(** {2 Extensions to the Array module} *) + module Array : sig + val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool + (** Same as [Array.exists2] from the standard library. *) + + val for_alli : (int -> 'a -> bool) -> 'a array -> bool + (** Same as [Array.for_all] from the standard library, but the + function is applied with the index of the element as first argument, + and the element itself as second argument. *) + + val all_somes : 'a option array -> 'a array option + end + +(** {2 Extensions to the String module} *) + module String : sig + include module type of String + module Set : Set.S with type elt = string + module Map : Map.S with type key = string + module Tbl : Hashtbl.S with type key = string + + val print : Format.formatter -> t -> unit + + val for_all : (char -> bool) -> t -> bool + end + + external compare : 'a -> 'a -> int = "%compare" +end + +(** {1 Operations on files and file paths} *) + +val find_in_path: string list -> string -> string + (** Search a file in a list of directories. *) + +val find_in_path_rel: string list -> string -> string + (** Search a relative file in a list of directories. *) + + (** Normalize file name [Foo.ml] to [foo.ml], using NFC and case-folding. + Return [Error] if the input is not a valid utf-8 byte sequence *) +val normalized_unit_filename: string -> (string,string) Result.t + +val find_in_path_normalized: string list -> string -> string +(** Same as {!find_in_path_rel} , but search also for normalized unit filename, + i.e. if name is [Foo.ml], allow [/path/Foo.ml] and [/path/foo.ml] to + match. *) + +val remove_file: string -> unit + (** Delete the given file if it exists and is a regular file. + Does nothing for other kinds of files. + Never raises an error. *) + +val expand_directory: string -> string -> string + (** [expand_directory alt file] eventually expands a [+] at the + beginning of file into [alt] (an alternate root directory) *) + +val split_path_contents: ?sep:char -> string -> string list + (** [split_path_contents ?sep s] interprets [s] as the value of + a "PATH"-like variable and returns the corresponding list of + directories. [s] is split using the platform-specific delimiter, or + [~sep] if it is passed. + + Returns the empty list if [s] is empty. *) + +val copy_file: in_channel -> out_channel -> unit + (** [copy_file ic oc] reads the contents of file [ic] and copies + them to [oc]. It stops when encountering EOF on [ic]. *) + +val copy_file_chunk: in_channel -> out_channel -> int -> unit + (** [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies + them to [oc]. It raises [End_of_file] when encountering + EOF on [ic]. *) + +val string_of_file: in_channel -> string + (** [string_of_file ic] reads the contents of file [ic] and copies + them to a string. It stops when encountering EOF on [ic]. *) + +val output_to_file_via_temporary: + ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a + (** Produce output in temporary file, then rename it + (as atomically as possible) to the desired output file name. + [output_to_file_via_temporary filename fn] opens a temporary file + which is passed to [fn] (name + output channel). When [fn] returns, + the channel is closed and the temporary file is renamed to + [filename]. *) + +val protect_writing_to_file + : filename:string + -> f:(out_channel -> 'a) + -> 'a + (** Open the given [filename] for writing (in binary mode), pass + the [out_channel] to the given function, then close the + channel. If the function raises an exception then [filename] + will be removed. *) + +val concat_null_terminated : string list -> string +(** [concat_null_terminated [x1;x2; ... xn]] is + [x1 ^ "\000" ^ x2 ^ "\000" ^ ... ^ xn ^ "\000"] *) + +val split_null_terminated : string -> string list +(** [split_null_terminated s] is similar + [String.split_on_char '\000'] but ignores the trailing separator, if any *) + +val chop_extensions: string -> string + (** Return the given file name without its extensions. The extensions + is the longest suffix starting with a period and not including + a directory separator, [.xyz.uvw] for instance. + + Return the given name if it does not contain an extension. *) + +(** {1 Integer operations} *) + +val log2: int -> int + (** [log2 n] returns [s] such that [n = 1 lsl s] + if [n] is a power of 2*) + +val align: int -> int -> int + (** [align n a] rounds [n] upwards to a multiple of [a] + (a power of 2). *) + +val no_overflow_add: int -> int -> bool + (** [no_overflow_add n1 n2] returns [true] if the computation of + [n1 + n2] does not overflow. *) + +val no_overflow_sub: int -> int -> bool + (** [no_overflow_sub n1 n2] returns [true] if the computation of + [n1 - n2] does not overflow. *) + +val no_overflow_mul: int -> int -> bool + (** [no_overflow_mul n1 n2] returns [true] if the computation of + [n1 * n2] does not overflow. *) + +val no_overflow_lsl: int -> int -> bool + (** [no_overflow_lsl n k] returns [true] if the computation of + [n lsl k] does not overflow. *) + +val letter_of_int : int -> string + +module Int_literal_converter : sig + val int : string -> int + (** Convert a string to an integer. Unlike {!Stdlib.int_of_string}, + this function accepts the string representation of [max_int + 1] + and returns [min_int] in this case. *) + + val int32 : string -> int32 + (** Likewise, at type [int32] *) + + val int64 : string -> int64 + (** Likewise, at type [int64] *) + + val nativeint : string -> nativeint + (** Likewise, at type [nativeint] *) + +end + +val find_first_mono : (int -> bool) -> int + (**[find_first_mono p] takes an integer predicate [p : int -> bool] + that we assume: + 1. is monotonic on natural numbers: + if [a <= b] then [p a] implies [p b], + 2. is satisfied for some natural numbers in range [0; max_int] + (this is equivalent to: [p max_int = true]). + + [find_first_mono p] is the smallest natural number N that satisfies [p], + computed in O(log(N)) calls to [p]. + + Our implementation supports two cases where the preconditions on [p] + are not respected: + - If [p] is always [false], we silently return [max_int] + instead of looping or crashing. + - If [p] is non-monotonic but eventually true, + we return some satisfying value. + *) + +(** {1 String operations} *) + +val search_substring: string -> string -> int -> int + (** [search_substring pat str start] returns the position of the first + occurrence of string [pat] in string [str]. Search starts + at offset [start] in [str]. Raise [Not_found] if [pat] + does not occur. *) + +val replace_substring: before:string -> after:string -> string -> string + (** [replace_substring ~before ~after str] replaces all + occurrences of [before] with [after] in [str] and returns + the resulting string. *) + +val rev_split_words: string -> string list + (** [rev_split_words s] splits [s] in blank-separated words, and returns + the list of words in reverse order. *) + +val cut_at : string -> char -> string * string +(** [String.cut_at s c] returns a pair containing the sub-string before + the first occurrence of [c] in [s], and the sub-string after the + first occurrence of [c] in [s]. + [let (before, after) = String.cut_at s c in + before ^ String.make 1 c ^ after] is the identity if [s] contains [c]. + + Raise [Not_found] if the character does not appear in the string + @since 4.01 +*) + +val ordinal_suffix : int -> string +(** [ordinal_suffix n] is the appropriate suffix to append to the numeral [n] as + an ordinal number: [1] -> ["st"], [2] -> ["nd"], [3] -> ["rd"], + [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and + the numbers 11--13 (which all get ["th"]) correctly. *) + +val normalise_eol : string -> string +(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters + removed. Intended for pre-processing text which will subsequently be printed + on a channel which performs EOL transformations (i.e. Windows) *) + +val delete_eol_spaces : string -> string +(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of + line spaces removed. Intended to normalize the output of the + toplevel for tests. *) + +(** {1 Operations on references} *) + +type ref_and_value = R : 'a ref * 'a -> ref_and_value + +val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a +(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l] + while executing [f]. The previous contents of the references is restored + even if [f] raises an exception, without altering the exception backtrace. +*) + +val get_ref: 'a list ref -> 'a list + (** [get_ref lr] returns the content of the list reference [lr] and reset + its content to the empty list. *) + +val set_or_ignore : ('a -> 'b option) -> 'b option ref -> 'a -> unit + (** [set_or_ignore f opt x] sets [opt] to [f x] if it returns [Some _], + or leaves it unmodified if it returns [None]. *) + +(** {1 Operations on triples and quadruples} *) + +val fst3: 'a * 'b * 'c -> 'a +val snd3: 'a * 'b * 'c -> 'b +val thd3: 'a * 'b * 'c -> 'c + +val fst4: 'a * 'b * 'c * 'd -> 'a +val snd4: 'a * 'b * 'c * 'd -> 'b +val thd4: 'a * 'b * 'c * 'd -> 'c +val for4: 'a * 'b * 'c * 'd -> 'd + +(** {1 Spell checking and ``did you mean'' suggestions} *) + +val edit_distance : string -> string -> int -> int option +(** [edit_distance a b cutoff] computes the edit distance between + strings [a] and [b]. To help efficiency, it uses a cutoff: if the + distance [d] is smaller than [cutoff], it returns [Some d], else + [None]. + + The distance algorithm currently used is Damerau-Levenshtein: it + computes the number of insertion, deletion, substitution of + letters, or swapping of adjacent letters to go from one word to the + other. The particular algorithm may change in the future. +*) + +val spellcheck : string list -> string -> string list +(** [spellcheck env name] takes a list of names [env] that exist in + the current environment and an erroneous [name], and returns a + list of suggestions taken from [env], that are close enough to + [name] that it may be a typo for one of them. *) + +val did_you_mean : + Format_doc.formatter -> (unit -> string list) -> unit +(** [did_you_mean ppf get_choices] hints that the user may have meant + one of the option returned by calling [get_choices]. It does nothing + if the returned list is empty. + + The [unit -> ...] thunking is meant to delay any potentially-slow + computation (typically computing edit-distance with many things + from the current environment) to when the hint message is to be + printed. You should print an understandable error message before + calling [did_you_mean], so that users get a clear notification of + the failure even if producing the hint is slow. +*) + +(** {1 Color support detection }*) +module Color: sig + + type setting = Auto | Always | Never + + val default_setting : setting + +end + + +(** {1 Styling handling for terminal output } *) + +module Style : sig + type color = + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + + type style = + | FG of color (* foreground *) + | BG of color (* background *) + | Bold + | Reset + type Format.stag += Style of style list + + val ansi_of_style_l : style list -> string + (* ANSI escape sequence for the given style *) + + type tag_style ={ + ansi: style list; + text_open:string; + text_close:string + } + + type styles = { + error: tag_style; + warning: tag_style; + loc: tag_style; + hint: tag_style; + inline_code: tag_style; + } + + val as_inline_code: 'a Format_doc.printer -> 'a Format_doc.printer + val inline_code: string Format_doc.printer + + val default_styles: styles + val get_styles: unit -> styles + val set_styles: styles -> unit + + val setup : Color.setting option -> unit + (* [setup opt] will enable or disable color handling on standard formatters + according to the value of color setting [opt]. + Only the first call to this function has an effect. *) + + val set_tag_handling : Format.formatter -> unit + (* adds functions to support color tags to the given formatter. *) +end + +(* See the -error-style option *) +module Error_style : sig + type setting = + | Contextual + | Short + + val default_setting : setting +end + +(** {1 Formatted output} *) + +val print_if : + Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a +(** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *) + +val print_see_manual : int list Format_doc.printer +(** See manual section *) + +(** {1 Displaying configuration variables} *) + +val show_config_and_exit : unit -> unit + (** Display the values of all compiler configuration variables from module + [Config], then exit the program with code 0. *) + +val show_config_variable_and_exit : string -> unit + (** Display the value of the given configuration variable, + then exit the program with code 0. *) + +(** {1 Handling of build maps} *) + +(** Build maps cause the compiler to normalize file names embedded in + object files, thus leading to more reproducible builds. *) + +val get_build_path_prefix_map: unit -> Build_path_prefix_map.map option +(** Returns the map encoded in the [BUILD_PATH_PREFIX_MAP] environment + variable. *) + +val debug_prefix_map_flags: unit -> string list +(** Returns the list of [--debug-prefix-map] flags to be passed to the + assembler, built from the [BUILD_PATH_PREFIX_MAP] environment variable. *) + +(** {1 Handling of magic numbers} *) + +module Magic_number : sig + (** a typical magic number is "Caml1999I011"; it is formed of an + alphanumeric prefix, here Caml1990I, followed by a version, + here 011. The prefix identifies the kind of the versioned data: + here the I indicates that it is the magic number for .cmi files. + + All magic numbers have the same byte length, [magic_length], and + this is important for users as it gives them the number of bytes + to read to obtain the byte sequence that should be a magic + number. Typical user code will look like: + {[ + let ic = open_in_bin path in + let magic = + try really_input_string ic Magic_number.magic_length + with End_of_file -> ... in + match Magic_number.parse magic with + | Error parse_error -> ... + | Ok info -> ... + ]} + + A given compiler version expects one specific version for each + kind of object file, and will fail if given an unsupported + version. Because versions grow monotonically, you can compare + the parsed version with the expected "current version" for + a kind, to tell whether the wrong-magic object file comes from + the past or from the future. + + An example of code block that expects the "currently supported version" + of a given kind of magic numbers, here [Cmxa], is as follows: + {[ + let ic = open_in_bin path in + begin + try Magic_number.(expect_current Cmxa (get_info ic)) with + | Parse_error error -> ... + | Unexpected error -> ... + end; + ... + ]} + + Parse errors distinguish inputs that are [Not_a_magic_number str], + which are likely to come from the file being completely + different, and [Truncated str], raised by headers that are the + (possibly empty) prefix of a valid magic number. + + Unexpected errors correspond to valid magic numbers that are not + the one expected, either because it corresponds to a different + kind, or to a newer or older version. + + The helper functions [explain_parse_error] and [explain_unexpected_error] + will generate a textual explanation of each error, + for use in error messages. + + @since 4.11 + *) + + type native_obj_config = { + flambda : bool; + } + (** native object files have a format and magic number that depend + on certain native-compiler configuration parameters. This + configuration space is expressed by the [native_obj_config] + type. *) + + val native_obj_config : native_obj_config + (** the native object file configuration of the active/configured compiler. *) + + type version = int + + type kind = + | Exec + | Cmi | Cmo | Cma + | Cmx of native_obj_config | Cmxa of native_obj_config + | Cmxs + | Cmt | Ast_impl | Ast_intf + + type info = { + kind: kind; + version: version; + (** Note: some versions of the compiler use the same [version] suffix + for all kinds, but others use different versions counters for different + kinds. We may only assume that versions are growing monotonically + (not necessarily always by one) between compiler versions. *) + } + + type raw = string + (** the type of raw magic numbers, + such as "Caml1999A027" for the .cma files of OCaml 4.10 *) + + (** {3 Parsing magic numbers} *) + + type parse_error = + | Truncated of string + | Not_a_magic_number of string + + val explain_parse_error : kind option -> parse_error -> string + (** Produces an explanation for a parse error. If no kind is provided, + we use an unspecific formulation suggesting that any compiler-produced + object file would have been satisfying. *) + + val parse : raw -> (info, parse_error) result + (** Parses a raw magic number *) + + val read_info : in_channel -> (info, parse_error) result + (** Read a raw magic number from an input channel. + + If the data read [str] is not a valid magic number, it can be + recovered from the [Truncated str | Not_a_magic_number str] + payload of the [Error parse_error] case. + + If parsing succeeds with an [Ok info] result, we know that + exactly [magic_length] bytes have been consumed from the + input_channel. + + If you also wish to enforce that the magic number + is at the current version, see {!read_current_info} below. + *) + + val magic_length : int + (** all magic numbers take the same number of bytes *) + + + (** {3 Checking that magic numbers are current} *) + + type 'a unexpected = { expected : 'a; actual : 'a } + type unexpected_error = + | Kind of kind unexpected + | Version of kind * version unexpected + + val check_current : kind -> info -> (unit, unexpected_error) result + (** [check_current kind info] checks that the provided magic [info] + is the current version of [kind]'s magic header. *) + + val explain_unexpected_error : unexpected_error -> string + (** Provides an explanation of the [unexpected_error]. *) + + type error = + | Parse_error of parse_error + | Unexpected_error of unexpected_error + + val read_current_info : + expected_kind:kind option -> in_channel -> (info, error) result + (** Read a magic number as [read_info], + and check that it is the current version as its kind. + If the [expected_kind] argument is [None], any kind is accepted. *) + + + (** {3 Information on magic numbers} *) + + val string_of_kind : kind -> string + (** a user-printable string for a kind, eg. "exec" or "cmo", to use + in error messages. *) + + val human_name_of_kind : kind -> string + (** a user-meaningful name for a kind, eg. "executable file" or + "bytecode object file", to use in error messages. *) + + val current_raw : kind -> raw + (** the current magic number of each kind *) + + val current_version : kind -> version + (** the current version of each kind *) + + + (** {3 Raw representations} + + Mainly for internal usage and testing. *) + + type raw_kind = string + (** the type of raw magic numbers kinds, + such as "Caml1999A" for .cma files *) + + val parse_kind : raw_kind -> kind option + (** parse a raw kind into a kind *) + + val raw_kind : kind -> raw_kind + (** the current raw representation of a kind. + + In some cases the raw representation of a kind has changed + over compiler versions, so other files of the same kind + may have different raw kinds. + Note that all currently known cases are parsed correctly by [parse_kind]. + *) + + val raw : info -> raw + (** A valid raw representation of the magic number. + + Due to past and future changes in the string representation of + magic numbers, we cannot guarantee that the raw strings returned + for past and future versions actually match the expectations of + those compilers. The representation is accurate for current + versions, and it is correctly parsed back into the desired + version by the parsing functions above. + *) + + val all_kinds : kind list +end + +(** {1 Minimal support for Unicode characters in identifiers} *) + +(** Characters allowed in identifiers are, currently: + - ASCII letters A-Z a-z + - Latin-1 letters (U+00C0 - U+00FF except U+00D7 and U+00F7) + - Character sequences which normalize to the above character under NFC + - digits 0-9, underscore, single quote +*) + +module Utf8_lexeme: sig + type t = string + + val normalize: string -> (t,t) Result.t + (** Normalize the given UTF-8 encoded string. + Invalid UTF-8 sequences results in a error and are replaced + by U+FFFD. + Identifier characters are put in NFC normalized form. + Other Unicode characters are left unchanged. *) + + val capitalize: string -> (t,t) Result.t + (** Like [normalize], but if the string starts with a lowercase identifier + character, it is replaced by the corresponding uppercase character. + Subsequent characters are not changed. *) + + val uncapitalize: string -> (t,t) Result.t + (** Like [normalize], but if the string starts with an uppercase identifier + character, it is replaced by the corresponding lowercase character. + Subsequent characters are not changed. *) + + val is_capitalized: t -> bool + (** Returns [true] if the given normalized string starts with an + uppercase identifier character, [false] otherwise. May return + wrong results if the string is not normalized. *) + + val is_valid_identifier: t -> bool + (** Check whether the given normalized string is a valid OCaml identifier: + - all characters are identifier characters + - it does not start with a digit or a single quote + *) + + val is_lowercase: t -> bool + (** Returns [true] if the given normalized string only contains lowercase + identifier character, [false] otherwise. May return wrong results if the + string is not normalized. *) + + type validation_result = + | Valid + | Invalid_character of Uchar.t (** Character not allowed *) + | Invalid_beginning of Uchar.t (** Character not allowed as first char *) + + val validate_identifier: ?with_dot:bool -> t -> validation_result + (** Like [is_valid_identifier], but returns a more detailed error code. Dots + can be allowed to extend support to path-like identifiers. *) + + val starts_like_a_valid_identifier: t -> bool + (** Checks whether the given normalized string starts with an identifier + character other than a digit or a single quote. Subsequent characters + are not checked. *) +end + +(** {1 Miscellaneous type aliases} *) + +type filepath = string +type modname = string +type crcs = (modname * Digest.t option) list + +type alerts = string Stdlib.String.Map.t diff --git a/upstream/ocaml_503/utils/numbers.ml b/upstream/ocaml_503/utils/numbers.ml new file mode 100644 index 000000000..1680675ba --- /dev/null +++ b/upstream/ocaml_503/utils/numbers.ml @@ -0,0 +1,88 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Int_base = Identifiable.Make (struct + type t = int + + let compare x y = x - y + let output oc x = Printf.fprintf oc "%i" x + let hash i = i + let equal (i : int) j = i = j + let print = Format.pp_print_int +end) + +module Int = struct + type t = int + + include Int_base + + let rec zero_to_n n = + if n < 0 then Set.empty else Set.add n (zero_to_n (n-1)) + + let to_string n = Int.to_string n +end + +module Int8 = struct + type t = int + + let zero = 0 + let one = 1 + + let of_int_exn i = + if i < -(1 lsl 7) || i > ((1 lsl 7) - 1) then + Misc.fatal_errorf "Int8.of_int_exn: %d is out of range" i + else + i + + let to_int i = i +end + +module Int16 = struct + type t = int + + let of_int_exn i = + if i < -(1 lsl 15) || i > ((1 lsl 15) - 1) then + Misc.fatal_errorf "Int16.of_int_exn: %d is out of range" i + else + i + + let lower_int64 = Int64.neg (Int64.shift_left Int64.one 15) + let upper_int64 = Int64.sub (Int64.shift_left Int64.one 15) Int64.one + + let of_int64_exn i = + if Int64.compare i lower_int64 < 0 + || Int64.compare i upper_int64 > 0 + then + Misc.fatal_errorf "Int16.of_int64_exn: %Ld is out of range" i + else + Int64.to_int i + + let to_int t = t +end + +module Float = struct + type t = float + + include Identifiable.Make (struct + type t = float + + let compare x y = Stdlib.compare x y + let output oc x = Printf.fprintf oc "%f" x + let hash f = Hashtbl.hash f + let equal (i : float) j = i = j + let print = Format.pp_print_float + end) +end diff --git a/upstream/ocaml_503/utils/numbers.mli b/upstream/ocaml_503/utils/numbers.mli new file mode 100644 index 000000000..fa565e67e --- /dev/null +++ b/upstream/ocaml_503/utils/numbers.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Modules about numbers, some of which satisfy {!Identifiable.S}. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +module Int : sig + include Identifiable.S with type t = int + + (** [zero_to_n n] is the set of numbers \{0, ..., n\} (inclusive). *) + val zero_to_n : int -> Set.t + val to_string : int -> string +end + +module Int8 : sig + type t + + val zero : t + val one : t + + val of_int_exn : int -> t + val to_int : t -> int +end + +module Int16 : sig + type t + + val of_int_exn : int -> t + val of_int64_exn : Int64.t -> t + + val to_int : t -> int +end + +module Float : Identifiable.S with type t = float diff --git a/upstream/ocaml_503/utils/profile.ml b/upstream/ocaml_503/utils/profile.ml new file mode 100644 index 000000000..27c92a546 --- /dev/null +++ b/upstream/ocaml_503/utils/profile.ml @@ -0,0 +1,335 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-18-40-42-48"] + +type file = string + +external time_include_children: bool -> float = "caml_sys_time_include_children" +let cpu_time () = time_include_children true + +module Measure = struct + type t = { + time : float; + allocated_words : float; + top_heap_words : int; + } + let create () = + let stat = Gc.quick_stat () in + { + time = cpu_time (); + allocated_words = stat.minor_words +. stat.major_words; + top_heap_words = stat.top_heap_words; + } + let zero = { time = 0.; allocated_words = 0.; top_heap_words = 0 } +end + +module Measure_diff = struct + let timestamp = let r = ref (-1) in fun () -> incr r; !r + type t = { + timestamp : int; + duration : float; + allocated_words : float; + top_heap_words_increase : int; + } + let zero () = { + timestamp = timestamp (); + duration = 0.; + allocated_words = 0.; + top_heap_words_increase = 0; + } + let accumulate t (m1 : Measure.t) (m2 : Measure.t) = { + timestamp = t.timestamp; + duration = t.duration +. (m2.time -. m1.time); + allocated_words = + t.allocated_words +. (m2.allocated_words -. m1.allocated_words); + top_heap_words_increase = + t.top_heap_words_increase + (m2.top_heap_words - m1.top_heap_words); + } + let of_diff m1 m2 = + accumulate (zero ()) m1 m2 +end + +type hierarchy = + | E of (string, Measure_diff.t * hierarchy) Hashtbl.t +[@@unboxed] + +let create () = E (Hashtbl.create 2) +let hierarchy = ref (create ()) +let initial_measure = ref None +let reset () = hierarchy := create (); initial_measure := None + +let record_call ?(accumulate = false) name f = + let E prev_hierarchy = !hierarchy in + let start_measure = Measure.create () in + if !initial_measure = None then initial_measure := Some start_measure; + let this_measure_diff, this_table = + (* We allow the recording of multiple categories by the same name, for tools + like ocamldoc that use the compiler libs but don't care about profile + information, and so may record, say, "parsing" multiple times. *) + if accumulate + then + match Hashtbl.find prev_hierarchy name with + | exception Not_found -> Measure_diff.zero (), Hashtbl.create 2 + | measure_diff, E table -> + Hashtbl.remove prev_hierarchy name; + measure_diff, table + else Measure_diff.zero (), Hashtbl.create 2 + in + hierarchy := E this_table; + Misc.try_finally f + ~always:(fun () -> + hierarchy := E prev_hierarchy; + let end_measure = Measure.create () in + let measure_diff = + Measure_diff.accumulate this_measure_diff start_measure end_measure in + Hashtbl.add prev_hierarchy name (measure_diff, E this_table)) + +let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x) + +type display = { + to_string : max:float -> width:int -> string; + worth_displaying : max:float -> bool; +} + +let time_display v : display = + (* Because indentation is meaningful, and because the durations are + the first element of each row, we can't pad them with spaces. *) + let to_string_without_unit v ~width = Printf.sprintf "%0*.03f" width v in + let to_string ~max:_ ~width = + to_string_without_unit v ~width:(width - 1) ^ "s" in + let worth_displaying ~max:_ = + float_of_string (to_string_without_unit v ~width:0) <> 0. in + { to_string; worth_displaying } + +let memory_word_display = + (* To make memory numbers easily comparable across rows, we choose a single + scale for an entire column. To keep the display compact and not overly + precise (no one cares about the exact number of bytes), we pick the largest + scale we can and we only show 3 digits. Avoiding showing tiny numbers also + allows us to avoid displaying passes that barely allocate compared to the + rest of the compiler. *) + let bytes_of_words words = words *. float_of_int (Sys.word_size / 8) in + let to_string_without_unit v ~width scale = + let precision = 3 and precision_power = 1e3 in + let v_rescaled = bytes_of_words v /. scale in + let v_rounded = + floor (v_rescaled *. precision_power +. 0.5) /. precision_power in + let v_str = Printf.sprintf "%.*f" precision v_rounded in + let index_of_dot = String.index v_str '.' in + let v_str_truncated = + String.sub v_str 0 + (if index_of_dot >= precision + then index_of_dot + else precision + 1) + in + Printf.sprintf "%*s" width v_str_truncated + in + let choose_memory_scale = + let units = [|"B"; "kB"; "MB"; "GB"|] in + fun words -> + let bytes = bytes_of_words words in + let scale = ref (Array.length units - 1) in + while !scale > 0 && bytes < 1024. ** float_of_int !scale do + decr scale + done; + 1024. ** float_of_int !scale, units.(!scale) + in + fun ?previous v : display -> + let to_string ~max ~width = + let scale, scale_str = choose_memory_scale max in + let width = width - String.length scale_str in + to_string_without_unit v ~width scale ^ scale_str + in + let worth_displaying ~max = + let scale, _ = choose_memory_scale max in + float_of_string (to_string_without_unit v ~width:0 scale) <> 0. + && match previous with + | None -> true + | Some p -> + (* This branch is for numbers that represent absolute quantity, rather + than differences. It allows us to skip displaying the same absolute + quantity many times in a row. *) + to_string_without_unit p ~width:0 scale + <> to_string_without_unit v ~width:0 scale + in + { to_string; worth_displaying } + +let profile_list (E table) = + let l = Hashtbl.fold (fun k d l -> (k, d) :: l) table [] in + List.sort (fun (_, (p1, _)) (_, (p2, _)) -> + compare p1.Measure_diff.timestamp p2.Measure_diff.timestamp) l + +let compute_other_category (E table : hierarchy) (total : Measure_diff.t) = + let r = ref total in + Hashtbl.iter (fun _pass ((p2 : Measure_diff.t), _) -> + let p1 = !r in + r := { + timestamp = p1.timestamp; + duration = p1.duration -. p2.duration; + allocated_words = p1.allocated_words -. p2.allocated_words; + top_heap_words_increase = + p1.top_heap_words_increase - p2.top_heap_words_increase; + } + ) table; + !r + +type row = R of string * (float * display) list * row list +type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ] + +let rec rows_of_hierarchy ~nesting make_row name measure_diff hierarchy env = + let rows = + rows_of_hierarchy_list + ~nesting:(nesting + 1) make_row hierarchy measure_diff env in + let values, env = + make_row env measure_diff ~toplevel_other:(nesting = 0 && name = "other") in + R (name, values, rows), env + +and rows_of_hierarchy_list ~nesting make_row hierarchy total env = + let list = profile_list hierarchy in + let list = + if list <> [] || nesting = 0 + then list @ [ "other", (compute_other_category hierarchy total, create ()) ] + else [] + in + let env = ref env in + List.map (fun (name, (measure_diff, hierarchy)) -> + let a, env' = + rows_of_hierarchy ~nesting make_row name measure_diff hierarchy !env in + env := env'; + a + ) list + +let rows_of_hierarchy hierarchy measure_diff initial_measure columns = + (* Computing top heap size is a bit complicated: if the compiler applies a + list of passes n times (rather than applying pass1 n times, then pass2 n + times etc), we only show one row for that pass but what does "top heap + size at the end of that pass" even mean? + It seems the only sensible answer is to pretend the compiler applied pass1 + n times, pass2 n times by accumulating all the heap size increases that + happened during each pass, and then compute what the heap size would have + been. So that's what we do. + There's a bit of extra complication, which is that the heap can increase in + between measurements. So the heap sizes can be a bit off until the "other" + rows account for what's missing. We special case the toplevel "other" row + so that any increases that happened before the start of the compilation is + correctly reported, as a lot of code may run before the start of the + compilation (eg functor applications). *) + let make_row prev_top_heap_words (p : Measure_diff.t) ~toplevel_other = + let top_heap_words = + prev_top_heap_words + + p.top_heap_words_increase + - if toplevel_other + then initial_measure.Measure.top_heap_words + else 0 + in + let make value ~f = value, f value in + List.map (function + | `Time -> + make p.duration ~f:time_display + | `Alloc -> + make p.allocated_words ~f:memory_word_display + | `Top_heap -> + make (float_of_int p.top_heap_words_increase) ~f:memory_word_display + | `Abs_top_heap -> + make (float_of_int top_heap_words) + ~f:(memory_word_display ~previous:(float_of_int prev_top_heap_words)) + ) columns, + top_heap_words + in + rows_of_hierarchy_list ~nesting:0 make_row hierarchy measure_diff + initial_measure.top_heap_words + +let max_by_column ~n_columns rows = + let a = Array.make n_columns 0. in + let rec loop (R (_, values, rows)) = + List.iteri (fun i (v, _) -> a.(i) <- Float.max a.(i) v) values; + List.iter loop rows + in + List.iter loop rows; + a + +let width_by_column ~n_columns ~display_cell rows = + let a = Array.make n_columns 1 in + let rec loop (R (_, values, rows)) = + List.iteri (fun i cell -> + let _, str = display_cell i cell ~width:0 in + a.(i) <- Int.max a.(i) (String.length str) + ) values; + List.iter loop rows; + in + List.iter loop rows; + a + +let display_rows ppf rows = + let n_columns = + match rows with + | [] -> 0 + | R (_, values, _) :: _ -> List.length values + in + let maxs = max_by_column ~n_columns rows in + let display_cell i (_, c) ~width = + let display_cell = c.worth_displaying ~max:maxs.(i) in + display_cell, if display_cell + then c.to_string ~max:maxs.(i) ~width + else String.make width '-' + in + let widths = width_by_column ~n_columns ~display_cell rows in + let rec loop (R (name, values, rows)) ~indentation = + let worth_displaying, cell_strings = + values + |> List.mapi (fun i cell -> display_cell i cell ~width:widths.(i)) + |> List.split + in + if List.exists (fun b -> b) worth_displaying then + Format.fprintf ppf "%s%s %s@\n" + indentation (String.concat " " cell_strings) name; + List.iter (loop ~indentation:(" " ^ indentation)) rows; + in + List.iter (loop ~indentation:"") rows + +let print ppf columns = + match columns with + | [] -> () + | _ :: _ -> + let initial_measure = + match !initial_measure with + | Some v -> v + | None -> Measure.zero + in + let total = Measure_diff.of_diff Measure.zero (Measure.create ()) in + display_rows ppf + (rows_of_hierarchy !hierarchy total initial_measure columns) + +let column_mapping = [ + "time", `Time; + "alloc", `Alloc; + "top-heap", `Top_heap; + "absolute-top-heap", `Abs_top_heap; +] + +let column_names = List.map fst column_mapping + +let options_doc = + Printf.sprintf + " Print performance information for each pass\ + \n The columns are: %s." + (String.concat " " column_names) + +let all_columns = List.map snd column_mapping + +let generate = "generate" +let transl = "transl" +let typing = "typing" diff --git a/upstream/ocaml_503/utils/profile.mli b/upstream/ocaml_503/utils/profile.mli new file mode 100644 index 000000000..7eff6957b --- /dev/null +++ b/upstream/ocaml_503/utils/profile.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Compiler performance recording + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type file = string + +val reset : unit -> unit +(** erase all recorded profile information *) + +val record_call : ?accumulate:bool -> string -> (unit -> 'a) -> 'a +(** [record_call pass f] calls [f] and records its profile information. *) + +val record : ?accumulate:bool -> string -> ('a -> 'b) -> 'a -> 'b +(** [record pass f arg] records the profile information of [f arg] *) + +type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ] + +val print : Format.formatter -> column list -> unit +(** Prints the selected recorded profiling information to the formatter. *) + +(** Command line flags *) + +val options_doc : string +val all_columns : column list + +(** A few pass names that are needed in several places, and shared to + avoid typos. *) + +val generate : string +val transl : string +val typing : string diff --git a/upstream/ocaml_503/utils/strongly_connected_components.ml b/upstream/ocaml_503/utils/strongly_connected_components.ml new file mode 100644 index 000000000..eb1501ca7 --- /dev/null +++ b/upstream/ocaml_503/utils/strongly_connected_components.ml @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Int = Numbers.Int + +module Kosaraju : sig + type component_graph = + { sorted_connected_components : int list array; + component_edges : int list array; + } + + val component_graph : int list array -> component_graph +end = struct + let transpose graph = + let size = Array.length graph in + let transposed = Array.make size [] in + let add src dst = transposed.(src) <- dst :: transposed.(src) in + Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts) + graph; + transposed + + let depth_first_order (graph : int list array) : int array = + let size = Array.length graph in + let marked = Array.make size false in + let stack = Array.make size ~-1 in + let pos = ref 0 in + let push i = + stack.(!pos) <- i; + incr pos + in + let rec aux node = + if not marked.(node) + then begin + marked.(node) <- true; + List.iter aux graph.(node); + push node + end + in + for i = 0 to size - 1 do + aux i + done; + stack + + let mark order graph = + let size = Array.length graph in + let graph = transpose graph in + let marked = Array.make size false in + let id = Array.make size ~-1 in + let count = ref 0 in + let rec aux node = + if not marked.(node) + then begin + marked.(node) <- true; + id.(node) <- !count; + List.iter aux graph.(node) + end + in + for i = size - 1 downto 0 do + let node = order.(i) in + if not marked.(node) + then begin + aux order.(i); + incr count + end + done; + id, !count + + let kosaraju graph = + let dfo = depth_first_order graph in + let components, ncomponents = mark dfo graph in + ncomponents, components + + type component_graph = + { sorted_connected_components : int list array; + component_edges : int list array; + } + + let component_graph graph = + let ncomponents, components = kosaraju graph in + let id_scc = Array.make ncomponents [] in + let component_graph = Array.make ncomponents Int.Set.empty in + let add_component_dep node set = + let node_deps = graph.(node) in + List.fold_left (fun set dep -> Int.Set.add components.(dep) set) + set node_deps + in + Array.iteri (fun node component -> + id_scc.(component) <- node :: id_scc.(component); + component_graph.(component) <- + add_component_dep node (component_graph.(component))) + components; + { sorted_connected_components = id_scc; + component_edges = Array.map Int.Set.elements component_graph; + } +end + +module type S = sig + module Id : Identifiable.S + + type directed_graph = Id.Set.t Id.Map.t + + type component = + | Has_loop of Id.t list + | No_loop of Id.t + + val connected_components_sorted_from_roots_to_leaf + : directed_graph + -> component array + + val component_graph : directed_graph -> (component * int list) array +end + +module Make (Id : Identifiable.S) = struct + type directed_graph = Id.Set.t Id.Map.t + + type component = + | Has_loop of Id.t list + | No_loop of Id.t + + (* Ensure that the dependency graph does not have external dependencies. *) + (* Note: this function is currently not used. *) + let _check dependencies = + Id.Map.iter (fun id set -> + Id.Set.iter (fun v -> + if not (Id.Map.mem v dependencies) + then + Misc.fatal_errorf "Strongly_connected_components.check: the \ + graph has external dependencies (%a -> %a)" + Id.print id Id.print v) + set) + dependencies + + let number graph = + let size = Id.Map.cardinal graph in + let bindings = Id.Map.bindings graph in + let a = Array.of_list bindings in + let forth = Array.map fst a in + let back = + let back = ref Id.Map.empty in + for i = 0 to size - 1 do + back := Id.Map.add forth.(i) i !back; + done; + !back + in + let integer_graph = + Array.init size (fun i -> + let _, dests = a.(i) in + Id.Set.fold (fun dest acc -> + let v = + try Id.Map.find dest back + with Not_found -> + Misc.fatal_errorf + "Strongly_connected_components: missing dependency %a" + Id.print dest + in + v :: acc) + dests []) + in + forth, integer_graph + + let component_graph graph = + let forth, integer_graph = number graph in + let { Kosaraju. sorted_connected_components; + component_edges } = + Kosaraju.component_graph integer_graph + in + Array.mapi (fun component nodes -> + match nodes with + | [] -> assert false + | [node] -> + (if List.mem node integer_graph.(node) + then Has_loop [forth.(node)] + else No_loop forth.(node)), + component_edges.(component) + | _::_ -> + (Has_loop (List.map (fun node -> forth.(node)) nodes)), + component_edges.(component)) + sorted_connected_components + + let connected_components_sorted_from_roots_to_leaf graph = + Array.map fst (component_graph graph) +end diff --git a/upstream/ocaml_503/utils/strongly_connected_components.mli b/upstream/ocaml_503/utils/strongly_connected_components.mli new file mode 100644 index 000000000..e70095279 --- /dev/null +++ b/upstream/ocaml_503/utils/strongly_connected_components.mli @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Kosaraju's algorithm for strongly connected components. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +module type S = sig + module Id : Identifiable.S + + type directed_graph = Id.Set.t Id.Map.t + (** If (a -> set) belongs to the map, it means that there are edges + from [a] to every element of [set]. It is assumed that no edge + points to a vertex not represented in the map. *) + + type component = + | Has_loop of Id.t list + | No_loop of Id.t + + val connected_components_sorted_from_roots_to_leaf + : directed_graph + -> component array + + val component_graph : directed_graph -> (component * int list) array +end + +module Make (Id : Identifiable.S) : S with module Id := Id diff --git a/upstream/ocaml_503/utils/targetint.ml b/upstream/ocaml_503/utils/targetint.ml new file mode 100644 index 000000000..9d15a2ff5 --- /dev/null +++ b/upstream/ocaml_503/utils/targetint.ml @@ -0,0 +1,104 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2016 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type repr = + | Int32 of int32 + | Int64 of int64 + +module type S = sig + type t + val zero : t + val one : t + val minus_one : t + val neg : t -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + val unsigned_div : t -> t -> t + val rem : t -> t -> t + val unsigned_rem : t -> t -> t + val succ : t -> t + val pred : t -> t + val abs : t -> t + val max_int : t + val min_int : t + val logand : t -> t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + val lognot : t -> t + val shift_left : t -> int -> t + val shift_right : t -> int -> t + val shift_right_logical : t -> int -> t + val of_int : int -> t + val of_int_exn : int -> t + val to_int : t -> int + val of_float : float -> t + val to_float : t -> float + val of_int32 : int32 -> t + val to_int32 : t -> int32 + val of_int64 : int64 -> t + val to_int64 : t -> int64 + val of_string : string -> t + val to_string : t -> string + val compare: t -> t -> int + val unsigned_compare : t -> t -> int + val equal: t -> t -> bool + val repr: t -> repr + val print : Format.formatter -> t -> unit +end + +let size = Sys.word_size +(* Later, this will be set by the configure script + in order to support cross-compilation. *) + +module Int32 = struct + include Int32 + let of_int_exn = + match Sys.word_size with (* size of [int] *) + | 32 -> + Int32.of_int + | 64 -> + fun n -> + if n < Int32.(to_int min_int) || n > Int32.(to_int max_int) then + Misc.fatal_errorf "Targetint.of_int_exn: 0x%x out of range" n + else + Int32.of_int n + | _ -> + assert false + let of_int32 x = x + let to_int32 x = x + let of_int64 = Int64.to_int32 + let to_int64 = Int64.of_int32 + let repr x = Int32 x + let print ppf t = Format.fprintf ppf "%ld" t +end + +module Int64 = struct + include Int64 + let of_int_exn = Int64.of_int + let of_int64 x = x + let to_int64 x = x + let repr x = Int64 x + let print ppf t = Format.fprintf ppf "%Ld" t +end + +include (val + (match size with + | 32 -> (module Int32) + | 64 -> (module Int64) + | _ -> assert false + ) : S) diff --git a/upstream/ocaml_503/utils/targetint.mli b/upstream/ocaml_503/utils/targetint.mli new file mode 100644 index 000000000..a222f5d68 --- /dev/null +++ b/upstream/ocaml_503/utils/targetint.mli @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2016 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Target processor-native integers. + + This module provides operations on the type of + signed 32-bit integers (on 32-bit target platforms) or + signed 64-bit integers (on 64-bit target platforms). + This integer type has exactly the same width as that of a + pointer type in the C compiler. All arithmetic operations over + are taken modulo 2{^32} or 2{^64} depending + on the word size of the target architecture. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type t +(** The type of target integers. *) + +val zero : t +(** The target integer 0.*) + +val one : t +(** The target integer 1.*) + +val minus_one : t +(** The target integer -1.*) + +val neg : t -> t +(** Unary negation. *) + +val add : t -> t -> t +(** Addition. *) + +val sub : t -> t -> t +(** Subtraction. *) + +val mul : t -> t -> t +(** Multiplication. *) + +val div : t -> t -> t +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Stdlib.(/)}. *) + +val unsigned_div : t -> t -> t +(** Same as {!div}, except that arguments and result are interpreted as {e + unsigned} integers. *) + +val rem : t -> t -> t +(** Integer remainder. If [y] is not zero, the result + of [Targetint.rem x y] satisfies the following properties: + [Targetint.zero <= Nativeint.rem x y < Targetint.abs y] and + [x = Targetint.add (Targetint.mul (Targetint.div x y) y) + (Targetint.rem x y)]. + If [y = 0], [Targetint.rem x y] raises [Division_by_zero]. *) + +val unsigned_rem : t -> t -> t +(** Same as {!rem}, except that arguments and result are interpreted as {e + unsigned} integers. *) + +val succ : t -> t +(** Successor. + [Targetint.succ x] is [Targetint.add x Targetint.one]. *) + +val pred : t -> t +(** Predecessor. + [Targetint.pred x] is [Targetint.sub x Targetint.one]. *) + +val abs : t -> t +(** [abs x] is the absolute value of [x]. On [min_int] this + is [min_int] itself and thus remains negative. *) + +val size : int +(** The size in bits of a target native integer. *) + +val max_int : t +(** The greatest representable target integer, + either 2{^31} - 1 on a 32-bit platform, + or 2{^63} - 1 on a 64-bit platform. *) + +val min_int : t +(** The smallest representable target integer, + either -2{^31} on a 32-bit platform, + or -2{^63} on a 64-bit platform. *) + +val logand : t -> t -> t +(** Bitwise logical and. *) + +val logor : t -> t -> t +(** Bitwise logical or. *) + +val logxor : t -> t -> t +(** Bitwise logical exclusive or. *) + +val lognot : t -> t +(** Bitwise logical negation. *) + +val shift_left : t -> int -> t +(** [Targetint.shift_left x y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= bitsize], + where [bitsize] is [32] on a 32-bit platform and + [64] on a 64-bit platform. *) + +val shift_right : t -> int -> t +(** [Targetint.shift_right x y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= bitsize]. *) + +val shift_right_logical : t -> int -> t +(** [Targetint.shift_right_logical x y] shifts [x] to the right + by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= bitsize]. *) + +val of_int : int -> t +(** Convert the given integer (type [int]) to a target integer + (type [t]), module the target word size. *) + +val of_int_exn : int -> t +(** Convert the given integer (type [int]) to a target integer + (type [t]). Raises a fatal error if the conversion is not exact. *) + +val to_int : t -> int +(** Convert the given target integer (type [t]) to an + integer (type [int]). The high-order bit is lost during + the conversion. *) + +val of_float : float -> t +(** Convert the given floating-point number to a target integer, + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range + \[{!Targetint.min_int}, {!Targetint.max_int}\]. *) + +val to_float : t -> float +(** Convert the given target integer to a floating-point number. *) + +val of_int32 : int32 -> t +(** Convert the given 32-bit integer (type [int32]) + to a target integer. *) + +val to_int32 : t -> int32 +(** Convert the given target integer to a + 32-bit integer (type [int32]). On 64-bit platforms, + the 64-bit native integer is taken modulo 2{^32}, + i.e. the top 32 bits are lost. On 32-bit platforms, + the conversion is exact. *) + +val of_int64 : int64 -> t +(** Convert the given 64-bit integer (type [int64]) + to a target integer. *) + +val to_int64 : t -> int64 +(** Convert the given target integer to a + 64-bit integer (type [int64]). *) + +val of_string : string -> t +(** Convert the given string to a target integer. + The string is read in decimal (by default) or in hexadecimal, + octal or binary if the string begins with [0x], [0o] or [0b] + respectively. + Raise [Failure "int_of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [nativeint]. *) + +val to_string : t -> string +(** Return the string representation of its argument, in decimal. *) + +val compare: t -> t -> int +(** The comparison function for target integers, with the same specification as + {!Stdlib.compare}. Along with the type [t], this function [compare] + allows the module [Targetint] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) + +val unsigned_compare: t -> t -> int +(** Same as {!compare}, except that arguments are interpreted as {e unsigned} + integers. *) + +val equal: t -> t -> bool +(** The equal function for target ints. *) + +type repr = + | Int32 of int32 + | Int64 of int64 + +val repr : t -> repr +(** The concrete representation of a native integer. *) + +val print : Format.formatter -> t -> unit +(** Print a target integer to a formatter. *) diff --git a/upstream/ocaml_503/utils/terminfo.ml b/upstream/ocaml_503/utils/terminfo.ml new file mode 100644 index 000000000..1b4a3578e --- /dev/null +++ b/upstream/ocaml_503/utils/terminfo.ml @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Paris *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Printf + +external isatty : out_channel -> bool = "caml_sys_isatty" +external terminfo_rows: out_channel -> int = "caml_terminfo_rows" + +type status = + | Uninitialised + | Bad_term + | Good_term + +let setup oc = + let term = try Sys.getenv "TERM" with Not_found -> "" in + (* Same heuristics as in Misc.Color.should_enable_color *) + if term <> "" && term <> "dumb" && isatty oc + then Good_term + else Bad_term + +let num_lines oc = + let rows = terminfo_rows oc in + if rows > 0 then rows else 24 + (* 24 is a reasonable default for an ANSI-style terminal *) + +let backup oc n = + if n >= 1 then fprintf oc "\027[%dA%!" n + +let resume oc n = + if n >= 1 then fprintf oc "\027[%dB%!" n + +let standout oc b = + output_string oc (if b then "\027[4m" else "\027[0m"); flush oc diff --git a/upstream/ocaml_503/utils/terminfo.mli b/upstream/ocaml_503/utils/terminfo.mli new file mode 100644 index 000000000..10f5f5453 --- /dev/null +++ b/upstream/ocaml_503/utils/terminfo.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Basic interface to the terminfo database + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type status = + | Uninitialised + | Bad_term + | Good_term + +val setup : out_channel -> status +val num_lines : out_channel -> int +val backup : out_channel -> int -> unit +val standout : out_channel -> bool -> unit +val resume : out_channel -> int -> unit diff --git a/upstream/ocaml_503/utils/warnings.ml b/upstream/ocaml_503/utils/warnings.ml new file mode 100644 index 000000000..d9670caf4 --- /dev/null +++ b/upstream/ocaml_503/utils/warnings.ml @@ -0,0 +1,1259 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* When you change this, you need to update: + - the list 'description' at the bottom of this file + - man/ocamlc.m +*) + +type loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +type field_usage_warning = + | Unused + | Not_read + | Not_mutated + +type constructor_usage_warning = + | Unused + | Not_constructed + | Only_exported_private + +type t = + | Comment_start (* 1 *) + | Comment_not_end (* 2 *) +(*| Deprecated --> alert "deprecated" *) (* 3 *) + | Fragile_match of string (* 4 *) + | Ignored_partial_application (* 5 *) + | Labels_omitted of string list (* 6 *) + | Method_override of string list (* 7 *) + | Partial_match of string (* 8 *) + | Missing_record_field_pattern of string (* 9 *) + | Non_unit_statement (* 10 *) + | Redundant_case (* 11 *) + | Redundant_subpat (* 12 *) + | Instance_variable_override of string list (* 13 *) + | Illegal_backslash (* 14 *) + | Implicit_public_methods of string list (* 15 *) + | Unerasable_optional_argument (* 16 *) + | Undeclared_virtual_method of string (* 17 *) + | Not_principal of Format_doc.t (* 18 *) + | Non_principal_labels of string (* 19 *) + | Ignored_extra_argument (* 20 *) + | Nonreturning_statement (* 21 *) + | Preprocessor of string (* 22 *) + | Useless_record_with (* 23 *) + | Bad_module_name of string (* 24 *) + | All_clauses_guarded (* 8, used to be 25 *) + | Unused_var of string (* 26 *) + | Unused_var_strict of string (* 27 *) + | Wildcard_arg_to_constant_constr (* 28 *) + | Eol_in_string (* 29 *) + | Duplicate_definitions of string * string * string * string (*30 *) + (* [Module_linked_twice of string * string * string] (* 31 *) + was turned into a hard error *) + | Unused_value_declaration of string (* 32 *) + | Unused_open of string (* 33 *) + | Unused_type_declaration of string (* 34 *) + | Unused_for_index of string (* 35 *) + | Unused_ancestor of string (* 36 *) + | Unused_constructor of string * constructor_usage_warning (* 37 *) + | Unused_extension of string * bool * constructor_usage_warning (* 38 *) + | Unused_rec_flag (* 39 *) + | Name_out_of_scope of string * string list * bool (* 40 *) + | Ambiguous_name of string list * string list * bool * string (* 41 *) + | Disambiguated_name of string (* 42 *) + | Nonoptional_label of string (* 43 *) + | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) + | Bad_env_variable of string * string (* 46 *) + | Attribute_payload of string * string (* 47 *) + | Eliminated_optional_arguments of string list (* 48 *) + | No_cmi_file of string * string option (* 49 *) + | Unexpected_docstring of bool (* 50 *) + | Wrong_tailcall_expectation of bool (* 51 *) + | Fragile_literal_pattern (* 52 *) + | Misplaced_attribute of string (* 53 *) + | Duplicated_attribute of string (* 54 *) + | Inlining_impossible of string (* 55 *) + | Unreachable_case (* 56 *) + | Ambiguous_var_in_pattern_guard of string list (* 57 *) + | No_cmx_file of string (* 58 *) + | Flambda_assignment_to_non_mutable_value (* 59 *) + | Unused_module of string (* 60 *) + | Unboxable_type_in_prim_decl of string (* 61 *) + | Constraint_on_gadt (* 62 *) + | Erroneous_printed_signature of string (* 63 *) + | Unsafe_array_syntax_without_parsing (* 64 *) + | Redefining_unit of string (* 65 *) + | Unused_open_bang of string (* 66 *) + | Unused_functor_parameter of string (* 67 *) + | Match_on_mutable_state_prevent_uncurry (* 68 *) + | Unused_field of string * field_usage_warning (* 69 *) + | Missing_mli (* 70 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) + +(* If you remove a warning, leave a hole in the numbering. NEVER change + the numbers of existing warnings. + If you add a new warning, add it at the end with a new number; + do NOT reuse one of the holes. +*) + +type alert = {kind:string; message:string; def:loc; use:loc} + +let number = function + | Comment_start -> 1 + | Comment_not_end -> 2 + | Fragile_match _ -> 4 + | Ignored_partial_application -> 5 + | Labels_omitted _ -> 6 + | Method_override _ -> 7 + | Partial_match _ -> 8 + | Missing_record_field_pattern _ -> 9 + | Non_unit_statement -> 10 + | Redundant_case -> 11 + | Redundant_subpat -> 12 + | Instance_variable_override _ -> 13 + | Illegal_backslash -> 14 + | Implicit_public_methods _ -> 15 + | Unerasable_optional_argument -> 16 + | Undeclared_virtual_method _ -> 17 + | Not_principal _ -> 18 + | Non_principal_labels _ -> 19 + | Ignored_extra_argument -> 20 + | Nonreturning_statement -> 21 + | Preprocessor _ -> 22 + | Useless_record_with -> 23 + | Bad_module_name _ -> 24 + | All_clauses_guarded -> 8 (* used to be 25 *) + | Unused_var _ -> 26 + | Unused_var_strict _ -> 27 + | Wildcard_arg_to_constant_constr -> 28 + | Eol_in_string -> 29 + | Duplicate_definitions _ -> 30 + | Unused_value_declaration _ -> 32 + | Unused_open _ -> 33 + | Unused_type_declaration _ -> 34 + | Unused_for_index _ -> 35 + | Unused_ancestor _ -> 36 + | Unused_constructor _ -> 37 + | Unused_extension _ -> 38 + | Unused_rec_flag -> 39 + | Name_out_of_scope _ -> 40 + | Ambiguous_name _ -> 41 + | Disambiguated_name _ -> 42 + | Nonoptional_label _ -> 43 + | Open_shadow_identifier _ -> 44 + | Open_shadow_label_constructor _ -> 45 + | Bad_env_variable _ -> 46 + | Attribute_payload _ -> 47 + | Eliminated_optional_arguments _ -> 48 + | No_cmi_file _ -> 49 + | Unexpected_docstring _ -> 50 + | Wrong_tailcall_expectation _ -> 51 + | Fragile_literal_pattern -> 52 + | Misplaced_attribute _ -> 53 + | Duplicated_attribute _ -> 54 + | Inlining_impossible _ -> 55 + | Unreachable_case -> 56 + | Ambiguous_var_in_pattern_guard _ -> 57 + | No_cmx_file _ -> 58 + | Flambda_assignment_to_non_mutable_value -> 59 + | Unused_module _ -> 60 + | Unboxable_type_in_prim_decl _ -> 61 + | Constraint_on_gadt -> 62 + | Erroneous_printed_signature _ -> 63 + | Unsafe_array_syntax_without_parsing -> 64 + | Redefining_unit _ -> 65 + | Unused_open_bang _ -> 66 + | Unused_functor_parameter _ -> 67 + | Match_on_mutable_state_prevent_uncurry -> 68 + | Unused_field _ -> 69 + | Missing_mli -> 70 + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 + | Generative_application_expects_unit -> 73 + | Degraded_to_partial_match -> 74 +;; +(* DO NOT REMOVE the ;; above: it is used by + the testsuite/ests/warnings/mnemonics.mll test to determine where + the definition of the number function above ends *) + +let last_warning_number = 74 + +type description = + { number : int; + names : string list; + (* The first element of the list is the current name, any following ones are + deprecated. The current name should always be derived mechanically from + the constructor name. *) + description : string; + since : Sys.ocaml_release_info option; + (* The compiler version introducing this warning; only tagged for warnings + created after 3.12, which introduced the numbered syntax. *) + } + +let since major minor = Some { Sys.major; minor; patchlevel=0; extra=None } + +let descriptions = [ + { number = 1; + names = ["comment-start"]; + description = "Suspicious-looking start-of-comment mark."; + since = None }; + { number = 2; + names = ["comment-not-end"]; + description = "Suspicious-looking end-of-comment mark."; + since = None }; + { number = 3; + names = []; + description = "Deprecated synonym for the 'deprecated' alert."; + since = None }; + { number = 4; + names = ["fragile-match"]; + description = + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched."; + since = None }; + { number = 5; + names = ["ignored-partial-application"]; + description = + "Partially applied function: expression whose result has function\n\ + \ type and is ignored."; + since = None }; + { number = 6; + names = ["labels-omitted"]; + description = "Label omitted in function application."; + since = None }; + { number = 7; + names = ["method-override"]; + description = "Method overridden."; + since = None }; + { number = 8; + names = ["partial-match"]; + description = "Partial match: missing cases in pattern-matching."; + since = None }; + { number = 9; + names = ["missing-record-field-pattern"]; + description = "Missing fields in a record pattern."; + since = None }; + { number = 10; + names = ["non-unit-statement"]; + description = + "Expression on the left-hand side of a sequence that doesn't have type\n\ + \ \"unit\" (and that is not a function, see warning number 5)."; + since = None }; + { number = 11; + names = ["redundant-case"]; + description = + "Redundant case in a pattern matching (unused match case)."; + since = None }; + { number = 12; + names = ["redundant-subpat"]; + description = "Redundant sub-pattern in a pattern-matching." ; + since = None}; + { number = 13; + names = ["instance-variable-override"]; + description = "Instance variable overridden."; + since = None }; + { number = 14; + names = ["illegal-backslash"]; + description = "Illegal backslash escape in a string constant."; + since = None }; + { number = 15; + names = ["implicit-public-methods"]; + description = "Private method made public implicitly."; + since = None }; + { number = 16; + names = ["unerasable-optional-argument"]; + description = "Unerasable optional argument."; + since = None }; + { number = 17; + names = ["undeclared-virtual-method"]; + description = "Undeclared virtual method."; + since = None }; + { number = 18; + names = ["not-principal"]; + description = "Non-principal type."; + since = None }; + { number = 19; + names = ["non-principal-labels"]; + description = "Type without principality."; + since = None }; + { number = 20; + names = ["ignored-extra-argument"]; + description = "Unused function argument."; + since = None }; + { number = 21; + names = ["nonreturning-statement"]; + description = "Non-returning statement."; + since = None }; + { number = 22; + names = ["preprocessor"]; + description = "Preprocessor warning."; + since = None }; + { number = 23; + names = ["useless-record-with"]; + description = "Useless record \"with\" clause."; + since = None }; + { number = 24; + names = ["bad-module-name"]; + description = + "Bad module name: the source file name is not a valid OCaml module name."; + since = None }; + { number = 25; + names = []; + description = "Ignored: now part of warning 8."; + since = None }; + { number = 26; + names = ["unused-var"]; + description = + "Suspicious unused variable: unused variable that is bound\n\ + \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 27; + names = ["unused-var-strict"]; + description = + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 28; + names = ["wildcard-arg-to-constant-constr"]; + description = + "Wildcard pattern given as argument to a constant constructor."; + since = None }; + { number = 29; + names = ["eol-in-string"]; + description = + "Unescaped end-of-line in a string constant (non-portable code)."; + since = None }; + { number = 30; + names = ["duplicate-definitions"]; + description = + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types."; + since = None }; + { number = 31; + names = ["module-linked-twice"]; + description = + "A module is linked twice in the same executable.\n\ + \ Ignored: now a hard error (since 5.1)."; + since = None }; + { number = 32; + names = ["unused-value-declaration"]; + description = "Unused value declaration."; + since = since 4 0 }; + { number = 33; + names = ["unused-open"]; + description = "Unused open statement."; + since = since 4 0 }; + { number = 34; + names = ["unused-type-declaration"]; + description = "Unused type declaration."; + since = since 4 0 }; + { number = 35; + names = ["unused-for-index"]; + description = "Unused for-loop index."; + since = since 4 0 }; + { number = 36; + names = ["unused-ancestor"]; + description = "Unused ancestor variable."; + since = since 4 0 }; + { number = 37; + names = ["unused-constructor"]; + description = "Unused constructor."; + since = since 4 0 }; + { number = 38; + names = ["unused-extension"]; + description = "Unused extension constructor."; + since = since 4 0 }; + { number = 39; + names = ["unused-rec-flag"]; + description = "Unused rec flag."; + since = since 4 0 }; + { number = 40; + names = ["name-out-of-scope"]; + description = "Constructor or label name used out of scope."; + since = since 4 1 }; + { number = 41; + names = ["ambiguous-name"]; + description = "Ambiguous constructor or label name."; + since = since 4 1 }; + { number = 42; + names = ["disambiguated-name"]; + description = + "Disambiguated constructor or label name (compatibility warning)."; + since = since 4 1 }; + { number = 43; + names = ["nonoptional-label"]; + description = "Nonoptional label applied as optional."; + since = since 4 1 }; + { number = 44; + names = ["open-shadow-identifier"]; + description = "Open statement shadows an already defined identifier."; + since = since 4 1 }; + { number = 45; + names = ["open-shadow-label-constructor"]; + description = + "Open statement shadows an already defined label or constructor."; + since = since 4 1 }; + { number = 46; + names = ["bad-env-variable"]; + description = "Error in environment variable."; + since = since 4 1 }; + { number = 47; + names = ["attribute-payload"]; + description = "Illegal attribute payload."; + since = since 4 2 }; + { number = 48; + names = ["eliminated-optional-arguments"]; + description = "Implicit elimination of optional arguments."; + since = since 4 2 }; + { number = 49; + names = ["no-cmi-file"]; + description = "Absent cmi file when looking up module alias."; + since = since 4 2 }; + { number = 50; + names = ["unexpected-docstring"]; + description = "Unexpected documentation comment."; + since = since 4 3 }; + { number = 51; + names = ["wrong-tailcall-expectation"]; + description = + "Function call annotated with an incorrect @tailcall attribute."; + since = since 4 3 }; + { number = 52; + names = ["fragile-literal-pattern"]; + description = "Fragile constant pattern."; + since = since 4 3 }; + { number = 53; + names = ["misplaced-attribute"]; + description = "Attribute cannot appear in this context."; + since = since 4 3 }; + { number = 54; + names = ["duplicated-attribute"]; + description = "Attribute used more than once on an expression."; + since = since 4 3 }; + { number = 55; + names = ["inlining-impossible"]; + description = "Inlining impossible."; + since = since 4 3 }; + { number = 56; + names = ["unreachable-case"]; + description = + "Unreachable case in a pattern-matching (based on type information)."; + since = since 4 3 }; + { number = 57; + names = ["ambiguous-var-in-pattern-guard"]; + description = "Ambiguous or-pattern variables under guard."; + since = since 4 3 }; + { number = 58; + names = ["no-cmx-file"]; + description = "Missing cmx file."; + since = since 4 3 }; + { number = 59; + names = ["flambda-assignment-to-non-mutable-value"]; + description = "Assignment to non-mutable value."; + since = since 4 3 }; + { number = 60; + names = ["unused-module"]; + description = "Unused module declaration."; + since = since 4 4 }; + { number = 61; + names = ["unboxable-type-in-prim-decl"]; + description = "Unboxable type in primitive declaration."; + since = since 4 4 }; + { number = 62; + names = ["constraint-on-gadt"]; + description = "Type constraint on GADT type declaration."; + since = since 4 6 }; + { number = 63; + names = ["erroneous-printed-signature"]; + description = "Erroneous printed signature."; + since = since 4 8 }; + { number = 64; + names = ["unsafe-array-syntax-without-parsing"]; + description = + "-unsafe used with a preprocessor returning a syntax tree."; + since = since 4 8 }; + { number = 65; + names = ["redefining-unit"]; + description = "Type declaration defining a new '()' constructor."; + since = since 4 8 }; + { number = 66; + names = ["unused-open-bang"]; + description = "Unused open! statement."; + since = since 4 8 }; + { number = 67; + names = ["unused-functor-parameter"]; + description = "Unused functor parameter."; + since = since 4 10 }; + { number = 68; + names = ["match-on-mutable-state-prevent-uncurry"]; + description = + "Pattern-matching depending on mutable state prevents the remaining \n\ + \ arguments from being uncurried."; + since = since 4 12 }; + { number = 69; + names = ["unused-field"]; + description = "Unused record field."; + since = since 4 13 }; + { number = 70; + names = ["missing-mli"]; + description = "Missing interface file."; + since = since 4 13 }; + { number = 71; + names = ["unused-tmc-attribute"]; + description = "Unused @tail_mod_cons attribute."; + since = since 4 14 }; + { number = 72; + names = ["tmc-breaks-tailcall"]; + description = "A tail call is turned into a non-tail call \ + by the @tail_mod_cons transformation."; + since = since 4 14 }; + { number = 73; + names = ["generative-application-expects-unit"]; + description = "A generative functor is applied to an empty structure \ + (struct end) rather than to ()."; + since = since 5 1 }; + { number = 74; + names = ["degraded-to-partial-match"]; + description = "A pattern-matching is compiled as partial \ + even if it appears to be total."; + since = since 5 3 }; +] + +let name_to_number = + let h = Hashtbl.create last_warning_number in + List.iter (fun {number; names; _} -> + List.iter (fun name -> Hashtbl.add h name number) names + ) descriptions; + fun s -> Hashtbl.find_opt h s + +(* Must be the max number returned by the [number] function. *) + +let letter = function + | 'a' -> + let rec loop i = if i = 0 then [] else i :: loop (i - 1) in + loop last_warning_number + | 'b' -> [] + | 'c' -> [1; 2] + | 'd' -> [3] + | 'e' -> [4] + | 'f' -> [5] + | 'g' -> [] + | 'h' -> [] + | 'i' -> [] + | 'j' -> [] + | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39] + | 'l' -> [6] + | 'm' -> [7] + | 'n' -> [] + | 'o' -> [] + | 'p' -> [8] + | 'q' -> [] + | 'r' -> [9] + | 's' -> [10] + | 't' -> [] + | 'u' -> [11; 12] + | 'v' -> [13] + | 'w' -> [] + | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30] + | 'y' -> [26] + | 'z' -> [27] + | _ -> assert false + +type state = + { + active: bool array; + error: bool array; + alerts: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *) + alert_errors: (Misc.Stdlib.String.Set.t * bool); (* false:set complement *) + } + +let current = + ref + { + active = Array.make (last_warning_number + 1) true; + error = Array.make (last_warning_number + 1) false; + alerts = (Misc.Stdlib.String.Set.empty, false); + alert_errors = (Misc.Stdlib.String.Set.empty, true); (* all soft *) + } + +let disabled = ref false + +let without_warnings f = + Misc.protect_refs [Misc.R(disabled, true)] f + +let backup () = !current + +let restore x = current := x + +let is_active x = + not !disabled && (!current).active.(number x) + +let is_error x = + not !disabled && (!current).error.(number x) + +let alert_is_active {kind; _} = + not !disabled && + let (set, pos) = (!current).alerts in + Misc.Stdlib.String.Set.mem kind set = pos + +let alert_is_error {kind; _} = + not !disabled && + let (set, pos) = (!current).alert_errors in + Misc.Stdlib.String.Set.mem kind set = pos + +let with_state state f = + let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn + +let mk_lazy f = + let state = backup () in + lazy (with_state state f) + +let set_alert ~error ~enable s = + let upd = + match s with + | "all" -> + (Misc.Stdlib.String.Set.empty, not enable) + | s -> + let (set, pos) = + if error then (!current).alert_errors else (!current).alerts + in + let f = + if enable = pos + then Misc.Stdlib.String.Set.add + else Misc.Stdlib.String.Set.remove + in + (f s set, pos) + in + if error then + current := {(!current) with alert_errors=upd} + else + current := {(!current) with alerts=upd} + +let parse_alert_option s = + let n = String.length s in + let id_char = function + | 'a'..'z' | 'A'..'Z' | '_' | '\'' | '0'..'9' -> true + | _ -> false + in + let rec parse_id i = + if i < n && id_char s.[i] then parse_id (i + 1) else i + in + let rec scan i = + if i = n then () + else if i + 1 = n then raise (Arg.Bad "Ill-formed list of alert settings") + else match s.[i], s.[i+1] with + | '+', '+' -> id (set_alert ~error:true ~enable:true) (i + 2) + | '+', _ -> id (set_alert ~error:false ~enable:true) (i + 1) + | '-', '-' -> id (set_alert ~error:true ~enable:false) (i + 2) + | '-', _ -> id (set_alert ~error:false ~enable:false) (i + 1) + | '@', _ -> + id (fun s -> + set_alert ~error:true ~enable:true s; + set_alert ~error:false ~enable:true s) + (i + 1) + | _ -> raise (Arg.Bad "Ill-formed list of alert settings") + and id f i = + let j = parse_id i in + if j = i then raise (Arg.Bad "Ill-formed list of alert settings"); + let id = String.sub s i (j - i) in + f id; + scan j + in + scan 0 + +type modifier = + | Set (** +a *) + | Clear (** -a *) + | Set_all (** @a *) + +type token = + | Letter of char * modifier option + | Num of int * int * modifier + +let ghost_loc_in_file name = + let pos = { Lexing.dummy_pos with pos_fname = name } in + { loc_start = pos; loc_end = pos; loc_ghost = true } + +let letter_alert tokens = + let print_warning_char ppf c = + let lowercase = Char.lowercase_ascii c = c in + Format.fprintf ppf "%c%c" + (if lowercase then '-' else '+') c + in + let print_modifier ppf = function + | Set_all -> Format.fprintf ppf "@" + | Clear -> Format.fprintf ppf "-" + | Set -> Format.fprintf ppf "+" + in + let print_token ppf = function + | Num (a,b,m) -> if a = b then + Format.fprintf ppf "%a%d" print_modifier m a + else + Format.fprintf ppf "%a%d..%d" print_modifier m a b + | Letter(l,Some m) -> Format.fprintf ppf "%a%c" print_modifier m l + | Letter(l,None) -> print_warning_char ppf l + in + let consecutive_letters = + (* we are tracking sequences of 2 or more consecutive unsigned letters + in warning strings, for instance in '-w "not-principa"'. *) + let commit_chunk l = function + | [] | [ _ ] -> l + | _ :: _ :: _ as chunk -> List.rev chunk :: l + in + let group_consecutive_letters (l,current) = function + | Letter (x, None) -> (l, x::current) + | _ -> (commit_chunk l current, []) + in + let l, on_going = + List.fold_left group_consecutive_letters ([],[]) tokens + in + commit_chunk l on_going + in + match consecutive_letters with + | [] -> None + | example :: _ -> + let nowhere = ghost_loc_in_file "_none_" in + let spelling_hint ppf = + let max_seq_len = + List.fold_left (fun l x -> Int.max l (List.length x)) + 0 consecutive_letters + in + if max_seq_len >= 5 then + Format.fprintf ppf + "@ @[Hint: Did you make a spelling mistake \ + when using a mnemonic name?@]" + else + () + in + let message = + Format.asprintf + "@[@[Setting a warning with a sequence of lowercase \ + or uppercase letters,@ like '%a',@ is deprecated.@]@ \ + @[Use the equivalent signed form:@ %t.@]@ \ + @[Hint: Enabling or disabling a warning by its mnemonic name \ + requires a + or - prefix.@]\ + %t@?@]" + Format.(pp_print_list ~pp_sep:(fun _ -> ignore) pp_print_char) example + (fun ppf -> List.iter (print_token ppf) tokens) + spelling_hint + in + Some { + kind="ocaml_deprecated_cli"; + use=nowhere; def=nowhere; + message + } + + +let parse_warnings s = + let error () = raise (Arg.Bad "Ill-formed list of warnings") in + let rec get_num n i = + if i >= String.length s then i, n + else match s.[i] with + | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1) + | _ -> i, n + in + let get_range i = + let i, n1 = get_num 0 i in + if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then + let i, n2 = get_num 0 (i + 2) in + if n2 < n1 then error (); + i, n1, n2 + else + i, n1, n1 + in + let rec loop tokens i = + if i >= String.length s then List.rev tokens else + match s.[i] with + | 'A' .. 'Z' | 'a' .. 'z' -> + loop (Letter(s.[i],None)::tokens) (i+1) + | '+' -> loop_letter_num tokens Set (i+1) + | '-' -> loop_letter_num tokens Clear (i+1) + | '@' -> loop_letter_num tokens Set_all (i+1) + | _ -> error () + and loop_letter_num tokens modifier i = + if i >= String.length s then error () else + match s.[i] with + | '0' .. '9' -> + let i, n1, n2 = get_range i in + loop (Num(n1,n2,modifier)::tokens) i + | 'A' .. 'Z' | 'a' .. 'z' -> + loop (Letter(s.[i],Some modifier)::tokens) (i+1) + | _ -> error () + in + loop [] 0 + +let parse_opt error active errflag s = + let flags = if errflag then error else active in + let action modifier i = match modifier with + | Set -> + if i = 3 then set_alert ~error:errflag ~enable:true "deprecated" + else flags.(i) <- true + | Clear -> + if i = 3 then set_alert ~error:errflag ~enable:false "deprecated" + else flags.(i) <- false + | Set_all -> + if i = 3 then begin + set_alert ~error:false ~enable:true "deprecated"; + set_alert ~error:true ~enable:true "deprecated" + end + else begin + active.(i) <- true; + error.(i) <- true + end + in + let eval = function + | Letter(c, m) -> + let lc = Char.lowercase_ascii c in + let modifier = match m with + | None -> if c = lc then Clear else Set + | Some m -> m + in + List.iter (action modifier) (letter lc) + | Num(n1,n2,modifier) -> + for n = n1 to Int.min n2 last_warning_number do action modifier n done + in + let parse_and_eval s = + let tokens = parse_warnings s in + List.iter eval tokens; + letter_alert tokens + in + match name_to_number s with + | Some n -> action Set n; None + | None -> + if s = "" then parse_and_eval s + else begin + let rest = String.sub s 1 (String.length s - 1) in + match s.[0], name_to_number rest with + | '+', Some n -> action Set n; None + | '-', Some n -> action Clear n; None + | '@', Some n -> action Set_all n; None + | _ -> parse_and_eval s + end + +let parse_options errflag s = + let error = Array.copy (!current).error in + let active = Array.copy (!current).active in + let alerts = parse_opt error active errflag s in + current := {(!current) with error; active}; + alerts + +(* If you change these, don't forget to change them in man/ocamlc.m *) +let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70-74" +let defaults_warn_error = "-a" +let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] + +let () = ignore @@ parse_options false defaults_w +let () = ignore @@ parse_options true defaults_warn_error +let () = + List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts + +let message = function + | Comment_start -> + "this `(*' is the start of a comment.\n\ + Hint: Did you forget spaces when writing the infix operator `( * )'?" + | Comment_not_end -> "this is not the end of a comment." + | Fragile_match "" -> + "this pattern-matching is fragile." + | Fragile_match s -> + "this pattern-matching is fragile.\n\ + It will remain exhaustive when constructors are added to type " ^ s ^ "." + | Ignored_partial_application -> + "this function application is partial,\n\ + maybe some arguments are missing." + | Labels_omitted [] -> assert false + | Labels_omitted [l] -> + "label " ^ l ^ " was omitted in the application of this function." + | Labels_omitted ls -> + "labels " ^ String.concat ", " ls ^ + " were omitted in the application of this function." + | Method_override [lab] -> + "the method " ^ lab ^ " is overridden." + | Method_override (cname :: slist) -> + String.concat " " + ("the following methods are overridden by the class" + :: cname :: ":\n " :: slist) + | Method_override [] -> assert false + | Partial_match "" -> "this pattern-matching is not exhaustive." + | Partial_match s -> + "this pattern-matching is not exhaustive.\n\ + Here is an example of a case that is not matched:\n" ^ s + | Missing_record_field_pattern s -> + "the following labels are not bound in this record pattern:\n" ^ s ^ + "\nEither bind these labels explicitly or add '; _' to the pattern." + | Non_unit_statement -> + "this expression should have type unit." + | Redundant_case -> "this match case is unused." + | Redundant_subpat -> "this sub-pattern is unused." + | Instance_variable_override [lab] -> + "the instance variable " ^ lab ^ " is overridden." + | Instance_variable_override (cname :: slist) -> + String.concat " " + ("the following instance variables are overridden by the class" + :: cname :: ":\n " :: slist) + | Instance_variable_override [] -> assert false + | Illegal_backslash -> + "illegal backslash escape in string.\n\ + Hint: Single backslashes \\ are reserved for escape sequences\n\ + (\\n, \\r, ...). Did you check the list of OCaml escape sequences?\n\ + To get a backslash character, escape it with a second backslash: \\\\." + | Implicit_public_methods l -> + "the following private methods were made public implicitly:\n " + ^ String.concat " " l ^ "." + | Unerasable_optional_argument -> "this optional argument cannot be erased." + | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared." + | Not_principal msg -> + Format_doc.asprintf "%a is not principal." + Format_doc.pp_doc msg + | Non_principal_labels s -> s^" without principality." + | Ignored_extra_argument -> "this argument will not be used by the function." + | Nonreturning_statement -> + "this statement never returns (or has an unsound type.)" + | Preprocessor s -> s + | Useless_record_with -> + "all the fields are explicitly listed in this record:\n\ + the 'with' clause is useless." + | Bad_module_name (modname) -> + "bad source file name: \"" ^ modname ^ "\" is not a valid module name." + | All_clauses_guarded -> + "this pattern-matching is not exhaustive.\n\ + All clauses in this pattern-matching are guarded." + | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "." + | Wildcard_arg_to_constant_constr -> + "wildcard pattern given as argument to a constant constructor" + | Eol_in_string -> + "unescaped end-of-line in a string constant\n\ + (non-portable behavior before OCaml 5.2)" + | Duplicate_definitions (kind, cname, tc1, tc2) -> + Printf.sprintf "the %s %s is defined in both types %s and %s." + kind cname tc1 tc2 + | Unused_value_declaration v -> "unused value " ^ v ^ "." + | Unused_open s -> "unused open " ^ s ^ "." + | Unused_open_bang s -> "unused open! " ^ s ^ "." + | Unused_type_declaration s -> "unused type " ^ s ^ "." + | Unused_for_index s -> "unused for-loop index " ^ s ^ "." + | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "." + | Unused_constructor (s, Unused) -> "unused constructor " ^ s ^ "." + | Unused_constructor (s, Not_constructed) -> + "constructor " ^ s ^ + " is never used to build values.\n\ + (However, this constructor appears in patterns.)" + | Unused_constructor (s, Only_exported_private) -> + "constructor " ^ s ^ + " is never used to build values.\n\ + Its type is exported as a private type." + | Unused_extension (s, is_exception, complaint) -> + let kind = + if is_exception then "exception" else "extension constructor" in + let name = kind ^ " " ^ s in + begin match complaint with + | Unused -> "unused " ^ name + | Not_constructed -> + name ^ + " is never used to build values.\n\ + (However, this constructor appears in patterns.)" + | Only_exported_private -> + name ^ + " is never used to build values.\n\ + It is exported or rebound as a private extension." + end + | Unused_rec_flag -> + "unused rec flag." + | Name_out_of_scope (ty, [nm], false) -> + nm ^ " was selected from type " ^ ty ^ + ".\nIt is not visible in the current scope, and will not \n\ + be selected if the type becomes unknown." + | Name_out_of_scope (_, _, false) -> assert false + | Name_out_of_scope (ty, slist, true) -> + "this record of type "^ ty ^" contains fields that are \n\ + not visible in the current scope: " + ^ String.concat " " slist ^ ".\n\ + They will not be selected if the type becomes unknown." + | Ambiguous_name ([s], tl, false, expansion) -> + s ^ " belongs to several types: " ^ String.concat " " tl ^ + "\nThe first one was selected. Please disambiguate if this is wrong." + ^ expansion + | Ambiguous_name (_, _, false, _ ) -> assert false + | Ambiguous_name (_slist, tl, true, expansion) -> + "these field labels belong to several types: " ^ + String.concat " " tl ^ + "\nThe first one was selected. Please disambiguate if this is wrong." + ^ expansion + | Disambiguated_name s -> + "this use of " ^ s ^ " relies on type-directed disambiguation,\n\ + it will not compile with OCaml 4.00 or earlier." + | Nonoptional_label s -> + "the label " ^ s ^ " is not optional." + | Open_shadow_identifier (kind, s) -> + Printf.sprintf + "this open statement shadows the %s identifier %s (which is later used)" + kind s + | Open_shadow_label_constructor (kind, s) -> + Printf.sprintf + "this open statement shadows the %s %s (which is later used)" + kind s + | Bad_env_variable (var, s) -> + Printf.sprintf "illegal environment variable %s : %s" var s + | Attribute_payload (a, s) -> + Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s + | Eliminated_optional_arguments sl -> + Printf.sprintf "implicit elimination of optional argument%s %s" + (if List.length sl = 1 then "" else "s") + (String.concat ", " sl) + | No_cmi_file(name, None) -> + "no cmi file was found in path for module " ^ name + | No_cmi_file(name, Some msg) -> + Printf.sprintf + "no valid cmi file was found in path for module %s. %s" + name msg + | Unexpected_docstring unattached -> + if unattached then "unattached documentation comment (ignored)" + else "ambiguous documentation comment" + | Wrong_tailcall_expectation b -> + Printf.sprintf "expected %s" + (if b then "tailcall" else "non-tailcall") + | Fragile_literal_pattern -> + let[@manual.ref "ss:warn52"] ref_manual = [ 13; 5; 3 ] in + Format.asprintf + "Code should not depend on the actual values of\n\ + this constructor's arguments. They are only for information\n\ + and may change in future versions. %a" + (Format_doc.compat Misc.print_see_manual) ref_manual + | Unreachable_case -> + "this match case is unreachable.\n\ + Consider replacing it with a refutation case ' -> .'" + | Misplaced_attribute attr_name -> + Printf.sprintf "the %S attribute cannot appear in this context" attr_name + | Duplicated_attribute attr_name -> + Printf.sprintf "the %S attribute is used more than once on this \ + expression" + attr_name + | Inlining_impossible reason -> + Printf.sprintf "Cannot inline: %s" reason + | Ambiguous_var_in_pattern_guard vars -> + let[@manual.ref "ss:warn57"] ref_manual = [ 13; 5; 4 ] in + let vars = List.sort String.compare vars in + let vars_explanation = + let in_different_places = + "in different places in different or-pattern alternatives" + in + match vars with + | [] -> assert false + | [x] -> "variable " ^ x ^ " appears " ^ in_different_places + | _::_ -> + let vars = String.concat ", " vars in + "variables " ^ vars ^ " appear " ^ in_different_places + in + Format.asprintf + "Ambiguous or-pattern variables under guard;\n\ + %s.\n\ + Only the first match will be used to evaluate the guard expression.\n\ + %a" + vars_explanation (Format_doc.compat Misc.print_see_manual) ref_manual + | No_cmx_file name -> + Printf.sprintf + "no cmx file was found in path for module %s, \ + and its interface was not compiled with -opaque" name + | Flambda_assignment_to_non_mutable_value -> + "A potential assignment to a non-mutable value was detected \n\ + in this source file. Such assignments may generate incorrect code \n\ + when using Flambda." + | Unused_module s -> "unused module " ^ s ^ "." + | Unboxable_type_in_prim_decl t -> + Printf.sprintf + "This primitive declaration uses type %s, whose representation\n\ + may be either boxed or unboxed. Without an annotation to indicate\n\ + which representation is intended, the boxed representation has been\n\ + selected by default. This default choice may change in future\n\ + versions of the compiler, breaking the primitive implementation.\n\ + You should explicitly annotate the declaration of %s\n\ + with [@@boxed] or [@@unboxed], so that its external interface\n\ + remains stable in the future." t t + | Constraint_on_gadt -> + "Type constraints do not apply to GADT cases of variant types." + | Erroneous_printed_signature s -> + "The printed interface differs from the inferred interface.\n\ + The inferred interface contained items which could not be printed\n\ + properly due to name collisions between identifiers.\n" + ^ s + ^ "\nBeware that this warning is purely informational and will not catch\n\ + all instances of erroneous printed interface." + | Unsafe_array_syntax_without_parsing -> + "option -unsafe used with a preprocessor returning a syntax tree" + | Redefining_unit name -> + Printf.sprintf + "This type declaration is defining a new '()' constructor\n\ + which shadows the existing one.\n\ + Hint: Did you mean 'type %s = unit'?" name + | Unused_functor_parameter s -> "unused functor parameter " ^ s ^ "." + | Match_on_mutable_state_prevent_uncurry -> + "This pattern depends on mutable state.\n\ + It prevents the remaining arguments from being uncurried, which will \ + cause additional closure allocations." + | Unused_field (s, Unused) -> "unused record field " ^ s ^ "." + | Unused_field (s, Not_read) -> + "record field " ^ s ^ + " is never read.\n\ + (However, this field is used to build or mutate values.)" + | Unused_field (s, Not_mutated) -> + "mutable record field " ^ s ^ + " is never mutated." + | Missing_mli -> + "Cannot find interface file." + | Unused_tmc_attribute -> + "This function is marked @tail_mod_cons\n\ + but is never applied in TMC position." + | Tmc_breaks_tailcall -> + "This call\n\ + is in tail-modulo-cons position in a TMC function,\n\ + but the function called is not itself specialized for TMC,\n\ + so the call will not be transformed into a tail call.\n\ + Please either mark the called function with the [@tail_mod_cons]\n\ + attribute, or mark this call with the [@tailcall false] attribute\n\ + to make its non-tailness explicit." + | Generative_application_expects_unit -> + "A generative functor\n\ + should be applied to '()'; using '(struct end)' is deprecated." + | Degraded_to_partial_match -> + let[@manual.ref "ss:warn74"] ref_manual = [ 13; 5; 5 ] in + Format.asprintf + "This pattern-matching is compiled \n\ + as partial, even if it appears to be total. \ + It may generate a Match_failure\n\ + exception. This typically occurs due to \ + complex matches on mutable fields.\n\ + %a" + (Format_doc.compat Misc.print_see_manual) ref_manual +;; + +let nerrors = ref 0 + +type reporting_information = + { id : string + ; message : string + ; is_error : bool + ; sub_locs : (loc * string) list; + } + +let id_name w = + let n = number w in + match List.find_opt (fun {number; _} -> number = n) descriptions with + | Some {names = s :: _; _} -> + Printf.sprintf "%d [%s]" n s + | _ -> + string_of_int n + +let report w = + match is_active w with + | false -> `Inactive + | true -> + if is_error w then incr nerrors; + `Active + { id = id_name w; + message = message w; + is_error = is_error w; + sub_locs = []; + } + +let report_alert (alert : alert) = + match alert_is_active alert with + | false -> `Inactive + | true -> + let is_error = alert_is_error alert in + if is_error then incr nerrors; + let message = Misc.normalise_eol alert.message in + (* Reduce \r\n to \n: + - Prevents any \r characters being printed on Unix when processing + Windows sources + - Prevents \r\r\n being generated on Windows, which affects the + testsuite + *) + let sub_locs = + if not alert.def.loc_ghost && not alert.use.loc_ghost then + [ + alert.def, "Definition"; + alert.use, "Expected signature"; + ] + else + [] + in + `Active + { + id = alert.kind; + message; + is_error; + sub_locs; + } + +exception Errors + +let reset_fatal () = + nerrors := 0 + +let check_fatal () = + if !nerrors > 0 then begin + nerrors := 0; + raise Errors; + end + +let pp_since out release_info = + Printf.fprintf out " (since %d.%0*d)" + release_info.Sys.major + (if release_info.Sys.major >= 5 then 0 else 2) + release_info.Sys.minor + +let help_warnings () = + List.iter + (fun {number; description; names; since} -> + let name = + match names with + | s :: _ -> " [" ^ s ^ "]" + | [] -> "" + in + Printf.printf "%3i%s %s%a\n" + number name description (fun out -> Option.iter (pp_since out)) since) + descriptions; + print_endline " A all warnings"; + for i = Char.code 'b' to Char.code 'z' do + let c = Char.chr i in + match letter c with + | [] -> () + | [n] -> + Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n + | l -> + Printf.printf " %c warnings %s.\n" + (Char.uppercase_ascii c) + (String.concat ", " (List.map Int.to_string l)) + done; + exit 0 diff --git a/upstream/ocaml_503/utils/warnings.mli b/upstream/ocaml_503/utils/warnings.mli new file mode 100644 index 000000000..1da12c15f --- /dev/null +++ b/upstream/ocaml_503/utils/warnings.mli @@ -0,0 +1,171 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Warning definitions + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +val ghost_loc_in_file : string -> loc +(** Return an empty ghost range located in a given file *) + +type field_usage_warning = + | Unused + | Not_read + | Not_mutated + +type constructor_usage_warning = + | Unused + | Not_constructed + | Only_exported_private + +type t = + | Comment_start (* 1 *) + | Comment_not_end (* 2 *) +(*| Deprecated --> alert "deprecated" *) (* 3 *) + | Fragile_match of string (* 4 *) + | Ignored_partial_application (* 5 *) + | Labels_omitted of string list (* 6 *) + | Method_override of string list (* 7 *) + | Partial_match of string (* 8 *) + | Missing_record_field_pattern of string (* 9 *) + | Non_unit_statement (* 10 *) + | Redundant_case (* 11 *) + | Redundant_subpat (* 12 *) + | Instance_variable_override of string list (* 13 *) + | Illegal_backslash (* 14 *) + | Implicit_public_methods of string list (* 15 *) + | Unerasable_optional_argument (* 16 *) + | Undeclared_virtual_method of string (* 17 *) + | Not_principal of Format_doc.t (* 18 *) + | Non_principal_labels of string (* 19 *) + | Ignored_extra_argument (* 20 *) + | Nonreturning_statement (* 21 *) + | Preprocessor of string (* 22 *) + | Useless_record_with (* 23 *) + | Bad_module_name of string (* 24 *) + | All_clauses_guarded (* 8, used to be 25 *) + | Unused_var of string (* 26 *) + | Unused_var_strict of string (* 27 *) + | Wildcard_arg_to_constant_constr (* 28 *) + | Eol_in_string (* 29 + Note: since OCaml 5.2, the lexer normalizes \r\n sequences in + the source file to a single \n character, so the behavior of + newlines in string literals is portable. This warning is + never emitted anymore. *) + | Duplicate_definitions of string * string * string * string (* 30 *) + | Unused_value_declaration of string (* 32 *) + | Unused_open of string (* 33 *) + | Unused_type_declaration of string (* 34 *) + | Unused_for_index of string (* 35 *) + | Unused_ancestor of string (* 36 *) + | Unused_constructor of string * constructor_usage_warning (* 37 *) + | Unused_extension of string * bool * constructor_usage_warning (* 38 *) + | Unused_rec_flag (* 39 *) + | Name_out_of_scope of string * string list * bool (* 40 *) + | Ambiguous_name of string list * string list * bool * string (* 41 *) + | Disambiguated_name of string (* 42 *) + | Nonoptional_label of string (* 43 *) + | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) + | Bad_env_variable of string * string (* 46 *) + | Attribute_payload of string * string (* 47 *) + | Eliminated_optional_arguments of string list (* 48 *) + | No_cmi_file of string * string option (* 49 *) + | Unexpected_docstring of bool (* 50 *) + | Wrong_tailcall_expectation of bool (* 51 *) + | Fragile_literal_pattern (* 52 *) + | Misplaced_attribute of string (* 53 *) + | Duplicated_attribute of string (* 54 *) + | Inlining_impossible of string (* 55 *) + | Unreachable_case (* 56 *) + | Ambiguous_var_in_pattern_guard of string list (* 57 *) + | No_cmx_file of string (* 58 *) + | Flambda_assignment_to_non_mutable_value (* 59 *) + | Unused_module of string (* 60 *) + | Unboxable_type_in_prim_decl of string (* 61 *) + | Constraint_on_gadt (* 62 *) + | Erroneous_printed_signature of string (* 63 *) + | Unsafe_array_syntax_without_parsing (* 64 *) + | Redefining_unit of string (* 65 *) + | Unused_open_bang of string (* 66 *) + | Unused_functor_parameter of string (* 67 *) + | Match_on_mutable_state_prevent_uncurry (* 68 *) + | Unused_field of string * field_usage_warning (* 69 *) + | Missing_mli (* 70 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) + +type alert = {kind:string; message:string; def:loc; use:loc} + +val parse_options : bool -> string -> alert option + +val parse_alert_option: string -> unit + (** Disable/enable alerts based on the parameter to the -alert + command-line option. Raises [Arg.Bad] if the string is not a + valid specification. + *) + +val without_warnings : (unit -> 'a) -> 'a + (** Run the thunk with all warnings and alerts disabled. *) + +val is_active : t -> bool +val is_error : t -> bool + +val defaults_w : string +val defaults_warn_error : string + +type reporting_information = + { id : string + ; message : string + ; is_error : bool + ; sub_locs : (loc * string) list; + } + +val report : t -> [ `Active of reporting_information | `Inactive ] +val report_alert : alert -> [ `Active of reporting_information | `Inactive ] + +exception Errors + +val check_fatal : unit -> unit +val reset_fatal: unit -> unit + +val help_warnings: unit -> unit + +type state +val backup: unit -> state +val restore: state -> unit +val with_state : state -> (unit -> 'a) -> 'a +val mk_lazy: (unit -> 'a) -> 'a Lazy.t + (** Like [Lazy.of_fun], but the function is applied with + the warning/alert settings at the time [mk_lazy] is called. *) + +type description = + { number : int; + names : string list; + description : string; + since : Sys.ocaml_release_info option; } + +val descriptions : description list From d0821cc90ae3b3fb1e5122b1571243ab050d7711 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 17 Sep 2024 01:21:22 +0200 Subject: [PATCH 03/36] Upgrade `gen_patch` (migration script) --- upstream/gen_patch.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/upstream/gen_patch.sh b/upstream/gen_patch.sh index 3fa724dfd..6a980fb9a 100644 --- a/upstream/gen_patch.sh +++ b/upstream/gen_patch.sh @@ -2,8 +2,8 @@ D_MERLIN=../src/ocaml -FROM=501 -TO=502 +FROM=502 +TO=503 D_FROM=ocaml_${FROM} D_TO=ocaml_${TO} From df1c22a9df4d0a7b6083be69e336ac4eb3758edd Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 17 Sep 2024 01:49:48 +0200 Subject: [PATCH 04/36] Be more smart on patch application --- upstream/gen_patch.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/upstream/gen_patch.sh b/upstream/gen_patch.sh index 6a980fb9a..139ac7c8e 100644 --- a/upstream/gen_patch.sh +++ b/upstream/gen_patch.sh @@ -21,7 +21,7 @@ for file in "${D_TO}"/*/*.ml*; do diff -u -N "${F_FROM}" "${F_TO}" >"${F_PATCH}.patch" if [ -s "${F_PATCH}.patch" ]; then # Apply the patch file - patch "${F_MERLIN}" "${F_PATCH}.patch" + patch --no-backup-if-mismatch --merge "${F_MERLIN}" "${F_PATCH}.patch" echo "patched ${F_MERLIN}" else rm "${F_PATCH}.patch" From a68460ca6ac33d2d874b8b4f1492098614428648 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 17 Sep 2024 02:00:20 +0200 Subject: [PATCH 05/36] Apply valid patches --- src/ocaml/parsing/ast_helper.ml | 23 +- src/ocaml/parsing/ast_helper.mli | 16 +- src/ocaml/parsing/ast_iterator.ml | 1 + src/ocaml/parsing/ast_mapper.ml | 33 +- src/ocaml/parsing/asttypes.mli | 2 + src/ocaml/parsing/attr_helper.ml | 8 +- src/ocaml/parsing/attr_helper.mli | 3 +- src/ocaml/parsing/builtin_attributes.ml | 80 +- src/ocaml/parsing/builtin_attributes.mli | 9 +- src/ocaml/parsing/docstrings.ml | 6 +- src/ocaml/parsing/location.ml | 185 ++- src/ocaml/parsing/location.mli | 51 +- src/ocaml/parsing/parsetree.mli | 8 +- src/ocaml/parsing/pprintast.ml | 126 +- src/ocaml/parsing/pprintast.mli | 12 + src/ocaml/parsing/printast.ml | 31 +- src/ocaml/parsing/unit_info.ml | 59 +- src/ocaml/parsing/unit_info.mli | 32 +- src/ocaml/typing/btype.ml | 165 ++- src/ocaml/typing/btype.mli | 123 +- src/ocaml/typing/ctype.ml | 914 ++++++++------- src/ocaml/typing/ctype.mli | 33 +- src/ocaml/typing/datarepr.ml | 37 +- src/ocaml/typing/datarepr.mli | 4 +- src/ocaml/typing/env.ml | 168 +-- src/ocaml/typing/env.mli | 21 +- src/ocaml/typing/envaux.ml | 10 +- src/ocaml/typing/envaux.mli | 5 +- src/ocaml/typing/errortrace.ml | 12 +- src/ocaml/typing/errortrace.mli | 9 +- src/ocaml/typing/ident.ml | 28 +- src/ocaml/typing/ident.mli | 7 +- src/ocaml/typing/includeclass.ml | 40 +- src/ocaml/typing/includeclass.mli | 5 +- src/ocaml/typing/includecore.ml | 175 +-- src/ocaml/typing/includecore.mli | 21 +- src/ocaml/typing/includemod.ml | 302 +++-- src/ocaml/typing/includemod.mli | 4 + src/ocaml/typing/includemod_errorprinter.ml | 378 +++--- src/ocaml/typing/includemod_errorprinter.mli | 4 +- src/ocaml/typing/mtype.ml | 20 +- src/ocaml/typing/oprint.ml | 53 +- src/ocaml/typing/oprint.mli | 32 +- src/ocaml/typing/outcometree.mli | 10 +- src/ocaml/typing/parmatch.ml | 53 +- src/ocaml/typing/parmatch.mli | 4 +- src/ocaml/typing/path.ml | 4 +- src/ocaml/typing/path.mli | 2 +- src/ocaml/typing/persistent_env.ml | 33 +- src/ocaml/typing/persistent_env.mli | 3 +- src/ocaml/typing/predef.ml | 38 + src/ocaml/typing/predef.mli | 4 + src/ocaml/typing/primitive.ml | 6 +- src/ocaml/typing/printpat.ml | 30 +- src/ocaml/typing/printpat.mli | 15 +- src/ocaml/typing/printtyp.ml | 169 ++- src/ocaml/typing/printtyp.mli | 110 +- src/ocaml/typing/printtyped.ml | 13 +- src/ocaml/typing/shape.ml | 17 +- src/ocaml/typing/shape.mli | 8 +- src/ocaml/typing/stypes.ml | 8 +- src/ocaml/typing/tast_iterator.ml | 10 +- src/ocaml/typing/tast_mapper.ml | 11 +- src/ocaml/typing/typeclass.ml | 200 ++-- src/ocaml/typing/typeclass.mli | 7 +- src/ocaml/typing/typecore.ml | 1093 +++++++++++------- src/ocaml/typing/typecore.mli | 20 +- src/ocaml/typing/typedecl.ml | 214 ++-- src/ocaml/typing/typedecl.mli | 5 +- src/ocaml/typing/typedtree.ml | 11 +- src/ocaml/typing/typedtree.mli | 17 +- src/ocaml/typing/typemod.ml | 168 +-- src/ocaml/typing/typemod.mli | 3 +- src/ocaml/typing/typeopt.ml | 2 +- src/ocaml/typing/types.ml | 83 +- src/ocaml/typing/types.mli | 35 +- src/ocaml/typing/typetexp.ml | 93 +- src/ocaml/typing/typetexp.mli | 3 +- src/ocaml/typing/untypeast.ml | 44 +- src/ocaml/typing/value_rec_check.ml | 15 +- src/ocaml/utils/clflags.ml | 243 ++++ src/ocaml/utils/clflags.mli | 64 + src/ocaml/utils/config.mli | 20 + src/ocaml/utils/diffing.ml | 24 +- src/ocaml/utils/diffing.mli | 2 +- src/ocaml/utils/diffing_with_keys.ml | 6 +- src/ocaml/utils/diffing_with_keys.mli | 2 +- src/ocaml/utils/load_path.ml | 36 +- src/ocaml/utils/local_store.mli | 3 +- src/ocaml/utils/warnings.ml | 33 +- src/ocaml/utils/warnings.mli | 3 +- 91 files changed, 4015 insertions(+), 2237 deletions(-) diff --git a/src/ocaml/parsing/ast_helper.ml b/src/ocaml/parsing/ast_helper.ml index 5e093022b..f3d154c09 100644 --- a/src/ocaml/parsing/ast_helper.ml +++ b/src/ocaml/parsing/ast_helper.ml @@ -36,15 +36,20 @@ let with_default_loc l f = Misc.protect_refs [Misc.R (default_loc, l)] f module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c + let mk ?(loc = !default_loc) d = + {pconst_desc = d; + pconst_loc = loc} + + let integer ?loc ?suffix i = mk ?loc (Pconst_integer (i, suffix)) + let int ?loc ?suffix i = integer ?loc ?suffix (Int.to_string i) + let int32 ?loc ?(suffix='l') i = integer ?loc ~suffix (Int32.to_string i) + let int64 ?loc ?(suffix='L') i = integer ?loc ~suffix (Int64.to_string i) + let nativeint ?loc ?(suffix='n') i = + integer ?loc ~suffix (Nativeint.to_string i) + let float ?loc ?suffix f = mk ?loc (Pconst_float (f, suffix)) + let char ?loc c = mk ?loc (Pconst_char c) let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) + mk ~loc (Pconst_string (s, loc, quotation_delimiter)) end module Attr = struct @@ -172,6 +177,7 @@ module Pat = struct let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) + let effect_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_effect(a, b)) let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) end @@ -619,7 +625,6 @@ module Te = struct pext_loc = loc; pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - end module Csig = struct diff --git a/src/ocaml/parsing/ast_helper.mli b/src/ocaml/parsing/ast_helper.mli index 70f59e5b9..afca340e0 100644 --- a/src/ocaml/parsing/ast_helper.mli +++ b/src/ocaml/parsing/ast_helper.mli @@ -46,15 +46,16 @@ val with_default_loc: loc -> (unit -> 'a) -> 'a (** {1 Constants} *) module Const : sig - val char : char -> constant + val mk : ?loc:loc -> constant_desc -> constant + val char : ?loc:loc -> char -> constant val string : ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant + val integer : ?loc:loc -> ?suffix:char -> string -> constant + val int : ?loc:loc -> ?suffix:char -> int -> constant + val int32 : ?loc:loc -> ?suffix:char -> int32 -> constant + val int64 : ?loc:loc -> ?suffix:char -> int64 -> constant + val nativeint : ?loc:loc -> ?suffix:char -> nativeint -> constant + val float : ?loc:loc -> ?suffix:char -> string -> constant end (** {1 Attributes} *) @@ -128,6 +129,7 @@ module Pat: val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern + val effect_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern end diff --git a/src/ocaml/parsing/ast_iterator.ml b/src/ocaml/parsing/ast_iterator.ml index 94d5806fb..389a9a404 100644 --- a/src/ocaml/parsing/ast_iterator.ml +++ b/src/ocaml/parsing/ast_iterator.ml @@ -493,6 +493,7 @@ module P = struct | Ppat_type s -> iter_loc sub s | Ppat_lazy p -> sub.pat sub p | Ppat_unpack s -> iter_loc sub s + | Ppat_effect (p1,p2) -> sub.pat sub p1; sub.pat sub p2 | Ppat_exception p -> sub.pat sub p | Ppat_extension x -> sub.extension sub x | Ppat_open (lid, p) -> diff --git a/src/ocaml/parsing/ast_mapper.ml b/src/ocaml/parsing/ast_mapper.ml index e3997095a..66e244e0e 100644 --- a/src/ocaml/parsing/ast_mapper.ml +++ b/src/ocaml/parsing/ast_mapper.ml @@ -95,14 +95,18 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} module C = struct (* Constants *) - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s + let map sub { pconst_desc; pconst_loc } = + let loc = sub.location sub pconst_loc in + let desc = + match pconst_desc with + | Pconst_integer _ + | Pconst_char _ + | Pconst_float _ -> + pconst_desc + | Pconst_string (s, loc, quotation_delimiter) -> + Pconst_string (s, sub.location sub loc, quotation_delimiter) + in + Const.mk ~loc desc end module T = struct @@ -549,6 +553,8 @@ module P = struct | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) + | Ppat_effect(p1, p2) -> + effect_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) end @@ -828,21 +834,21 @@ let default_mapper = let extension_of_error {kind; main; sub} = if kind <> Location.Report_error then raise (Invalid_argument "extension_of_error: expected kind Report_error"); - let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in + let str_of_msg msg = Format.asprintf "%a" Format_doc.Doc.format msg in let extension_of_sub sub = { loc = sub.loc; txt = "ocaml.error" }, PStr ([Str.eval (Exp.constant - (Pconst_string (str_of_pp sub.txt, sub.loc, None)))]) + (Const.string ~loc:sub.loc (str_of_msg sub.txt)))]) in { loc = main.loc; txt = "ocaml.error" }, PStr (Str.eval (Exp.constant - (Pconst_string (str_of_pp main.txt, main.loc, None))) :: + (Const.string ~loc:main.loc (str_of_msg main.txt))) :: List.map (fun msg -> Str.extension (extension_of_sub msg)) sub) let attribute_of_warning loc s = Attr.mk {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) + (PStr ([Str.eval ~loc (Exp.constant (Const.string ~loc s))])) let cookies = ref String.Map.empty @@ -935,7 +941,8 @@ module PpxContext = struct let restore fields = let field name payload = let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str + | {pexp_desc = Pexp_constant + {pconst_desc = Pconst_string (str, _, None); _}} -> str | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ { %s }] string syntax" name and get_bool pexp = diff --git a/src/ocaml/parsing/asttypes.mli b/src/ocaml/parsing/asttypes.mli index 7a4f1c191..e3cf5ae4e 100644 --- a/src/ocaml/parsing/asttypes.mli +++ b/src/ocaml/parsing/asttypes.mli @@ -65,3 +65,5 @@ type variance = type injectivity = | Injective | NoInjectivity + +val string_of_label: arg_label -> string diff --git a/src/ocaml/parsing/attr_helper.ml b/src/ocaml/parsing/attr_helper.ml index 390124199..f531cf95b 100644 --- a/src/ocaml/parsing/attr_helper.ml +++ b/src/ocaml/parsing/attr_helper.ml @@ -39,9 +39,9 @@ let has_no_payload_attribute alt_names attrs = | None -> false | Some _ -> true -open Format +open Format_doc -let report_error ppf = function +let report_error_doc ppf = function | Multiple_attributes name -> fprintf ppf "Too many %a attributes" Style.inline_code name | No_payload_expected name -> @@ -51,7 +51,9 @@ let () = Location.register_error_of_exn (function | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) + Some (Location.error_of_printer ~loc report_error_doc err) | _ -> None ) + +let report_error = Format_doc.compat report_error_doc diff --git a/src/ocaml/parsing/attr_helper.mli b/src/ocaml/parsing/attr_helper.mli index a94042a29..2782cba80 100644 --- a/src/ocaml/parsing/attr_helper.mli +++ b/src/ocaml/parsing/attr_helper.mli @@ -35,4 +35,5 @@ val has_no_payload_attribute : string -> attributes -> bool exception Error of Location.t * error -val report_error: Format.formatter -> error -> unit +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer diff --git a/src/ocaml/parsing/builtin_attributes.ml b/src/ocaml/parsing/builtin_attributes.ml index 6add5ac37..35a2a549e 100644 --- a/src/ocaml/parsing/builtin_attributes.ml +++ b/src/ocaml/parsing/builtin_attributes.ml @@ -36,12 +36,22 @@ let attr_order a1 a2 = | 0 -> Int.compare a1.loc.loc_start.pos_cnum a2.loc.loc_start.pos_cnum | n -> n +let compiler_stops_before_attributes_consumed () = + let stops_before_lambda = + match !Clflags.stop_after with + | None -> false + | Some pass -> Clflags.Compiler_pass.(compare pass Lambda) < 0 + in + stops_before_lambda || !Clflags.print_types + let warn_unused () = let keys = List.of_seq (Attribute_table.to_seq_keys unused_attrs) in - let keys = List.sort attr_order keys in - List.iter (fun sloc -> - Location.prerr_warning sloc.loc (Warnings.Misplaced_attribute sloc.txt)) - keys + Attribute_table.clear unused_attrs; + if not (compiler_stops_before_attributes_consumed ()) then + let keys = List.sort attr_order keys in + List.iter (fun sloc -> + Location.prerr_warning sloc.loc (Warnings.Misplaced_attribute sloc.txt)) + keys (* These are the attributes that are tracked in the builtin_attrs table for misplaced attribute warnings. *) @@ -93,8 +103,13 @@ let register_attr current_phase name = if is_builtin_attr name.txt then Attribute_table.replace unused_attrs name () +<<<<<<< let string_of_cst = function +======= +let string_of_cst const = + match const.pconst_desc with +>>>>>>> | Pconst_string(s, _, _) -> Some s | _ -> None @@ -108,37 +123,39 @@ let string_of_opt_payload p = | Some s -> s | None -> "" +module Style = Misc.Style let error_of_extension ext = let submessage_from main_loc main_txt = function | {pstr_desc=Pstr_extension (({txt = ("ocaml.error"|"error"); loc}, p), _)} -> begin match p with | PStr([{pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)} + ({pexp_desc=Pexp_constant + {pconst_desc=Pconst_string(msg, _, _); _}}, _)} ]) -> - { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg } + Location.msg ~loc "%a" Format_doc.pp_print_text msg | _ -> - { Location.loc; txt = fun ppf -> - Format.fprintf ppf - "Invalid syntax for sub-message of extension '%s'." main_txt } + Location.msg ~loc "Invalid syntax for sub-message of extension %a." + Style.inline_code main_txt end | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} -> - { Location.loc; txt = fun ppf -> - Format.fprintf ppf "Uninterpreted extension '%s'." txt } + Location.msg ~loc "Uninterpreted extension '%a'." + Style.inline_code txt | _ -> - { Location.loc = main_loc; txt = fun ppf -> - Format.fprintf ppf - "Invalid syntax for sub-message of extension '%s'." main_txt } + Location.msg ~loc:main_loc + "Invalid syntax for sub-message of extension %a." + Style.inline_code main_txt in match ext with | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> begin match p with | PStr [] -> raise Location.Already_displayed_error | PStr({pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}:: + ({pexp_desc=Pexp_constant + {pconst_desc=Pconst_string(msg, _, _)}}, _)}:: inner) -> let sub = List.map (submessage_from loc txt) inner in - Location.error_of_printer ~loc ~sub Format.pp_print_text msg + Location.error_of_printer ~loc ~sub Format_doc.pp_print_text msg | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt end @@ -186,7 +203,8 @@ let kind_and_message = function Pstr_eval ({pexp_desc=Pexp_apply ({pexp_desc=Pexp_ident{txt=Longident.Lident id}}, - [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_,_))}]) + [Nolabel,{pexp_desc=Pexp_constant + {pconst_desc=Pconst_string(s,_,_); _}}]) },_)}] -> Some (id, s) | PStr[ @@ -265,7 +283,10 @@ let rec attrs_of_sig = function | _ -> [] -let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg) +let alerts_of_sig ~mark sg = + let a = attrs_of_sig sg in + if mark then mark_alerts_used a; + alerts_of_attrs a let rec attrs_of_str = function | {pstr_desc = Pstr_attribute a} :: tl -> @@ -273,7 +294,10 @@ let rec attrs_of_str = function | _ -> [] -let alerts_of_str str = alerts_of_attrs (attrs_of_str str) +let alerts_of_str ~mark str = + let a = attrs_of_str str in + if mark then mark_alerts_used a; + alerts_of_attrs a let warn_payload loc txt msg = Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)) @@ -294,7 +318,7 @@ let warning_attribute ?(ppwarning = true) = let process_alert loc name = function | PStr[{pstr_desc= Pstr_eval( - {pexp_desc=Pexp_constant(Pconst_string(s,_,_))}, + {pexp_desc=Pexp_constant {pconst_desc=Pconst_string(s,_,_); _}}, _) }] -> begin @@ -303,15 +327,19 @@ let warning_attribute ?(ppwarning = true) = with Arg.Bad msg -> warn_payload loc name.txt msg end | k -> - (* Don't [mark_used] in the [Some] cases - that happens in [Env] or - [type_mod] if they are in a valid place. Do [mark_used] in the - [None] case, which is just malformed and covered by the "Invalid - payload" warning. *) match kind_and_message k with | Some ("all", _) -> warn_payload loc name.txt "The alert name 'all' is reserved" - | Some _ -> () + | Some _ -> + (* Do [mark_used] in the [Some] case only if Warning 53 is + disabled. Later, they will be marked used (provided they are in a + valid place) in [compile_common], when they are extracted to be + persisted inside the [.cmi] file. *) + if not (Warnings.is_active (Misplaced_attribute "")) + then mark_used name | None -> begin + (* Do [mark_used] in the [None] case, which is just malformed and + covered by the "Invalid payload" warning. *) mark_used name; warn_payload loc name.txt "Invalid payload" end @@ -327,7 +355,7 @@ let warning_attribute ?(ppwarning = true) = begin match attr_payload with | PStr [{ pstr_desc= Pstr_eval({pexp_desc=Pexp_constant - (Pconst_string (s, _, _))},_); + {pconst_desc=Pconst_string (s, _, _); _}},_); pstr_loc }] -> (mark_used attr_name; Location.prerr_warning pstr_loc (Warnings.Preprocessor s)) diff --git a/src/ocaml/parsing/builtin_attributes.mli b/src/ocaml/parsing/builtin_attributes.mli index 4eb5ef91f..4176bcb93 100644 --- a/src/ocaml/parsing/builtin_attributes.mli +++ b/src/ocaml/parsing/builtin_attributes.mli @@ -75,7 +75,8 @@ val register_attr : current_phase -> string Location.loc -> unit val mark_payload_attrs_used : Parsetree.payload -> unit (** Issue misplaced attribute warnings for all attributes created with - [mk_internal] but not yet marked used. *) + [mk_internal] but not yet marked used. Does nothing if compilation + is stopped before lambda due to command-line flags. *) val warn_unused : unit -> unit (** {3 Warning 53 helpers for environment attributes} @@ -115,8 +116,8 @@ val check_alerts_inclusion: def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> Parsetree.attributes -> string -> unit val alerts_of_attrs: Parsetree.attributes -> Misc.alerts -val alerts_of_sig: Parsetree.signature -> Misc.alerts -val alerts_of_str: Parsetree.structure -> Misc.alerts +val alerts_of_sig: mark:bool -> Parsetree.signature -> Misc.alerts +val alerts_of_str: mark:bool -> Parsetree.structure -> Misc.alerts val check_deprecated_mutable: Location.t -> Parsetree.attributes -> string -> unit @@ -172,7 +173,7 @@ val select_attributes : (** [attr_equals_builtin attr s] is true if the name of the attribute is [s] or ["ocaml." ^ s]. This is useful for manually inspecting attribute names, but note that doing so will not result in marking the attribute used for the - purpose of warning 53, so it is usually preferrable to use [has_attribute] + purpose of warning 53, so it is usually preferable to use [has_attribute] or [select_attributes]. *) val attr_equals_builtin : Parsetree.attribute -> string -> bool diff --git a/src/ocaml/parsing/docstrings.ml b/src/ocaml/parsing/docstrings.ml index a39f75d25..32b8e8c46 100644 --- a/src/ocaml/parsing/docstrings.ml +++ b/src/ocaml/parsing/docstrings.ml @@ -91,8 +91,9 @@ let docs_attr ds = let open Parsetree in let body = ds.ds_body in let loc = ds.ds_loc in + let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); + { pexp_desc = Pexp_constant const; pexp_loc = loc; pexp_loc_stack = []; pexp_attributes = []; } @@ -143,8 +144,9 @@ let text_attr ds = let open Parsetree in let body = ds.ds_body in let loc = ds.ds_loc in + let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); + { pexp_desc = Pexp_constant const; pexp_loc = loc; pexp_loc_stack = []; pexp_attributes = []; } diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml index 781a2e846..1710b45a1 100644 --- a/src/ocaml/parsing/location.ml +++ b/src/ocaml/parsing/location.ml @@ -122,13 +122,6 @@ let echo_eof () = print_newline (); incr num_loc_lines -(* This is used by the toplevel and the report printers below. *) -let separate_new_message ppf = - if not (is_first_message ()) then begin - Format.pp_print_newline ppf (); - incr num_loc_lines - end - (* Code printing errors and warnings must be wrapped using this function, in order to update [num_loc_lines]. @@ -150,7 +143,12 @@ let print_updating_num_loc_lines ppf f arg = pp_print_flush ppf (); pp_set_formatter_out_functions ppf out_functions +<<<<<<< (* +======= +(** {1 Printing setup }*) + +>>>>>>> let setup_tags () = Misc.Style.setup !Clflags.color *) @@ -214,8 +212,18 @@ let absolute_path s = (* This function could go into Filename *) let show_filename file = (* if !Clflags.absname then absolute_path file else *) file -let print_filename ppf file = - Format.pp_print_string ppf (show_filename file) +module Fmt = Format_doc +module Doc = struct + + (* This is used by the toplevel and the report printers below. *) + let separate_new_message ppf () = + if not (is_first_message ()) then begin + Fmt.pp_print_newline ppf (); + incr num_loc_lines + end + + let filename ppf file = + Fmt.pp_print_string ppf (show_filename file) (* Best-effort printing of the text describing a location, of the form 'File "foo.ml", line 3, characters 10-12'. @@ -223,6 +231,7 @@ let print_filename ppf file = Some of the information (filename, line number or characters numbers) in the location might be invalid; in which case we do not print it. *) +<<<<<<< let print_loc ppf loc = (* setup_tags (); *) let file_valid = function @@ -264,18 +273,75 @@ let print_loc ppf loc = comma (); Format.fprintf ppf "%s %i" (capitalize "line") (if line_valid line then line else 1); - - if chars_valid ~startchar ~endchar then ( +======= + let loc ppf loc = + setup_tags (); + let file_valid = function + | "_none_" -> + (* This is a dummy placeholder, but we print it anyway to please + editors that parse locations in error messages (e.g. Emacs). *) + true + | "" | "//toplevel//" -> false + | _ -> true + in + let line_valid line = line > 0 in + let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in +>>>>>>> + + let file = + (* According to the comment in location.mli, if [pos_fname] is "", we must + use [!input_name]. *) + if loc.loc_start.pos_fname = "" then !input_name + else loc.loc_start.pos_fname + in + let startline = loc.loc_start.pos_lnum in + let endline = loc.loc_end.pos_lnum in + let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in + let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in + + let first = ref true in + let capitalize s = + if !first then (first := false; String.capitalize_ascii s) + else s in + let comma () = + if !first then () else Fmt.fprintf ppf ", " in + + Fmt.fprintf ppf "@{"; + + if file_valid file then + Fmt.fprintf ppf "%s \"%a\"" (capitalize "file") filename file; + + (* Print "line 1" in the case of a dummy line number. This is to please the + existing setup of editors that parse locations in error messages (e.g. + Emacs). *) comma (); - Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar - ); + let startline = if line_valid startline then startline else 1 in + let endline = if line_valid endline then endline else startline in + begin if startline = endline then + Fmt.fprintf ppf "%s %i" (capitalize "line") startline + else + Fmt.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline + end; - Format.fprintf ppf "@}" + if chars_valid ~startchar ~endchar then ( + comma (); + Fmt.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar + ); -(* Print a comma-separated list of locations *) -let print_locs ppf locs = - Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") - print_loc ppf locs + Fmt.fprintf ppf "@}" + + (* Print a comma-separated list of locations *) + let locs ppf locs = + Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.fprintf ppf ",@ ") + loc ppf locs + let quoted_filename ppf f = Misc.Style.as_inline_code filename ppf f + +end + +let print_filename = Fmt.compat Doc.filename +let print_loc = Fmt.compat Doc.loc +let print_locs = Fmt.compat Doc.locs +let separate_new_message ppf = Fmt.compat Doc.separate_new_message ppf () (******************************************************************************) (* An interval set structure; additionally, it stores user-provided information @@ -469,13 +535,13 @@ let highlight_quote ppf Option.fold ~some:Int.to_string ~none:"" lnum, start_pos)) in - Format.fprintf ppf "@["; + Fmt.fprintf ppf "@["; begin match lines with | [] | [("", _, _)] -> () | [(line, line_nb, line_start_cnum)] -> (* Single-line error *) - Format.fprintf ppf "%s | %s@," line_nb line; - Format.fprintf ppf "%*s " (String.length line_nb) ""; + Fmt.fprintf ppf "%s | %s@," line_nb line; + Fmt.fprintf ppf "%*s " (String.length line_nb) ""; (* Iterate up to [rightmost], which can be larger than the length of the line because we may point to a location after the end of the last token on the line, for instance: @@ -487,21 +553,21 @@ let highlight_quote ppf for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do let pos = line_start_cnum + i in if ISet.is_start iset ~pos <> None then - Format.fprintf ppf "@{<%s>" highlight_tag; - if ISet.mem iset ~pos then Format.pp_print_char ppf '^' + Fmt.fprintf ppf "@{<%s>" highlight_tag; + if ISet.mem iset ~pos then Fmt.pp_print_char ppf '^' else if i < String.length line then begin (* For alignment purposes, align using a tab for each tab in the source code *) - if line.[i] = '\t' then Format.pp_print_char ppf '\t' - else Format.pp_print_char ppf ' ' + if line.[i] = '\t' then Fmt.pp_print_char ppf '\t' + else Fmt.pp_print_char ppf ' ' end; if ISet.is_end iset ~pos <> None then - Format.fprintf ppf "@}" + Fmt.fprintf ppf "@}" done; - Format.fprintf ppf "@}@," + Fmt.fprintf ppf "@}@," | _ -> (* Multi-line error *) - Misc.pp_two_columns ~sep:"|" ~max_lines ppf + Fmt.pp_two_columns ~sep:"|" ~max_lines ppf @@ List.map (fun (line, line_nb, line_start_cnum) -> let line = String.mapi (fun i car -> if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.' @@ -509,8 +575,12 @@ let highlight_quote ppf (line_nb, line) ) lines end; +<<<<<<< Format.fprintf ppf "@]" *) +======= + Fmt.fprintf ppf "@]" +>>>>>>> @@ -614,10 +684,10 @@ let lines_around_from_current_input ~start_pos ~end_pos = (******************************************************************************) (* Reporting errors and warnings *) -type msg = (Format.formatter -> unit) loc +type msg = Fmt.t loc let msg ?(loc = none) fmt = - Format.kdprintf (fun txt -> { loc; txt }) fmt + Fmt.kdoc_printf (fun txt -> { loc; txt }) fmt type report_kind = | Report_error @@ -632,7 +702,11 @@ type report = { kind : report_kind; main : msg; sub : msg list; +<<<<<<< source : error_source; +======= + footnote: Fmt.t option; +>>>>>>> } let loc_of_report { main; _ } = main.loc @@ -651,7 +725,7 @@ type report_printer = { pp_main_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_main_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; + Format.formatter -> Fmt.t -> unit; pp_submsgs : report_printer -> report -> Format.formatter -> msg list -> unit; pp_submsg : report_printer -> report -> @@ -659,7 +733,7 @@ type report_printer = { pp_submsg_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_submsg_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; + Format.formatter -> Fmt.t -> unit; } (* @@ -721,11 +795,19 @@ let batch_mode_printer : report_printer = | Misc.Error_style.Short -> () in +<<<<<<< Format.fprintf ppf "@[%a:@ %a@]" print_loc loc highlight loc *) () +======= + Format.fprintf ppf "@[%a:@ %a@]" print_loc loc + (Fmt.compat highlight) loc + in + let pp_txt ppf txt = Format.fprintf ppf "@[%a@]" Fmt.Doc.format txt in + let pp_footnote ppf f = + Option.iter (Format.fprintf ppf "@,%a" pp_txt) f +>>>>>>> in - let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in let pp self ppf report = (* setup_tags (); *) separate_new_message ppf; @@ -734,13 +816,14 @@ let batch_mode_printer : report_printer = to be aligned with the main message box *) print_updating_num_loc_lines ppf (fun ppf () -> - Format.fprintf ppf "@[%a%a%a: %a%a%a%a@]@." + Format.fprintf ppf "@[%a%a%a: %a%a%a%a%a@]@." Format.pp_open_tbox () (self.pp_main_loc self report) report.main.loc (self.pp_report_kind self report) report.kind Format.pp_set_tab () (self.pp_main_txt self report) report.main.txt (self.pp_submsgs self report) report.sub + pp_footnote report.footnote Format.pp_close_tbox () ) () in @@ -821,18 +904,37 @@ let print_report ppf report = (* Reporting errors *) type error = report +type delayed_msg = unit -> Fmt.t option let report_error ppf err = print_report ppf err +<<<<<<< let mkerror loc sub txt source = { kind = Report_error; main = { loc; txt }; sub; source } +======= +let mkerror loc sub footnote txt = + { kind = Report_error; main = { loc; txt }; sub; footnote=footnote () } + +let errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = + Fmt.kdoc_printf (mkerror loc sub footnote) +>>>>>>> +<<<<<<< let errorf ?(loc = none) ?(sub = []) ?(source=Typer) = Format.kdprintf (fun msg -> mkerror loc sub msg source) +======= +let error ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) msg_str = + mkerror loc sub footnote Fmt.Doc.(string msg_str empty) +>>>>>>> +<<<<<<< let error ?(loc = none) ?(sub = []) ?(source=Typer) msg_str = mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str) source +======= +let error_of_printer ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) pp x = + mkerror loc sub footnote (Fmt.doc_printf "%a" pp x) +>>>>>>> let error_of_printer ?(loc = none) ?(sub = []) ?(source=Typer) pp x = mkerror loc sub (fun ppf -> pp ppf x) source @@ -848,13 +950,17 @@ let default_warning_alert_reporter ?(source = Typer) report mk (loc: t) w : repo match report w with | `Inactive -> None | `Active { Warnings.id; message; is_error; sub_locs } -> - let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in + let msg_of_str str = Format_doc.Doc.(empty |> string str) in let kind = mk is_error id in let main = { loc; txt = msg_of_str message } in let sub = List.map (fun (loc, sub_message) -> { loc; txt = msg_of_str sub_message } ) sub_locs in +<<<<<<< Some { kind; main; sub; source } +======= + Some { kind; main; sub; footnote=None } +>>>>>>> let default_warning_reporter = @@ -910,7 +1016,7 @@ let deprecated ?def ?use loc message = module Style = Misc.Style let auto_include_alert lib = - let message = Format.asprintf "\ + let message = Fmt.asprintf "\ OCaml's lib directory layout changed in 5.0. The %a subdirectory has been \ automatically added to the search path, but you should add %a to the \ command-line to silence this alert (e.g. by adding %a to the list of \ @@ -929,7 +1035,7 @@ let auto_include_alert lib = prerr_alert none alert let deprecated_script_alert program = - let message = Format.asprintf "\ + let message = Fmt.asprintf "\ Running %a where the first argument is an implicit basename with no \ extension (e.g. %a) is deprecated. Either rename the script \ (%a) or qualify the basename (%a)" @@ -995,5 +1101,10 @@ let () = | _ -> None ) +<<<<<<< let raise_errorf ?(loc = none) ?(sub = []) ?(source = Typer)= Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt source))) +======= +let raise_errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = + Fmt.kdoc_printf (fun txt -> raise (Error (mkerror loc sub footnote txt))) +>>>>>>> diff --git a/src/ocaml/parsing/location.mli b/src/ocaml/parsing/location.mli index 6681309d5..abe46fcb8 100644 --- a/src/ocaml/parsing/location.mli +++ b/src/ocaml/parsing/location.mli @@ -87,7 +87,6 @@ val input_phrase_buffer: Buffer.t option ref (** {1 Toplevel-specific functions} *) val echo_eof: unit -> unit -val separate_new_message: formatter -> unit val reset: unit -> unit @@ -173,10 +172,21 @@ val show_filename: string -> string Otherwise, returns the filename unchanged. *) val print_filename: formatter -> string -> unit - val print_loc: formatter -> t -> unit val print_locs: formatter -> t list -> unit +val separate_new_message: formatter -> unit +<<<<<<< +======= +module Doc: sig + val separate_new_message: unit Format_doc.printer + val filename: string Format_doc.printer + val quoted_filename: string Format_doc.printer + val loc: t Format_doc.printer + val locs: t list Format_doc.printer +end + +>>>>>>> (** {1 Toplevel-specific location highlighting} *) (* val highlight_terminfo: @@ -187,9 +197,9 @@ val highlight_terminfo: (** {2 The type of reports and report printers} *) -type msg = (Format.formatter -> unit) loc +type msg = Format_doc.t loc -val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a +val msg: ?loc:t -> ('a, Format_doc.formatter, unit, msg) format4 -> 'a type report_kind = | Report_error @@ -204,7 +214,11 @@ type report = { kind : report_kind; main : msg; sub : msg list; +<<<<<<< source : error_source; +======= + footnote: Format_doc.t option +>>>>>>> } (* Exposed for Merlin *) @@ -222,7 +236,7 @@ type report_printer = { pp_main_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_main_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; + Format.formatter -> Format_doc.t -> unit; pp_submsgs : report_printer -> report -> Format.formatter -> msg list -> unit; pp_submsg : report_printer -> report -> @@ -230,7 +244,7 @@ type report_printer = { pp_submsg_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_submsg_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; + Format.formatter -> Format_doc.t -> unit; } (** A printer for [report]s, defined using open-recursion. The goal is to make it easy to define new printers by re-using code from @@ -336,15 +350,35 @@ val deprecated_script_alert: string -> unit type error = report (** An [error] is a [report] which [report_kind] must be [Report_error]. *) +<<<<<<< val error: ?loc:t -> ?sub:msg list -> ?source:error_source -> string -> error +======= +type delayed_msg = unit -> Format_doc.t option + +val error: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> string -> error +>>>>>>> +<<<<<<< val errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> ('a, Format.formatter, unit, error) format4 -> 'a +======= +val errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> + ('a, Format_doc.formatter, unit, error) format4 -> 'a +>>>>>>> +<<<<<<< val error_of_printer: ?loc:t -> ?sub:msg list -> ?source:error_source -> (formatter -> 'a -> unit) -> 'a -> error +======= +val error_of_printer: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> + (Format_doc.formatter -> 'a -> unit) -> 'a -> error +>>>>>>> +<<<<<<< val error_of_printer_file: ?source:error_source -> (formatter -> 'a -> unit) -> 'a -> error +======= +val error_of_printer_file: (Format_doc.formatter -> 'a -> unit) -> 'a -> error +>>>>>>> (** {1 Automatically reporting errors for raised exceptions} *) @@ -367,8 +401,13 @@ exception Already_displayed_error (** Raising [Already_displayed_error] signals an error which has already been printed. The exception will be caught, but nothing will be printed *) +<<<<<<< val raise_errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> ('a, Format.formatter, unit, 'b) format4 -> 'a +======= +val raise_errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> + ('a, Format_doc.formatter, unit, 'b) format4 -> 'a +>>>>>>> val report_exception: formatter -> exn -> unit (** Reraise the exception if it is unknown. *) diff --git a/src/ocaml/parsing/parsetree.mli b/src/ocaml/parsing/parsetree.mli index 2f0a40c26..e22a9a781 100644 --- a/src/ocaml/parsing/parsetree.mli +++ b/src/ocaml/parsing/parsetree.mli @@ -22,7 +22,12 @@ open Asttypes -type constant = +type constant = { + pconst_desc : constant_desc; + pconst_loc : Location.t; +} + +and constant_desc = | Pconst_integer of string * char option (** Integer constants such as [3] [3l] [3L] [3n]. @@ -270,6 +275,7 @@ and pattern_desc = [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] *) | Ppat_exception of pattern (** Pattern [exception P] *) + | Ppat_effect of pattern * pattern (* Pattern [effect P P] *) | Ppat_extension of extension (** Pattern [[%id]] *) | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index ef87dcb4a..9132073b2 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -94,26 +94,95 @@ let needs_parens txt = let needs_spaces txt = first_is '*' txt || last_is '*' txt +let tyvar_of_name s = + if String.length s >= 2 && s.[1] = '\'' then + (* without the space, this would be parsed as + a character literal *) + "' " ^ s + else if Lexer.is_keyword s then + "'\\#" ^ s + else if String.equal s "_" then + s + else + "'" ^ s + +module Doc = struct (* Turn an arbitrary variable name into a valid OCaml identifier by adding \# in case it is a keyword, or parenthesis when it is an infix or prefix operator. *) -let ident_of_name ppf txt = - let format : (_, _, _) format = - if Lexer.is_keyword txt then "\\#%s" - else if not (needs_parens txt) then "%s" - else if needs_spaces txt then "(@;%s@;)" - else "(%s)" - in fprintf ppf format txt - -let ident_of_name_loc ppf s = ident_of_name ppf s.txt - -let protect_longident ppf print_longident longprefix txt = + let ident_of_name ppf txt = + let format : (_, _, _) format = + if Lexer.is_keyword txt then "\\#%s" + else if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in Format_doc.fprintf ppf format txt + + let protect_longident ppf print_longident longprefix txt = if not (needs_parens txt) then - fprintf ppf "%a.%a" print_longident longprefix ident_of_name txt + Format_doc.fprintf ppf "%a.%a" + print_longident longprefix + ident_of_name txt else if needs_spaces txt then - fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt + Format_doc.fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt else - fprintf ppf "%a.(%s)" print_longident longprefix txt + Format_doc.fprintf ppf "%a.(%s)" print_longident longprefix txt + + let rec longident f = function + | Lident s -> ident_of_name f s + | Ldot(y,s) -> protect_longident f longident y s + | Lapply (y,s) -> + Format_doc.fprintf f "%a(%a)" longident y longident s + + let tyvar ppf s = + Format_doc.fprintf ppf "%s" (tyvar_of_name s) + + (* Expressions are considered nominal if they can be used as the subject of a + sentence or action. In practice, we consider that an expression is nominal + if they satisfy one of: + - Similar to an identifier: words separated by '.' or '#'. + - Do not contain spaces when printed. + - Is a constant that is short enough. + *) + let nominal_exp t = + let open Format_doc.Doc in + let longident l = Format_doc.doc_printer longident l.Location.txt in + let rec nominal_exp doc exp = + match exp.pexp_desc with + | _ when exp.pexp_attributes <> [] -> None + | Pexp_ident l -> + Some (longident l doc) + | Pexp_variant (lbl, None) -> + Some (printf "`%s" lbl doc) + | Pexp_construct (l, None) -> + Some (longident l doc) + | Pexp_field (parent, lbl) -> + Option.map + (printf ".%t" (longident lbl)) + (nominal_exp doc parent) + | Pexp_send (parent, meth) -> + Option.map + (printf "#%s" meth.txt) + (nominal_exp doc parent) + (* String constants are syntactically too complex. For example, the + quotes conflict with the 'inline_code' style and they might contain + spaces. *) + | Pexp_constant { pconst_desc = Pconst_string _; _ } -> None + (* Char, integer and float constants are nominal. *) + | Pexp_constant { pconst_desc = Pconst_char c; _ } -> + Some (msg "%C" c) + | Pexp_constant + { pconst_desc = Pconst_integer (cst, suf) | Pconst_float (cst, suf); + _ } -> + Some (msg "%s%t" cst (option char suf)) + | _ -> None + in + nominal_exp empty t +end + +let longident ppf l = Format_doc.compat Doc.longident ppf l +let ident_of_name ppf i = Format_doc.compat Doc.ident_of_name ppf i +let ident_of_name_loc ppf s = ident_of_name ppf s.txt type space_formatter = (unit, Format.formatter, unit) format @@ -225,15 +294,9 @@ let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") else fu f x -let rec longident f = function - | Lident s -> ident_of_name f s - | Ldot(y,s) -> protect_longident f longident y s - | Lapply (y,s) -> - pp f "%a(%a)" longident y longident s - let longident_loc f x = pp f "%a" longident x.txt -let constant f = function +let constant_desc f = function | Pconst_char i -> pp f "%C" i | Pconst_string (i, _, None) -> @@ -249,6 +312,8 @@ let constant f = function | Pconst_float (i, Some m) -> paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m) +let constant f const = constant_desc f const.pconst_desc + (* trailing space*) let mutable_flag f = function | Immutable -> () @@ -277,20 +342,9 @@ let iter_loc f ctxt {txt; loc = _} = f ctxt txt let constant_string f s = pp f "%S" s -let tyvar_of_name s = - if String.length s >= 2 && s.[1] = '\'' then - (* without the space, this would be parsed as - a character literal *) - "' " ^ s - else if Lexer.is_keyword s then - "'\\#" ^ s - else if String.equal s "_" then - s - else - "'" ^ s -let tyvar ppf s = - Format.fprintf ppf "%s" (tyvar_of_name s) + +let tyvar ppf v = Format_doc.compat Doc.tyvar ppf v let tyvar_loc f str = tyvar f str.txt let string_quot f x = pp f "`%a" ident_of_name x @@ -512,6 +566,8 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_effect(p1, p2) -> + pp f "@[<2>effect@;%a, @;%a@]" (pattern1 ctxt) p1 (pattern1 ctxt) p2 | Ppat_extension e -> extension ctxt f e | Ppat_open (lid, p) -> let with_paren = @@ -1136,7 +1192,7 @@ and module_type ctxt f x = pp f "@[%a@ ->@ %a@]" (module_type1 ctxt) mt1 (module_type ctxt) mt2 | Some name -> - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name + pp f "@[(%s@ :@ %a)@ ->@ %a@]" name (module_type ctxt) mt1 (module_type ctxt) mt2 end | Pmty_with (mt, []) -> module_type ctxt f mt diff --git a/src/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli index bf7350139..56a9b12f1 100644 --- a/src/ocaml/parsing/pprintast.mli +++ b/src/ocaml/parsing/pprintast.mli @@ -60,7 +60,19 @@ val tyvar: Format.formatter -> string -> unit special treatment required for the single quote character in second position, or for keywords by escaping them with \#. No-op on "_". *) +<<<<<<< (* merlin *) val case_list : Format.formatter -> Parsetree.case list -> unit val ident_of_name : Format.formatter -> string -> unit val needs_parens : string -> bool +======= +(** {!Format_doc} functions for error messages *) +module Doc:sig + val longident: Longident.t Format_doc.printer + val tyvar: string Format_doc.printer + + (** Returns a format document if the expression reads nicely as the subject + of a sentence in a error message. *) + val nominal_exp : Parsetree.expression -> Format_doc.t option +end +>>>>>>> diff --git a/src/ocaml/parsing/printast.ml b/src/ocaml/parsing/printast.ml index d7d569214..331d82f62 100644 --- a/src/ocaml/parsing/printast.ml +++ b/src/ocaml/parsing/printast.ml @@ -59,6 +59,7 @@ let fmt_char_option f = function | None -> fprintf f "None" | Some c -> fprintf f "Some %c" c +<<<<<<< let fmt_constant f x = match x with | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; @@ -69,6 +70,8 @@ let fmt_constant f x = fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m +======= +>>>>>>> let fmt_mutable_flag f x = match x with | Immutable -> fprintf f "Immutable" @@ -108,6 +111,18 @@ let line i f s (*...*) = fprintf f "%s" (String.make ((2*i) mod 72) ' '); fprintf f s (*...*) +let fmt_constant i f x = + line i f "constant %a\n" fmt_location x.pconst_loc; + let i = i+1 in + match x.pconst_desc with + | Pconst_integer (j,m) -> line i f "PConst_int (%s,%a)\n" j fmt_char_option m + | Pconst_char c -> line i f "PConst_char %02x\n" (Char.code c) + | Pconst_string (s, strloc, None) -> + line i f "PConst_string(%S,%a,None)\n" s fmt_location strloc + | Pconst_string (s, strloc, Some delim) -> + line i f "PConst_string (%S,%a,Some %S)\n" s fmt_location strloc delim + | Pconst_float (s,m) -> line i f "PConst_float (%s,%a)\n" s fmt_char_option m + let list i f ppf l = match l with | [] -> line i ppf "[]\n" @@ -204,9 +219,13 @@ and pattern i ppf x = | Ppat_alias (p, s) -> line i ppf "Ppat_alias %a\n" fmt_string_loc s; pattern i ppf p; - | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Ppat_constant (c) -> + line i ppf "Ppat_constant\n"; + fmt_constant i ppf c; | Ppat_interval (c1, c2) -> - line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; + line i ppf "Ppat_interval\n"; + fmt_constant i ppf c1; + fmt_constant i ppf c2; | Ppat_tuple (l) -> line i ppf "Ppat_tuple\n"; list i pattern ppf l; @@ -245,6 +264,10 @@ and pattern i ppf x = | Ppat_exception p -> line i ppf "Ppat_exception\n"; pattern i ppf p + | Ppat_effect(p1, p2) -> + line i ppf "Ppat_effect\n"; + pattern i ppf p1; + pattern i ppf p2 | Ppat_open (m,p) -> line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; pattern i ppf p @@ -258,7 +281,9 @@ and expression i ppf x = let i = i+1 in match x.pexp_desc with | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; - | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Pexp_constant (c) -> + line i ppf "Pexp_constant\n"; + fmt_constant i ppf c; | Pexp_let (rf, l, e) -> line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; diff --git a/src/ocaml/parsing/unit_info.ml b/src/ocaml/parsing/unit_info.ml index 03e8d4494..66ad51b7c 100644 --- a/src/ocaml/parsing/unit_info.ml +++ b/src/ocaml/parsing/unit_info.ml @@ -13,18 +13,24 @@ (* *) (**************************************************************************) +type intf_or_impl = Intf | Impl type modname = string type filename = string type file_prefix = string +type error = Invalid_encoding of string +exception Error of error + type t = { source_file: filename; prefix: file_prefix; modname: modname; + kind: intf_or_impl; } let source_file (x: t) = x.source_file let modname (x: t) = x.modname +let kind (x: t) = x.kind let prefix (x: t) = x.prefix let basename_chop_extensions basename = @@ -32,37 +38,39 @@ let basename_chop_extensions basename = | dot_pos -> String.sub basename 0 dot_pos | exception Not_found -> basename -let modulize s = String.capitalize_ascii s +let strict_modulize s = + match Misc.Utf8_lexeme.capitalize s with + | Ok x -> x + | Error _ -> raise (Error (Invalid_encoding s)) + +let modulize s = match Misc.Utf8_lexeme.capitalize s with Ok x | Error x -> x -(* We re-export the [Misc] definition *) -let normalize = Misc.normalized_unit_filename +(* We re-export the [Misc] definition, and ignore encoding errors under the + assumption that we should focus our effort on not *producing* badly encoded + module names *) +let normalize x = match Misc.normalized_unit_filename x with + | Ok x | Error x -> x -let modname_from_source source_file = - source_file |> Filename.basename |> basename_chop_extensions |> modulize +let stem source_file = + source_file |> Filename.basename |> basename_chop_extensions -let start_char = function - | 'A' .. 'Z' -> true - | _ -> false +let strict_modname_from_source source_file = + source_file |> stem |> strict_modulize -let is_identchar_latin1 = function - | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' - | '\248'..'\255' | '\'' | '0'..'9' -> true - | _ -> false +let lax_modname_from_source source_file = + source_file |> stem |> modulize (* Check validity of module name *) -let is_unit_name name = - String.length name > 0 - && start_char name.[0] - && String.for_all is_identchar_latin1 name +let is_unit_name name = Misc.Utf8_lexeme.is_valid_identifier name let check_unit_name file = if not (is_unit_name (modname file)) then Location.prerr_warning (Location.in_file (source_file file)) (Warnings.Bad_module_name (modname file)) -let make ?(check_modname=true) ~source_file prefix = - let modname = modname_from_source prefix in - let p = { modname; prefix; source_file } in +let make ?(check_modname=true) ~source_file kind prefix = + let modname = strict_modname_from_source prefix in + let p = { modname; prefix; source_file; kind } in if check_modname then check_unit_name p; p @@ -79,7 +87,7 @@ module Artifact = struct let prefix x = Filename.remove_extension (filename x) let from_filename filename = - let modname = modname_from_source filename in + let modname = lax_modname_from_source filename in { modname; filename; source_file = None } end @@ -120,3 +128,14 @@ let find_normalized_cmi f = let filename = modname f ^ ".cmi" in let filename = Load_path.find_normalized filename in { Artifact.filename; modname = modname f; source_file = Some f.source_file } + +let report_error = function + | Invalid_encoding name -> + Location.errorf "Invalid encoding of output name: %s." name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (report_error err) + | _ -> None + ) diff --git a/src/ocaml/parsing/unit_info.mli b/src/ocaml/parsing/unit_info.mli index 466a07a22..4117d243c 100644 --- a/src/ocaml/parsing/unit_info.mli +++ b/src/ocaml/parsing/unit_info.mli @@ -21,24 +21,32 @@ (** {1:modname_from_strings Module name convention and computation} *) +type intf_or_impl = Intf | Impl type modname = string type filename = string type file_prefix = string +type error = Invalid_encoding of filename +exception Error of error + (** [modulize s] capitalizes the first letter of [s]. *) val modulize: string -> modname (** [normalize s] uncapitalizes the first letter of [s]. *) val normalize: string -> string -(** [modname_from_source filename] is [modulize stem] where [stem] is the +(** [lax_modname_from_source filename] is [modulize stem] where [stem] is the basename of the filename [filename] stripped from all its extensions. - For instance, [modname_from_source "/pa.th/x.ml.pp"] is ["X"]. *) -val modname_from_source: filename -> modname + For instance, [lax_modname_from_source "/pa.th/x.ml.pp"] is ["X"]. *) +val lax_modname_from_source: filename -> modname + +(** Same as {!lax_modname_from_source} but raises an {!error.Invalid_encoding} + error on filename with invalid utf8 encoding. *) +val strict_modname_from_source: filename -> modname (** {2:module_name_validation Module name validation function}*) -(** [is_unit_name ~strict name] is true only if [name] can be used as a +(** [is_unit_name name] is true only if [name] can be used as a valid module name. *) val is_unit_name : modname -> bool @@ -67,19 +75,24 @@ val prefix: t -> file_prefix or compilation artifact.*) val modname: t -> modname +(** [kind u] is the kind (interface or implementation) of the unit. *) +val kind: t -> intf_or_impl + (** [check_unit_name u] prints a warning if the derived module name [modname u] should not be used as a module name as specified by {!is_unit_name}[ ~strict:true]. *) val check_unit_name : t -> unit -(** [make ~check ~source_file prefix] associates both the - [source_file] and the module name {!modname_from_source}[ target_prefix] to - the prefix filesystem path [prefix]. +(** [make ~check ~source_file kind prefix] associates both the + [source_file] and the module name {!lax_modname_from_source}[ target_prefix] + to the prefix filesystem path [prefix]. If [check_modname=true], this function emits a warning if the derived module name is not valid according to {!check_unit_name}. *) -val make: ?check_modname:bool -> source_file:filename -> file_prefix -> t +val make: + ?check_modname:bool -> source_file:filename -> + intf_or_impl -> file_prefix -> t (** {1:artifact_function Build artifacts }*) module Artifact: sig @@ -103,7 +116,8 @@ module Artifact: sig val modname: t -> modname (** [from_filename filename] reconstructs the module name - [modname_from_source filename] associated to the artifact [filename]. *) + [lax_modname_from_source filename] associated to the artifact + [filename]. *) val from_filename: filename -> t end diff --git a/src/ocaml/typing/btype.ml b/src/ocaml/typing/btype.ml index 5ce396ecd..4cc0cd4d4 100644 --- a/src/ocaml/typing/btype.ml +++ b/src/ocaml/typing/btype.ml @@ -43,7 +43,6 @@ module TypeMap = struct let singleton ty = wrap_repr singleton ty let fold f = TransientTypeMap.fold (wrap_type_expr f) end -module TransientTypeHash = Hashtbl.Make(TransientTypeOps) module TypeHash = struct include TransientTypeHash let mem hash = wrap_repr (mem hash) @@ -94,45 +93,85 @@ module TypePairs = struct f (type_expr t1, type_expr t2)) end -(**** Forward declarations ****) - -let print_raw = - ref (fun _ -> assert false : Format.formatter -> type_expr -> unit) - (**** Type level management ****) let generic_level = Ident.highest_scope - -(* Used to mark a type during a traversal. *) let lowest_level = Ident.lowest_scope -let pivot_level = 2 * lowest_level - 1 - (* pivot_level - lowest_level < lowest_level *) + +(**** leveled type pool ****) +(* This defines a stack of pools of type nodes indexed by the level + we will try to generalize them in [Ctype.with_local_level_gen]. + [pool_of_level] returns the pool in which types at level [level] + should be kept, which is the topmost pool whose level is lower or + equal to [level]. + [Ctype.with_local_level_gen] shall call [with_new_pool] to create + a new pool at a given level. On return it shall process all nodes + that were added to the pool. + Remark: the only function adding to a pool is [add_to_pool], and + the only function returning the contents of a pool is [with_new_pool], + so that the initial pool can be added to, but never read from. *) + +type pool = {level: int; mutable pool: transient_expr list; next: pool} +(* To avoid an indirection we choose to add a dummy level at the end of + the list. It will never be accessed, as [pool_of_level] is always called + with [level >= 0]. *) +let rec dummy = {level = max_int; pool = []; next = dummy} +let pool_stack = s_table (fun () -> {level = 0; pool = []; next = dummy}) () + +(* Lookup in the stack is linear, but the depth is the number of nested + generalization points (e.g. lhs of let-definitions), which in ML is known + to be generally low. In most cases we are allocating in the topmost pool. + In [Ctype.with_local_gen], we move non-generalizable type nodes from the + topmost pool to one deeper in the stack, so that for each type node the + accumulated depth of lookups over its life is bounded by the depth of + the stack when it was allocated. + In case this linear search turns out to be costly, we could switch to + binary search, exploiting the fact that the levels of pools in the stack + are expected to grow. *) +let rec pool_of_level level pool = + if level >= pool.level then pool else pool_of_level level pool.next + +(* Create a new pool at given level, and use it locally. *) +let with_new_pool ~level f = + let pool = {level; pool = []; next = !pool_stack} in + let r = + Misc.protect_refs [ R(pool_stack, pool) ] f + in + (r, pool.pool) + +let add_to_pool ~level ty = + if level >= generic_level || level <= lowest_level then () else + let pool = pool_of_level level !pool_stack in + pool.pool <- ty :: pool.pool (**** Some type creators ****) +let newty3 ~level ~scope desc = + let ty = proto_newty3 ~level ~scope desc in + add_to_pool ~level ty; + Transient_expr.type_expr ty + +let newty2 ~level desc = + newty3 ~level ~scope:Ident.lowest_scope desc + let newgenty desc = newty2 ~level:generic_level desc let newgenvar ?name () = newgenty (Tvar name) let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) -(* -let newmarkedvar level = - incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } -let newmarkedgenvar () = - incr new_id; - { desc = Tvar; level = pivot_level - generic_level; id = !new_id } -*) - (**** Check some types ****) let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false +let is_poly_Tpoly ty = + match get_desc ty with Tpoly (_, _ :: _) -> true | _ -> false let type_kind_is_abstract decl = match decl.type_kind with Type_abstract _ -> true | _ -> false let type_origin decl = match decl.type_kind with | Type_abstract origin -> origin | Type_variant _ | Type_record _ | Type_open -> Definition +let label_is_poly lbl = is_poly_Tpoly lbl.lbl_arg let dummy_method = "*dummy method*" @@ -238,7 +277,6 @@ let set_static_row_name decl path = set_type_desc ty (Tvariant row) | _ -> () - (**********************************) (* Utilities for type traversal *) (**********************************) @@ -303,24 +341,6 @@ let rec iter_abbrev f = function | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem | Mlink rem -> iter_abbrev f !rem -type type_iterators = - { it_signature: type_iterators -> signature -> unit; - it_signature_item: type_iterators -> signature_item -> unit; - it_value_description: type_iterators -> value_description -> unit; - it_type_declaration: type_iterators -> type_declaration -> unit; - it_extension_constructor: type_iterators -> extension_constructor -> unit; - it_module_declaration: type_iterators -> module_declaration -> unit; - it_modtype_declaration: type_iterators -> modtype_declaration -> unit; - it_class_declaration: type_iterators -> class_declaration -> unit; - it_class_type_declaration: type_iterators -> class_type_declaration -> unit; - it_functor_param: type_iterators -> functor_parameter -> unit; - it_module_type: type_iterators -> module_type -> unit; - it_class_type: type_iterators -> class_type -> unit; - it_type_kind: type_iterators -> type_decl_kind -> unit; - it_do_type_expr: type_iterators -> type_expr -> unit; - it_type_expr: type_iterators -> type_expr -> unit; - it_path: Path.t -> unit; } - let iter_type_expr_cstr_args f = function | Cstr_tuple tl -> List.iter f tl | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls @@ -344,8 +364,44 @@ let iter_type_expr_kind f = function | Type_open -> () + (**********************************) + (* Utilities for marking *) + (**********************************) -let type_iterators = +let rec mark_type mark ty = + if try_mark_node mark ty then iter_type_expr (mark_type mark) ty + +let mark_type_params mark ty = + iter_type_expr (mark_type mark) ty + + (**********************************) + (* (Object-oriented) iterator *) + (**********************************) + +type 'a type_iterators = + { it_signature: 'a type_iterators -> signature -> unit; + it_signature_item: 'a type_iterators -> signature_item -> unit; + it_value_description: 'a type_iterators -> value_description -> unit; + it_type_declaration: 'a type_iterators -> type_declaration -> unit; + it_extension_constructor: + 'a type_iterators -> extension_constructor -> unit; + it_module_declaration: 'a type_iterators -> module_declaration -> unit; + it_modtype_declaration: 'a type_iterators -> modtype_declaration -> unit; + it_class_declaration: 'a type_iterators -> class_declaration -> unit; + it_class_type_declaration: + 'a type_iterators -> class_type_declaration -> unit; + it_functor_param: 'a type_iterators -> functor_parameter -> unit; + it_module_type: 'a type_iterators -> module_type -> unit; + it_class_type: 'a type_iterators -> class_type -> unit; + it_type_kind: 'a type_iterators -> type_decl_kind -> unit; + it_do_type_expr: 'a type_iterators -> 'a; + it_type_expr: 'a type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; } + +type type_iterators_full = (type_expr -> unit) type_iterators +type type_iterators_without_type_expr = (unit -> unit) type_iterators + +let type_iterators_without_type_expr = let it_signature it = List.iter (it.it_signature_item it) and it_signature_item it = function @@ -406,6 +462,17 @@ let type_iterators = it.it_class_type it cty and it_type_kind it kind = iter_type_expr_kind (it.it_type_expr it) kind + and it_path _p = () + in + { it_path; it_type_expr = (fun _ _ -> ()); it_do_type_expr = (fun _ _ -> ()); + it_type_kind; it_class_type; it_functor_param; it_module_type; + it_signature; it_class_type_declaration; it_class_declaration; + it_modtype_declaration; it_module_declaration; it_extension_constructor; + it_type_declaration; it_value_description; it_signature_item; } + +let type_iterators mark = + let it_type_expr it ty = + if try_mark_node mark ty then it.it_do_type_expr it ty and it_do_type_expr it ty = iter_type_expr (it.it_type_expr it) ty; match get_desc ty with @@ -416,13 +483,12 @@ let type_iterators = | Tvariant row -> Option.iter (fun (p,_) -> it.it_path p) (row_name row) | _ -> () - and it_path _p = () in - { it_path; it_type_expr = it_do_type_expr; it_do_type_expr; - it_type_kind; it_class_type; it_functor_param; it_module_type; - it_signature; it_class_type_declaration; it_class_declaration; - it_modtype_declaration; it_module_declaration; it_extension_constructor; - it_type_declaration; it_value_description; it_signature_item; } + {type_iterators_without_type_expr with it_type_expr; it_do_type_expr} + + (**********************************) + (* Utilities for copying *) + (**********************************) let copy_row f fixed row keep more = let Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} = @@ -468,8 +534,7 @@ let rec copy_type_desc ?(keep_names=false) f = function Tpoly (f ty, tyl) | Tpackage (p, fl) -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl) -(* Utilities for copying *) - +(* TODO: rename to [module Copy_scope] *) module For_copy : sig type copy_scope @@ -712,6 +777,7 @@ let instance_variable_type label sign = | (_, _, ty) -> ty | exception Not_found -> assert false +<<<<<<< (**********************************) (* Utilities for level-marking *) (**********************************) @@ -768,9 +834,12 @@ let unmark_class_signature sign = unmark_type sign.csig_self_row; Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars; Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths +======= +>>>>>>> -let unmark_class_type cty = - unmark_iterators.it_class_type unmark_iterators cty + (**********) + (* Misc *) + (**********) (**** Type information getter ****) diff --git a/src/ocaml/typing/btype.mli b/src/ocaml/typing/btype.mli index 71dd67b74..224dc2e6c 100644 --- a/src/ocaml/typing/btype.mli +++ b/src/ocaml/typing/btype.mli @@ -58,6 +58,22 @@ end (**** Levels ****) val generic_level: int + (* level of polymorphic variables; = Ident.highest_scope *) +val lowest_level: int + (* lowest level for type nodes; = Ident.lowest_scope *) + +val with_new_pool: level:int -> (unit -> 'a) -> 'a * transient_expr list + (* [with_new_pool ~level f] executes [f] and returns the nodes + that were created at level [level] and above *) +val add_to_pool: level:int -> transient_expr -> unit + (* Add a type node to the pool associated to the level (which should + be the level of the type node). + Do nothing if [level = generic_level] or [level = lowest_level]. *) + +val newty3: level:int -> scope:int -> type_desc -> type_expr + (* Create a type with a fresh id *) +val newty2: level:int -> type_desc -> type_expr + (* Create a type with a fresh id and no scope *) val newgenty: type_desc -> type_expr (* Create a generic type *) @@ -67,21 +83,16 @@ val newgenstub: scope:int -> type_expr (* Return a fresh generic node, to be instantiated by [Transient_expr.set_stub_desc] *) -(* Use Tsubst instead -val newmarkedvar: int -> type_expr - (* Return a fresh marked variable *) -val newmarkedgenvar: unit -> type_expr - (* Return a fresh marked generic variable *) -*) - (**** Types ****) val is_Tvar: type_expr -> bool val is_Tunivar: type_expr -> bool val is_Tconstr: type_expr -> bool +val is_poly_Tpoly: type_expr -> bool val dummy_method: label val type_kind_is_abstract: type_declaration -> bool -val type_origin : type_declaration -> type_origin +val type_origin: type_declaration -> type_origin +val label_is_poly: label_description -> bool (**** polymorphic variants ****) @@ -136,29 +147,47 @@ val iter_type_expr_cstr_args: (type_expr -> unit) -> val map_type_expr_cstr_args: (type_expr -> type_expr) -> (constructor_arguments -> constructor_arguments) +(**** Utilities for type marking ****) -type type_iterators = - { it_signature: type_iterators -> signature -> unit; - it_signature_item: type_iterators -> signature_item -> unit; - it_value_description: type_iterators -> value_description -> unit; - it_type_declaration: type_iterators -> type_declaration -> unit; - it_extension_constructor: type_iterators -> extension_constructor -> unit; - it_module_declaration: type_iterators -> module_declaration -> unit; - it_modtype_declaration: type_iterators -> modtype_declaration -> unit; - it_class_declaration: type_iterators -> class_declaration -> unit; - it_class_type_declaration: type_iterators -> class_type_declaration -> unit; - it_functor_param: type_iterators -> functor_parameter -> unit; - it_module_type: type_iterators -> module_type -> unit; - it_class_type: type_iterators -> class_type -> unit; - it_type_kind: type_iterators -> type_decl_kind -> unit; - it_do_type_expr: type_iterators -> type_expr -> unit; - it_type_expr: type_iterators -> type_expr -> unit; +val mark_type: type_mark -> type_expr -> unit + (* Mark a type recursively *) +val mark_type_params: type_mark -> type_expr -> unit + (* Mark the sons of a type node recursively *) + +(**** (Object-oriented) iterator ****) + +type 'a type_iterators = + { it_signature: 'a type_iterators -> signature -> unit; + it_signature_item: 'a type_iterators -> signature_item -> unit; + it_value_description: 'a type_iterators -> value_description -> unit; + it_type_declaration: 'a type_iterators -> type_declaration -> unit; + it_extension_constructor: + 'a type_iterators -> extension_constructor -> unit; + it_module_declaration: 'a type_iterators -> module_declaration -> unit; + it_modtype_declaration: 'a type_iterators -> modtype_declaration -> unit; + it_class_declaration: 'a type_iterators -> class_declaration -> unit; + it_class_type_declaration: + 'a type_iterators -> class_type_declaration -> unit; + it_functor_param: 'a type_iterators -> functor_parameter -> unit; + it_module_type: 'a type_iterators -> module_type -> unit; + it_class_type: 'a type_iterators -> class_type -> unit; + it_type_kind: 'a type_iterators -> type_decl_kind -> unit; + it_do_type_expr: 'a type_iterators -> 'a; + it_type_expr: 'a type_iterators -> type_expr -> unit; it_path: Path.t -> unit; } -val type_iterators: type_iterators - (* Iteration on arbitrary type information. + +type type_iterators_full = (type_expr -> unit) type_iterators +type type_iterators_without_type_expr = (unit -> unit) type_iterators + +val type_iterators: type_mark -> type_iterators_full + (* Iteration on arbitrary type information, including [type_expr]. [it_type_expr] calls [mark_node] to avoid loops. *) -val unmark_iterators: type_iterators - (* Unmark any structure containing types. See [unmark_type] below. *) + +val type_iterators_without_type_expr: type_iterators_without_type_expr + (* Iteration on arbitrary type information. + Cannot recurse on [type_expr]. *) + +(**** Utilities for copying ****) val copy_type_desc: ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc @@ -184,41 +213,6 @@ module For_copy : sig before returning its result. *) end -val lowest_level: int - (* Marked type: ty.level < lowest_level *) - -val not_marked_node: type_expr -> bool - (* Return true if a type node is not yet marked *) - -val logged_mark_node: type_expr -> unit - (* Mark a type node, logging the marking so it can be backtracked *) -val try_logged_mark_node: type_expr -> bool - (* Mark a type node if it is not yet marked, logging the marking so it - can be backtracked. - Return false if it was already marked *) - -val flip_mark_node: type_expr -> unit - (* Mark a type node. - The marking is not logged and will have to be manually undone using - one of the various [unmark]'ing functions below. *) -val try_mark_node: type_expr -> bool - (* Mark a type node if it is not yet marked. - The marking is not logged and will have to be manually undone using - one of the various [unmark]'ing functions below. - - Return false if it was already marked *) -val mark_type: type_expr -> unit - (* Mark a type recursively *) -val mark_type_params: type_expr -> unit - (* Mark the sons of a type node recursively *) - -val unmark_type: type_expr -> unit -val unmark_type_decl: type_declaration -> unit -val unmark_extension_constructor: extension_constructor -> unit -val unmark_class_type: class_type -> unit -val unmark_class_signature: class_signature -> unit - (* Remove marks from a type *) - (**** Memorization of abbreviation expansion ****) val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option @@ -311,9 +305,6 @@ val method_type : label -> class_signature -> type_expr @raises [Assert_failure] if the class has no such method. *) val instance_variable_type : label -> class_signature -> type_expr -(**** Forward declarations ****) -val print_raw: (Format.formatter -> type_expr -> unit) ref - (**** Type information getter ****) val cstr_type_path : constructor_description -> Path.t diff --git a/src/ocaml/typing/ctype.ml b/src/ocaml/typing/ctype.ml index 970c637a9..a48ff1277 100644 --- a/src/ocaml/typing/ctype.ml +++ b/src/ocaml/typing/ctype.ml @@ -23,16 +23,6 @@ open Errortrace open Local_store -(* - Type manipulation after type inference - ====================================== - If one wants to manipulate a type after type inference (for - instance, during code generation or in the debugger), one must - first make sure that the type levels are correct, using the - function [correct_levels]. Then, this type can be correctly - manipulated by [apply], [expand_head] and [moregeneral]. -*) - (* General notes ============= @@ -119,10 +109,11 @@ let raise_scope_escape_exn ty = raise (scope_escape_exn ty) exception Tags of label * label let () = + let open Format_doc in Location.register_error_of_exn (function | Tags (l, l') -> - let pp_tag ppf s = Format.fprintf ppf "`%s" s in + let pp_tag ppf s = fprintf ppf "`%s" s in let inline_tag = Misc.Style.as_inline_code pp_tag in Some Location. @@ -146,6 +137,32 @@ exception Matches_failure of Env.t * unification_error exception Incompatible +(**** Control tracing of GADT instances *) + +let trace_gadt_instances = ref false +let check_trace_gadt_instances env = + not !trace_gadt_instances && Env.has_local_constraints env && + (trace_gadt_instances := true; cleanup_abbrev (); true) + +let reset_trace_gadt_instances b = + if b then trace_gadt_instances := false + +let wrap_trace_gadt_instances env f x = + let b = check_trace_gadt_instances env in + let y = f x in + reset_trace_gadt_instances b; + y + +(**** Abbreviations without parameters ****) +(* Shall reset after generalizing *) + +let simple_abbrevs = ref Mnil + +let proper_abbrevs tl abbrev = + if tl <> [] || !trace_gadt_instances || !Clflags.principal + then abbrev + else simple_abbrevs + (**** Type level management ****) let current_level = s_ref 0 @@ -186,10 +203,77 @@ let end_def () = saved_level := List.tl !saved_level; current_level := cl; nongen_level := nl let create_scope () = - init_def (!current_level + 1); - !current_level + let level = !current_level + 1 in + init_def level; + level let wrap_end_def f = Misc.try_finally f ~always:end_def +let wrap_end_def_new_pool f = + wrap_end_def (fun _ -> with_new_pool ~level:!current_level f) + +(* [with_local_level_gen] handles both the scoping structure of levels + and automatic generalization through pools (cf. btype.ml) *) +let with_local_level_gen ~begin_def ~structure ?before_generalize f = + begin_def (); + let level = !current_level in + let result, pool = wrap_end_def_new_pool f in + Option.iter (fun g -> g result) before_generalize; + simple_abbrevs := Mnil; + (* Nodes in [pool] were either created by the above call to [f], + or they were created before, generalized, and then added to + the pool by [update_level]. + In the latter case, their level was already kept for backtracking + by a call to [set_level] inside [update_level]. + Since backtracking can only go back to a snapshot taken before [f] was + called, this means that either they did not exists in that snapshot, + or that they original level is already stored, so that there is no need + to register levels for backtracking when we change them with + [Transient_expr.set_level] here *) + List.iter begin fun ty -> + (* Already generic nodes are not tracked *) + if ty.level = generic_level then () else + match ty.desc with + | Tvar _ when structure -> + (* In structure mode, we do do not generalize type variables, + so we need to lower their level, and move them to an outer pool. + The goal of this mode is to allow unsharing inner nodes + without introducing polymorphism *) + if ty.level >= level then Transient_expr.set_level ty !current_level; + add_to_pool ~level:ty.level ty + | Tlink _ -> () + (* If a node is no longer used as representative, no need + to track it anymore *) + | _ -> + if ty.level < level then + (* If a node was introduced locally, but its level was lowered + through unification, keeping that node as representative, + then we need to move it to an outer pool. *) + add_to_pool ~level:ty.level ty + else begin + (* Generalize all remaining nodes *) + Transient_expr.set_level ty generic_level; + if structure then match ty.desc with + Tconstr (_, _, abbrev) -> + (* In structure mode, we drop abbreviations, as the goal of + this mode is to reduce sharing *) + abbrev := Mnil + | _ -> () + end + end pool; + result + +let with_local_level_generalize_structure f = + with_local_level_gen ~begin_def ~structure:true f +let with_local_level_generalize ?before_generalize f = + with_local_level_gen ~begin_def ~structure:false ?before_generalize f +let with_local_level_generalize_if cond ?before_generalize f = + if cond then with_local_level_generalize ?before_generalize f else f () +let with_local_level_generalize_structure_if cond f = + if cond then with_local_level_generalize_structure f else f () +let with_local_level_generalize_structure_if_principal f = + if !Clflags.principal then with_local_level_generalize_structure f else f () +let with_local_level_generalize_for_class f = + with_local_level_gen ~begin_def:begin_class_def ~structure:false f let with_local_level ?post f = begin_def (); @@ -200,7 +284,7 @@ let with_local_level_if cond f ~post = if cond then with_local_level f ~post else f () let with_local_level_iter f ~post = begin_def (); - let result, l = wrap_end_def f in + let (result, l) = wrap_end_def f in List.iter post l; result let with_local_level_iter_if cond f ~post = @@ -211,8 +295,7 @@ let with_local_level_iter_if_principal f ~post = with_local_level_iter_if !Clflags.principal f ~post let with_level ~level f = begin_def (); init_def level; - let result = wrap_end_def f in - result + wrap_end_def f let with_level_if cond ~level f = if cond then with_level ~level f else f () @@ -236,32 +319,6 @@ let increase_global_level () = let restore_global_level gl = global_level := gl -(**** Control tracing of GADT instances *) - -let trace_gadt_instances = ref false -let check_trace_gadt_instances env = - not !trace_gadt_instances && Env.has_local_constraints env && - (trace_gadt_instances := true; cleanup_abbrev (); true) - -let reset_trace_gadt_instances b = - if b then trace_gadt_instances := false - -let wrap_trace_gadt_instances env f x = - let b = check_trace_gadt_instances env in - let y = f x in - reset_trace_gadt_instances b; - y - -(**** Abbreviations without parameters ****) -(* Shall reset after generalizing *) - -let simple_abbrevs = ref Mnil - -let proper_abbrevs tl abbrev = - if tl <> [] || !trace_gadt_instances || !Clflags.principal - then abbrev - else simple_abbrevs - (**** Some type creators ****) (* Re-export generic type creators *) @@ -567,9 +624,9 @@ exception Non_closed of type_expr * variable_kind [free_variables] below drops the type/row information and only returns a [variable list]. *) -let free_vars ?env ty = +let free_vars ?env mark ty = let rec fv ~kind acc ty = - if not (try_mark_node ty) then acc + if not (try_mark_node mark ty) then acc else match get_desc ty, env with | Tvar _, _ -> (ty, kind) :: acc @@ -598,26 +655,22 @@ let free_vars ?env ty = in fv ~kind:Type_variable [] ty let free_variables ?env ty = - let tl = List.map fst (free_vars ?env ty) in - unmark_type ty; - tl + with_type_mark (fun mark -> List.map fst (free_vars ?env mark ty)) -let closed_type ty = - match free_vars ty with +let closed_type mark ty = + match free_vars mark ty with [] -> () | (v, real) :: _ -> raise (Non_closed (v, real)) let closed_parameterized_type params ty = - List.iter mark_type params; - let ok = - try closed_type ty; true with Non_closed _ -> false in - List.iter unmark_type params; - unmark_type ty; - ok + with_type_mark begin fun mark -> + List.iter (mark_type mark) params; + try closed_type mark ty; true with Non_closed _ -> false + end let closed_type_decl decl = - try - List.iter mark_type decl.type_params; + with_type_mark begin fun mark -> try + List.iter (mark_type mark) decl.type_params; begin match decl.type_kind with Type_abstract _ -> () @@ -628,36 +681,35 @@ let closed_type_decl decl = | Some _ -> () | None -> match cd_args with - | Cstr_tuple l -> List.iter closed_type l - | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l + | Cstr_tuple l -> List.iter (closed_type mark) l + | Cstr_record l -> + List.iter (fun l -> closed_type mark l.ld_type) l ) v | Type_record(r, _rep) -> - List.iter (fun l -> closed_type l.ld_type) r + List.iter (fun l -> closed_type mark l.ld_type) r | Type_open -> () end; begin match decl.type_manifest with None -> () - | Some ty -> closed_type ty + | Some ty -> closed_type mark ty end; - unmark_type_decl decl; None with Non_closed (ty, _) -> - unmark_type_decl decl; Some ty + end let closed_extension_constructor ext = - try - List.iter mark_type ext.ext_type_params; + with_type_mark begin fun mark -> try + List.iter (mark_type mark) ext.ext_type_params; begin match ext.ext_ret_type with | Some _ -> () - | None -> iter_type_expr_cstr_args closed_type ext.ext_args + | None -> iter_type_expr_cstr_args (closed_type mark) ext.ext_args end; - unmark_extension_constructor ext; None with Non_closed (ty, _) -> - unmark_extension_constructor ext; Some ty + end type closed_class_failure = { free_variable: type_expr * variable_kind; @@ -667,13 +719,14 @@ type closed_class_failure = { exception CCFailure of closed_class_failure let closed_class params sign = - List.iter mark_type params; - ignore (try_mark_node sign.csig_self_row); + with_type_mark begin fun mark -> + List.iter (mark_type mark) params; + ignore (try_mark_node mark sign.csig_self_row); try Meths.iter (fun lab (priv, _, ty) -> if priv = Mpublic then begin - try closed_type ty with Non_closed (ty0, variable_kind) -> + try closed_type mark ty with Non_closed (ty0, variable_kind) -> raise (CCFailure { free_variable = (ty0, variable_kind); meth = lab; @@ -681,14 +734,10 @@ let closed_class params sign = }) end) sign.csig_meths; - List.iter unmark_type params; - unmark_class_signature sign; None with CCFailure reason -> - List.iter unmark_type params; - unmark_class_signature sign; Some reason - + end (**********************) (* Type duplication *) @@ -708,76 +757,53 @@ let duplicate_class_type ty = (* Type level manipulation *) (*****************************) -(* - It would be a bit more efficient to remove abbreviation expansions - rather than generalizing them: these expansions will usually not be - used anymore. However, this is not possible in the general case, as - [expand_abbrev] (via [subst]) requires these expansions to be - preserved. Does it worth duplicating this code ? -*) -let rec generalize ty = - let level = get_level ty in - if (level > !current_level) && (level <> generic_level) then begin - set_level ty generic_level; - (* recur into abbrev for the speed *) - begin match get_desc ty with - Tconstr (_, _, abbrev) -> - iter_abbrev generalize !abbrev - | _ -> () - end; - iter_type_expr generalize ty - end - -let generalize ty = - simple_abbrevs := Mnil; - generalize ty - -(* Generalize the structure and lower the variables *) -let rec generalize_structure ty = - let level = get_level ty in - if level <> generic_level then begin - if is_Tvar ty && level > !current_level then - set_level ty !current_level - else if level > !current_level then begin - begin match get_desc ty with - Tconstr (_, _, abbrev) -> - abbrev := Mnil - | _ -> () - end; - set_level ty generic_level; - iter_type_expr generalize_structure ty - end - end - -let generalize_structure ty = - simple_abbrevs := Mnil; - generalize_structure ty - -(* Generalize the spine of a function, if the level >= !current_level *) +(* + Build a copy of a type in which nodes reachable through a path composed + only of Tarrow, Tpoly, Ttuple, Tpackage and Tconstr, and whose level + was no lower than [!current_level], are at [generic_level]. + This is different from [with_local_level_gen], which generalizes in place, + and only nodes with a level higher than [!current_level]. + This is used for typing classes, to indicate which types have been + inferred in the first pass, and can be considered as "known" during the + second pass. + *) -let rec generalize_spine ty = - let level = get_level ty in - if level < !current_level || level = generic_level then () else +let rec copy_spine copy_scope ty = match get_desc ty with - Tarrow (_, ty1, ty2, _) -> - set_level ty generic_level; - generalize_spine ty1; - generalize_spine ty2; - | Tpoly (ty', _) -> - set_level ty generic_level; - generalize_spine ty' - | Ttuple tyl -> - set_level ty generic_level; - List.iter generalize_spine tyl - | Tpackage (_, fl) -> - set_level ty generic_level; - List.iter (fun (_n, ty) -> generalize_spine ty) fl - | Tconstr (_, tyl, memo) -> - set_level ty generic_level; - memo := Mnil; - List.iter generalize_spine tyl - | _ -> () + | Tsubst (ty, _) -> ty + | Tvar _ + | Tfield _ + | Tnil + | Tvariant _ + | Tobject _ + | Tlink _ + | Tunivar _ -> ty + | (Tarrow _ | Tpoly _ | Ttuple _ | Tpackage _ | Tconstr _) as desc -> + let level = get_level ty in + if level < !current_level || level = generic_level then ty else + let t = newgenstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let copy_rec = copy_spine copy_scope in + let desc' = match desc with + | Tarrow (lbl, ty1, ty2, _) -> + Tarrow (lbl, copy_rec ty1, copy_rec ty2, commu_ok) + | Tpoly (ty', tvl) -> + Tpoly (copy_rec ty', tvl) + | Ttuple tyl -> + Ttuple (List.map copy_rec tyl) + | Tpackage (path, fl) -> + let fl = List.map (fun (n, ty) -> n, copy_rec ty) fl in + Tpackage (path, fl) + | Tconstr (path, tyl, _) -> + Tconstr (path, List.map copy_rec tyl, ref Mnil) + | _ -> assert false + in + Transient_expr.set_stub_desc t desc'; + t + +let copy_spine ty = + For_copy.with_scope (fun copy_scope -> copy_spine copy_scope ty) let forward_try_expand_safe = (* Forward declaration *) ref (fun _env _ty -> assert false) @@ -804,35 +830,35 @@ let rec normalize_package_path env p = normalize_package_path env (Path.Pdot (p1', s)) | _ -> p -let rec check_scope_escape env level ty = +let rec check_scope_escape mark env level ty = let orig_level = get_level ty in - if try_logged_mark_node ty then begin + if try_mark_node mark ty then begin if level < get_scope ty then raise_scope_escape_exn ty; begin match get_desc ty with | Tconstr (p, _, _) when level < Path.scope p -> begin match !forward_try_expand_safe env ty with | ty' -> - check_scope_escape env level ty' + check_scope_escape mark env level ty' | exception Cannot_expand -> raise_escape_exn (Constructor p) end | Tpackage (p, fl) when level < Path.scope p -> let p' = normalize_package_path env p in if Path.same p p' then raise_escape_exn (Module_type p); - check_scope_escape env level + check_scope_escape mark env level (newty2 ~level:orig_level (Tpackage (p', fl))) | _ -> - iter_type_expr (check_scope_escape env level) ty + iter_type_expr (check_scope_escape mark env level) ty end; end let check_scope_escape env level ty = - let snap = snapshot () in - try check_scope_escape env level ty; backtrack snap + with_type_mark begin fun mark -> try + check_scope_escape mark env level ty with Escape e -> - backtrack snap; raise (Escape { e with context = Some ty }) + end let rec update_scope scope ty = if get_scope ty < scope then begin @@ -856,8 +882,14 @@ let update_scope_for tr_exn scope ty = *) let rec update_level env level expand ty = - if get_level ty > level then begin + let ty_level = get_level ty in + if ty_level > level then begin if level < get_scope ty then raise_scope_escape_exn ty; + let set_level () = + set_level ty level; + if ty_level = generic_level then + add_to_pool ~level (Transient_expr.repr ty) + in match get_desc ty with Tconstr(p, _tl, _abbrev) when level < Path.scope p -> (* Try first to replace an abbreviation by its expansion. *) @@ -884,7 +916,7 @@ let rec update_level env level expand ty = link_type ty ty'; update_level env level expand ty' with Cannot_expand -> - set_level ty level; + set_level (); iter_type_expr (update_level env level expand) ty end | Tpackage (p, fl) when level < Path.scope p -> @@ -902,13 +934,13 @@ let rec update_level env level expand ty = set_type_desc ty (Tvariant (set_row_name row None)) | _ -> () end; - set_level ty level; + set_level (); iter_type_expr (update_level env level expand) ty | Tfield(lab, _, ty1, _) when lab = dummy_method && level < get_scope ty1 -> raise_escape_exn Self | _ -> - set_level ty level; + set_level (); (* XXX what about abbreviations in Tconstr ? *) iter_type_expr (update_level env level expand) ty end @@ -987,11 +1019,11 @@ let lower_contravariant env ty = simple_abbrevs := Mnil; lower_contravariant env !nongen_level (Hashtbl.create 7) false ty -let rec generalize_class_type' gen = +let rec generalize_class_type gen = function Cty_constr (_, params, cty) -> List.iter gen params; - generalize_class_type' gen cty + generalize_class_type gen cty | Cty_signature csig -> gen csig.csig_self; gen csig.csig_self_row; @@ -999,20 +1031,10 @@ let rec generalize_class_type' gen = Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths | Cty_arrow (_, ty, cty) -> gen ty; - generalize_class_type' gen cty - -let generalize_class_type cty = - generalize_class_type' generalize cty - -let generalize_class_type_structure cty = - generalize_class_type' generalize_structure cty - -(* Correct the levels of type [ty]. *) -let correct_levels ty = - duplicate_type ty + generalize_class_type gen cty (* Only generalize the type ty0 in ty *) -let limited_generalize ty0 ty = +let limited_generalize ty0 ~inside:ty = let graph = TypeHash.create 17 in let roots = ref [] in @@ -1052,8 +1074,8 @@ let limited_generalize ty0 ty = if get_level ty <> generic_level then set_level ty !current_level) graph -let limited_generalize_class_type rv cty = - generalize_class_type' (limited_generalize rv) cty +let limited_generalize_class_type rv ~inside:cty = + generalize_class_type (fun inside -> limited_generalize rv ~inside) cty (* Compute statically the free univars of all nodes in a type *) (* This avoids doing it repeatedly during instantiation *) @@ -1096,15 +1118,14 @@ let compute_univars ty = let fully_generic ty = - let rec aux ty = - if not_marked_node ty then - if get_level ty = generic_level then - (flip_mark_node ty; iter_type_expr aux ty) - else raise Exit - in - let res = try aux ty; true with Exit -> false in - unmark_type ty; - res + with_type_mark begin fun mark -> + let rec aux ty = + if try_mark_node mark ty then + if get_level ty = generic_level then iter_type_expr aux ty + else raise Exit + in + try aux ty; true with Exit -> false + end (*******************) @@ -1261,11 +1282,7 @@ let instance ?partial sch = copy ?partial copy_scope sch) let generic_instance sch = - let old = !current_level in - current_level := generic_level; - let ty = instance sch in - current_level := old; - ty + with_level ~level:generic_level (fun () -> instance sch) let instance_list schl = For_copy.with_scope (fun copy_scope -> @@ -1306,7 +1323,7 @@ let new_local_type ?(loc = Location.none) ?manifest_and_scope origin = type_attributes = []; type_immediate = Unknown; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } let existential_name name_counter ty = @@ -1388,11 +1405,7 @@ let instance_declaration decl = ) let generic_instance_declaration decl = - let old = !current_level in - current_level := generic_level; - let decl = instance_declaration decl in - current_level := old; - decl + with_level ~level:generic_level (fun () -> instance_declaration decl) let instance_class params cty = let rec copy_class_type copy_scope = function @@ -1533,33 +1546,31 @@ let unify_var' = (* Forward declaration *) let subst env level priv abbrev oty params args body = if List.length params <> List.length args then raise Cannot_subst; - let old_level = !current_level in - current_level := level; - let body0 = newvar () in (* Stub *) - let undo_abbrev = - match oty with - | None -> fun () -> () (* No abbreviation added *) - | Some ty -> - match get_desc ty with - Tconstr (path, tl, _) -> - let abbrev = proper_abbrevs tl abbrev in - memorize_abbrev abbrev priv path ty body0; - fun () -> forget_abbrev abbrev path - | _ -> assert false - in - abbreviations := abbrev; - let (params', body') = instance_parameterized_type params body in - abbreviations := ref Mnil; - let uenv = Expression {env; in_subst = true} in - try - !unify_var' uenv body0 body'; - List.iter2 (!unify_var' uenv) params' args; - current_level := old_level; - body' - with Unify _ -> - current_level := old_level; - undo_abbrev (); - raise Cannot_subst + with_level ~level begin fun () -> + let body0 = newvar () in (* Stub *) + let undo_abbrev = + match oty with + | None -> fun () -> () (* No abbreviation added *) + | Some ty -> + match get_desc ty with + Tconstr (path, tl, _) -> + let abbrev = proper_abbrevs tl abbrev in + memorize_abbrev abbrev priv path ty body0; + fun () -> forget_abbrev abbrev path + | _ -> assert false + in + abbreviations := abbrev; + let (params', body') = instance_parameterized_type params body in + abbreviations := ref Mnil; + let uenv = Expression {env; in_subst = true} in + try + !unify_var' uenv body0 body'; + List.iter2 (!unify_var' uenv) params' args; + body' + with Unify _ -> + undo_abbrev (); + raise Cannot_subst + end (* Default to generic level. Usually, only the shape of the type matters, not @@ -1800,8 +1811,8 @@ let full_expand ~may_forget_scope env ty = (* #10277: forget scopes when printing trace *) with_level ~level:(get_level ty) begin fun () -> (* The same as [expand_head], except in the failing case we return the - *original* type, not [correct_levels ty].*) - try try_expand_head try_expand_safe env (correct_levels ty) with + *original* type, not [duplicate_type ty].*) + try try_expand_head try_expand_safe env (duplicate_type ty) with | Cannot_expand -> ty end else expand_head env ty @@ -1953,6 +1964,17 @@ let local_non_recursive_abbrev uenv p ty = (* Polymorphic Unification *) (*****************************) +(* Polymorphic unification is hard in the presence of recursive types. A + correctness argument for the approach below can be made by reference to + "Numbering matters: first-order canonical forms for second-order recursive + types" (ICFP'04) by Gauthier & Pottier. That work describes putting numbers + on nodes; we do not do that here, but instead make a decision about whether + to abort or continue based on the comparison of the numbers if we calculated + them. A different approach would actually store the relevant numbers in the + [Tpoly] nodes. (The algorithm here actually pre-dates that paper, which was + developed independently. But reading and understanding the paper will help + guide intuition for reading this algorithm nonetheless.) *) + (* Since we cannot duplicate universal variables, unification must be done at meta-level, using bindings in univar_pairs *) let rec unify_univar t1 t2 = function @@ -1972,7 +1994,8 @@ let rec unify_univar t1 t2 = function | _ -> raise Cannot_unify_universal_variables end - | [] -> raise Cannot_unify_universal_variables + | [] -> + Misc.fatal_error "Ctype.unify_univar: univar not in scope" (* The same as [unify_univar], but raises the appropriate exception instead of [Cannot_unify_universal_variables] *) @@ -1985,10 +2008,11 @@ let unify_univar_for tr_exn t1 t2 univar_pairs = (* If [inj_only=true], only check injective positions *) let occur_univar ?(inj_only=false) env ty = let visited = ref TypeMap.empty in + with_type_mark begin fun mark -> let rec occur_rec bound ty = - if not_marked_node ty then + if not_marked_node mark ty then if TypeSet.is_empty bound then - (flip_mark_node ty; occur_desc bound ty) + (ignore (try_mark_node mark ty); occur_desc bound ty) else try let bound' = TypeMap.find ty !visited in if not (TypeSet.subset bound' bound) then begin @@ -2027,10 +2051,8 @@ let occur_univar ?(inj_only=false) env ty = end | _ -> iter_type_expr (occur_rec bound) ty in - Misc.try_finally (fun () -> - occur_rec TypeSet.empty ty - ) - ~always:(fun () -> unmark_type ty) + occur_rec TypeSet.empty ty + end let has_free_univars env ty = try occur_univar ~inj_only:false env ty; false with Escape _ -> true @@ -2061,10 +2083,9 @@ let get_univar_family univar_pairs univars = (* Whether a family of univars escapes from a type *) let univars_escape env univar_pairs vl ty = let family = get_univar_family univar_pairs vl in - let visited = ref TypeSet.empty in + with_type_mark begin fun mark -> let rec occur t = - if TypeSet.mem t !visited then () else begin - visited := TypeSet.add t !visited; + if try_mark_node mark t then begin match get_desc t with Tpoly (t, tl) -> if List.exists (fun t -> TypeSet.mem t family) tl then () @@ -2086,9 +2107,18 @@ let univars_escape env univar_pairs vl ty = end in occur ty + end + +let univar_pairs = ref [] + +let with_univar_pairs pairs f = + let old = !univar_pairs in + univar_pairs := pairs; + Misc.try_finally f + ~always:(fun () -> univar_pairs := old) (* Wrapper checking that no variable escapes and updating univar_pairs *) -let enter_poly env univar_pairs t1 tl1 t2 tl2 f = +let enter_poly env t1 tl1 t2 tl2 f = let old_univars = !univar_pairs in let known_univars = List.fold_left (fun s (cl,_) -> add_univars s cl) @@ -2100,17 +2130,15 @@ let enter_poly env univar_pairs t1 tl1 t2 tl2 f = univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1))); let cl1 = List.map (fun t -> t, ref None) tl1 and cl2 = List.map (fun t -> t, ref None) tl2 in - univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; - Misc.try_finally (fun () -> f t1 t2) - ~always:(fun () -> univar_pairs := old_univars) + with_univar_pairs + ((cl1,cl2) :: (cl2,cl1) :: old_univars) + (fun () -> f t1 t2) -let enter_poly_for tr_exn env univar_pairs t1 tl1 t2 tl2 f = +let enter_poly_for tr_exn env t1 tl1 t2 tl2 f = try - enter_poly env univar_pairs t1 tl1 t2 tl2 f + enter_poly env t1 tl1 t2 tl2 f with Escape e -> raise_for tr_exn (Escape e) -let univar_pairs = ref [] - (**** Instantiate a generic type into a poly type ***) let polyfy env ty vars = @@ -2197,16 +2225,18 @@ let unexpanded_diff ~got ~expected = (* Return whether [t0] occurs in [ty]. Objects are also traversed. *) let deep_occur t0 ty = + with_type_mark begin fun mark -> let rec occur_rec ty = - if get_level ty >= get_level t0 && try_mark_node ty then begin + if get_level ty >= get_level t0 && try_mark_node mark ty then begin if eq_type ty t0 then raise Occur; iter_type_expr occur_rec ty end in try - occur_rec ty; unmark_type ty; false + occur_rec ty; false with Occur -> - unmark_type ty; true + true + end (* A local constraint can be added only if the rhs @@ -2291,6 +2321,21 @@ let compatible_paths p1 p2 = Path.same p1 path_bytes && Path.same p2 path_string || Path.same p1 path_string && Path.same p2 path_bytes +(* Two labels are considered compatible under certain conditions. + - they are the same + - in classic mode, only optional labels are relavant + - in pattern mode, we act as if we were in classic mode. If not, interactions + with GADTs from files compiled in classic mode would be unsound. +*) +let compatible_labels ~in_pattern_mode l1 l2 = + l1 = l2 + || (!Clflags.classic || in_pattern_mode) + && not (is_optional l1 || is_optional l2) + +let eq_labels error_mode ~in_pattern_mode l1 l2 = + if not (compatible_labels ~in_pattern_mode l1 l2) then + raise_for error_mode (Function_label_mismatch {got=l1; expected=l2}) + (* Check for datatypes carefully; see PR#6348 *) let rec expands_to_datatype env ty = match get_desc ty with @@ -2335,7 +2380,7 @@ let rec mcomp type_pairs env t1 t2 = | (_, Tvar _) -> () | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) - when l1 = l2 || not (is_optional l1 || is_optional l2) -> + when compatible_labels ~in_pattern_mode:true l1 l2 -> mcomp type_pairs env t1 t2; mcomp type_pairs env u1 u2; | (Ttuple tl1, Ttuple tl2) -> @@ -2370,7 +2415,7 @@ let rec mcomp type_pairs env t1 t2 = mcomp type_pairs env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> (try - enter_poly env univar_pairs + enter_poly env t1 tl1 t2 tl2 (mcomp type_pairs env) with Escape _ -> raise Incompatible) | (Tunivar _, Tunivar _) -> @@ -2517,14 +2562,16 @@ let mcomp_for tr_exn env t1 t2 = let find_lowest_level ty = let lowest = ref generic_level in - let rec find ty = - if not_marked_node ty then begin - let level = get_level ty in - if level < !lowest then lowest := level; - flip_mark_node ty; - iter_type_expr find ty - end - in find ty; unmark_type ty; !lowest + with_type_mark begin fun mark -> + let rec find ty = + if try_mark_node mark ty then begin + let level = get_level ty in + if level < !lowest then lowest := level; + iter_type_expr find ty + end + in find ty + end; + !lowest (* This function can be called only in [Pattern] mode. *) let add_gadt_equation uenv source destination = @@ -2571,11 +2618,7 @@ let rec concat_longident lid1 = let nondep_instance env level id ty = let ty = !nondep_type' env [id] ty in if level = generic_level then duplicate_type ty else - let old = !current_level in - current_level := level; - let ty = instance ty in - current_level := old; - ty + with_level ~level (fun () -> instance ty) (* Find the type paths nl1 in the module type mty2, and add them to the list (nl2, tl2). raise Not_found if impossible *) @@ -2627,10 +2670,10 @@ let unify_package env unify_list lv1 p1 fl1 lv2 p2 fl2 = let ntl2 = complete_type_list env fl1 lv2 (Mty_ident p2) fl2 and ntl1 = complete_type_list env fl2 lv1 (Mty_ident p1) fl1 in unify_list (List.map snd ntl1) (List.map snd ntl2); - if eq_package_path env p1 p2 - || !package_subtype env p1 fl1 p2 fl2 - && !package_subtype env p2 fl2 p1 fl1 then () else raise Not_found - + if eq_package_path env p1 p2 then Ok () + else Result.bind + (!package_subtype env p1 fl1 p2 fl2) + (fun () -> !package_subtype env p2 fl2 p1 fl1) (* force unification in Reither when one side has a non-conjunctive type *) (* Code smell: this could also be put in unification_environment. @@ -2814,9 +2857,8 @@ and unify3 uenv t1 t1' t2 t2' = end; try begin match (d1, d2) with - (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || - (!Clflags.classic || in_pattern_mode uenv) && - not (is_optional l1 || is_optional l2) -> + (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) -> + eq_labels Unify ~in_pattern_mode:(in_pattern_mode uenv) l1 l2; unify uenv t1 t2; unify uenv u1 u2; begin match is_commu_ok c1, is_commu_ok c2 with | false, true -> set_commu_ok c1 @@ -2929,13 +2971,19 @@ and unify3 uenv t1 t1' t2 t2' = | (Tpoly (t1, []), Tpoly (t2, [])) -> unify uenv t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly_for Unify (get_env uenv) univar_pairs t1 tl1 t2 tl2 + enter_poly_for Unify (get_env uenv) t1 tl1 t2 tl2 (unify uenv) | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try + begin match unify_package (get_env uenv) (unify_list uenv) (get_level t1) p1 fl1 (get_level t2) p2 fl2 - with Not_found -> + with + | Ok () -> () + | Error fm_err -> + if not (in_pattern_mode uenv) then + raise_for Unify (Errortrace.First_class_module fm_err); + List.iter (fun (_n, ty) -> reify uenv ty) (fl1 @ fl2); + | exception Not_found -> if not (in_pattern_mode uenv) then raise_unexplained_for Unify; List.iter (fun (_n, ty) -> reify uenv ty) (fl1 @ fl2); (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) @@ -3249,7 +3297,6 @@ let unify uenv ty1 ty2 = raise (Unify (expand_to_unification_error (get_env uenv) trace)) let unify_gadt (penv : Pattern_env.t) ty1 ty2 = - univar_pairs := []; let equated_types = TypePairs.create 0 in let equations_generation = Allowed { equated_types } in let uenv = Pattern @@ -3258,8 +3305,9 @@ let unify_gadt (penv : Pattern_env.t) ty1 ty2 = assume_injective = true; unify_eq_set = TypePairs.create 11; } in - unify uenv ty1 ty2; - equated_types + with_univar_pairs [] (fun () -> + unify uenv ty1 ty2; + equated_types) let unify_var uenv t1 t2 = if eq_type t1 t2 then () else @@ -3291,8 +3339,8 @@ let unify_var env ty1 ty2 = unify_var (Expression {env; in_subst = false}) ty1 ty2 let unify_pairs env ty1 ty2 pairs = - univar_pairs := pairs; - unify (Expression {env; in_subst = false}) ty1 ty2 + with_univar_pairs pairs (fun () -> + unify (Expression {env; in_subst = false}) ty1 ty2) let unify env ty1 ty2 = unify_pairs env ty1 ty2 [] @@ -3704,40 +3752,35 @@ let close_class_signature env sign = let self = expand_head env sign.csig_self in close env (object_fields self) -let generalize_class_signature_spine env sign = +let generalize_class_signature_spine sign = (* Generalize the spine of methods *) - let meths = sign.csig_meths in - Meths.iter (fun _ (_, _, ty) -> generalize_spine ty) meths; - let new_meths = - Meths.map - (fun (priv, virt, ty) -> (priv, virt, generic_instance ty)) - meths - in - (* But keep levels correct on the type of self *) - Meths.iter - (fun _ (_, _, ty) -> unify_var env (newvar ()) ty) - meths; - sign.csig_meths <- new_meths + sign.csig_meths <- + Meths.map (fun (priv, virt, ty) -> priv, virt, copy_spine ty) + sign.csig_meths (***********************************) (* Matching between type schemes *) (***********************************) +(* Level of the subject, should be just below generic_level *) +let subject_level = generic_level - 1 + (* Update the level of [ty]. First check that the levels of generic variables from the subject are not lowered. *) let moregen_occur env level ty = - let rec occur ty = - let lv = get_level ty in - if lv <= level then () else - if is_Tvar ty && lv >= generic_level - 1 then raise Occur else - if try_mark_node ty then iter_type_expr occur ty - in - begin try - occur ty; unmark_type ty - with Occur -> - unmark_type ty; raise_unexplained_for Moregen + with_type_mark begin fun mark -> + let rec occur ty = + let lv = get_level ty in + if lv <= level then () else + if is_Tvar ty && lv >= subject_level then raise Occur else + if try_mark_node mark ty then iter_type_expr occur ty + in + try + occur ty + with Occur -> + raise_unexplained_for Moregen end; (* also check for free univars *) occur_univar_for Moregen env ty; @@ -3745,7 +3788,7 @@ let moregen_occur env level ty = let may_instantiate inst_nongen t1 = let level = get_level t1 in - if inst_nongen then level <> generic_level - 1 + if inst_nongen then level <> subject_level else level = generic_level let rec moregen inst_nongen type_pairs env t1 t2 = @@ -3772,8 +3815,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 = moregen_occur env (get_level t1') t2; update_scope_for Moregen (get_scope t1') t2; link_type t1' t2 - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 - || !Clflags.classic && not (is_optional l1 || is_optional l2) -> + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) -> + eq_labels Moregen ~in_pattern_mode:false l1 l2; moregen inst_nongen type_pairs env t1 t2; moregen inst_nongen type_pairs env u1 u2 | (Ttuple tl1, Ttuple tl2) -> @@ -3782,10 +3825,13 @@ let rec moregen inst_nongen type_pairs env t1 t2 = when Path.same p1 p2 -> moregen_list inst_nongen type_pairs env tl1 tl2 | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try + begin match unify_package env (moregen_list inst_nongen type_pairs env) (get_level t1') p1 fl1 (get_level t2') p2 fl2 - with Not_found -> raise_unexplained_for Moregen + with + | Ok () -> () + | Error fme -> raise_for Moregen (First_class_module fme) + | exception Not_found -> raise_unexplained_for Moregen end | (Tnil, Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second)) | (Tconstr _, Tnil ) -> raise_for Moregen (Obj (Abstract_row First)) @@ -3801,7 +3847,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = | (Tpoly (t1, []), Tpoly (t2, [])) -> moregen inst_nongen type_pairs env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly_for Moregen env univar_pairs t1 tl1 t2 tl2 + enter_poly_for Moregen env t1 tl1 t2 tl2 (moregen inst_nongen type_pairs env) | (Tunivar _, Tunivar _) -> unify_univar_for Moregen t1' t2' !univar_pairs @@ -3964,8 +4010,8 @@ and moregen_row inst_nongen type_pairs env row1 row2 = (* Must empty univar_pairs first *) let moregen inst_nongen type_pairs env patt subj = - univar_pairs := []; - moregen inst_nongen type_pairs env patt subj + with_univar_pairs [] (fun () -> + moregen inst_nongen type_pairs env patt subj) (* Non-generic variable can be instantiated only if [inst_nongen] is @@ -3976,37 +4022,37 @@ let moregen inst_nongen type_pairs env patt subj = is unimportant. So, no need to propagate abbreviations. *) let moregeneral env inst_nongen pat_sch subj_sch = - let old_level = !current_level in - current_level := generic_level - 1; - (* - Generic variables are first duplicated with [instance]. So, - their levels are lowered to [generic_level - 1]. The subject is - then copied with [duplicate_type]. That way, its levels won't be - changed. - *) - let subj_inst = instance subj_sch in - let subj = duplicate_type subj_inst in - current_level := generic_level; - (* Duplicate generic variables *) - let patt = instance pat_sch in - - Misc.try_finally - (fun () -> - try - moregen inst_nongen (TypePairs.create 13) env patt subj - with Moregen_trace trace -> - (* Moregen splits the generic level into two finer levels: - [generic_level] and [generic_level - 1]. In order to properly - detect and print weak variables when printing this error, we need to - merge them back together, by regeneralizing the levels of the types - after they were instantiated at [generic_level - 1] above. Because - [moregen] does some unification that we need to preserve for more - legible error messages, we have to manually perform the - regeneralization rather than backtracking. *) - current_level := generic_level - 2; - generalize subj_inst; - raise (Moregen (expand_to_moregen_error env trace))) - ~always:(fun () -> current_level := old_level) + (* Moregen splits the generic level into two finer levels: + [generic_level] and [subject_level = generic_level - 1]. + In order to properly detect and print weak variables when + printing errors, we need to merge those levels back together. + We do that by starting at level [subject_level - 1], using + [with_local_level_generalize] to first set the current level + to [subject_level], and then generalize nodes at [subject_level] + on exit. + Strictly speaking, we could avoid generalizing when there is no error, + as nodes at level [subject_level] are never unified with nodes of + the original types, but that would be rather ad hoc. + *) + with_level ~level:(subject_level - 1) begin fun () -> + match with_local_level_generalize begin fun () -> + assert (!current_level = subject_level); + (* + Generic variables are first duplicated with [instance]. So, + their levels are lowered to [subject_level]. The subject is + then copied with [duplicate_type]. That way, its levels won't be + changed. + *) + let subj_inst = instance subj_sch in + let subj = duplicate_type subj_inst in + (* Duplicate generic variables *) + let patt = generic_instance pat_sch in + try Ok (moregen inst_nongen (TypePairs.create 13) env patt subj) + with Moregen_trace trace -> Error trace + end with + | Ok () -> () + | Error trace -> raise (Moregen (expand_to_moregen_error env trace)) + end let is_moregeneral env inst_nongen pat_sch subj_sch = match moregeneral env inst_nongen pat_sch subj_sch with @@ -4017,8 +4063,8 @@ let is_moregeneral env inst_nongen pat_sch subj_sch = and check validity after unification *) (* Simpler, no? *) -let rec rigidify_rec vars ty = - if try_mark_node ty then +let rec rigidify_rec mark vars ty = + if try_mark_node mark ty then begin match get_desc ty with | Tvar _ -> if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars @@ -4031,18 +4077,17 @@ let rec rigidify_rec vars ty = ~name ~closed in link_type more (newty2 ~level:(get_level ty) (Tvariant row')) end; - iter_row (rigidify_rec vars) row; + iter_row (rigidify_rec mark vars) row; (* only consider the row variable if the variant is not static *) if not (static_row row) then - rigidify_rec vars (row_more row) + rigidify_rec mark vars (row_more row) | _ -> - iter_type_expr (rigidify_rec vars) ty + iter_type_expr (rigidify_rec mark vars) ty end let rigidify ty = let vars = ref TypeSet.empty in - rigidify_rec vars ty; - unmark_type ty; + with_type_mark (fun mark -> rigidify_rec mark vars ty); TypeSet.elements !vars let all_distinct_vars env vars = @@ -4104,8 +4149,18 @@ let eqtype_subst type_pairs subst t1 t2 = end let rec eqtype rename type_pairs subst env t1 t2 = - if eq_type t1 t2 then () else + let check_phys_eq t1 t2 = + not rename && eq_type t1 t2 + in + (* Checking for physical equality of type representatives when [rename] is + true would be incorrect: imagine comparing ['a * 'a] with ['b * 'a]. The + first ['a] and ['b] would be identified in [eqtype_subst], and then the + second ['a] and ['a] would be [eq_type]. So we do not call [eq_type] here. + On the other hand, when [rename] is false we need to check for physical + equality, as that's the only way variables can be identified. + *) + if check_phys_eq t1 t2 then () else try match (get_desc t1, get_desc t2) with (Tvar _, Tvar _) when rename -> @@ -4116,26 +4171,29 @@ let rec eqtype rename type_pairs subst env t1 t2 = let t1' = expand_head_rigid env t1 in let t2' = expand_head_rigid env t2 in (* Expansion may have changed the representative of the types... *) - if eq_type t1' t2' then () else + if check_phys_eq t1' t2' then () else if not (TypePairs.mem type_pairs (t1', t2')) then begin TypePairs.add type_pairs (t1', t2'); match (get_desc t1', get_desc t2') with (Tvar _, Tvar _) when rename -> eqtype_subst type_pairs subst t1' t2' - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 - || !Clflags.classic && not (is_optional l1 || is_optional l2) -> + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) -> + eq_labels Equality ~in_pattern_mode:false l1 l2; eqtype rename type_pairs subst env t1 t2; - eqtype rename type_pairs subst env u1 u2; + eqtype rename type_pairs subst env u1 u2 | (Ttuple tl1, Ttuple tl2) -> eqtype_list rename type_pairs subst env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> - eqtype_list rename type_pairs subst env tl1 tl2 + eqtype_list_same_length rename type_pairs subst env tl1 tl2 | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try + begin match unify_package env (eqtype_list rename type_pairs subst env) (get_level t1') p1 fl1 (get_level t2') p2 fl2 - with Not_found -> raise_unexplained_for Equality + with + | Ok () -> () + | Error fme -> raise_for Equality (First_class_module fme) + | exception Not_found -> raise_unexplained_for Equality end | (Tnil, Tconstr _ ) -> raise_for Equality (Obj (Abstract_row Second)) @@ -4153,7 +4211,7 @@ let rec eqtype rename type_pairs subst env t1 t2 = | (Tpoly (t1, []), Tpoly (t2, [])) -> eqtype rename type_pairs subst env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly_for Equality env univar_pairs t1 tl1 t2 tl2 + enter_poly_for Equality env t1 tl1 t2 tl2 (eqtype rename type_pairs subst env) | (Tunivar _, Tunivar _) -> unify_univar_for Equality t1' t2' !univar_pairs @@ -4163,17 +4221,22 @@ let rec eqtype rename type_pairs subst env t1 t2 = with Equality_trace trace -> raise_trace_for Equality (Diff {got = t1; expected = t2} :: trace) +and eqtype_list_same_length rename type_pairs subst env tl1 tl2 = + List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + and eqtype_list rename type_pairs subst env tl1 tl2 = if List.length tl1 <> List.length tl2 then raise_unexplained_for Equality; - List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + eqtype_list_same_length rename type_pairs subst env tl1 tl2 and eqtype_fields rename type_pairs subst env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 in let (fields2, rest2) = flatten_fields ty2 in (* First check if same row => already equal *) let same_row = - eq_type rest1 rest2 || TypePairs.mem type_pairs (rest1,rest2) + (* [not rename]: see comment at top of [eqtype] *) + (not rename && eq_type rest1 rest2) || + TypePairs.mem type_pairs (rest1,rest2) in if same_row then () else (* Try expansion, needed when called from Includecore.type_manifest *) @@ -4288,20 +4351,23 @@ and eqtype_row rename type_pairs subst env row1 row2 = pairs (* Must empty univar_pairs first *) -let eqtype_list rename type_pairs subst env tl1 tl2 = - univar_pairs := []; - let snap = Btype.snapshot () in - Misc.try_finally - ~always:(fun () -> backtrack snap) - (fun () -> eqtype_list rename type_pairs subst env tl1 tl2) +let eqtype_list_same_length rename type_pairs subst env tl1 tl2 = + with_univar_pairs [] (fun () -> + let snap = Btype.snapshot () in + Misc.try_finally + ~always:(fun () -> backtrack snap) + (fun () -> eqtype_list_same_length rename type_pairs subst env tl1 tl2)) let eqtype rename type_pairs subst env t1 t2 = - eqtype_list rename type_pairs subst env [t1] [t2] + eqtype_list_same_length rename type_pairs subst env [t1] [t2] (* Two modes: with or without renaming of variables *) let equal env rename tyl1 tyl2 = + if List.length tyl1 <> List.length tyl2 then + raise_unexplained_for Equality; + if List.for_all2 eq_type tyl1 tyl2 then () else let subst = ref [] in - try eqtype_list rename (TypePairs.create 11) subst env tyl1 tyl2 + try eqtype_list_same_length rename (TypePairs.create 11) subst env tyl1 tyl2 with Equality_trace trace -> raise (Equality (expand_to_equality_error env trace !subst)) @@ -4465,48 +4531,48 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = let errors = match_class_sig_shape ~strict:false sign1 sign2 in match errors with | [] -> - let old_level = !current_level in - current_level := generic_level - 1; - (* - Generic variables are first duplicated with [instance]. So, - their levels are lowered to [generic_level - 1]. The subject is - then copied with [duplicate_type]. That way, its levels won't be - changed. - *) - let (_, subj_inst) = instance_class [] subj_sch in - let subj = duplicate_class_type subj_inst in - current_level := generic_level; - (* Duplicate generic variables *) - let (_, patt) = instance_class [] pat_sch in - let type_pairs = TypePairs.create 53 in - let sign1 = signature_of_class_type patt in - let sign2 = signature_of_class_type subj in - let self1 = sign1.csig_self in - let self2 = sign2.csig_self in - let row1 = sign1.csig_self_row in - let row2 = sign2.csig_self_row in - TypePairs.add type_pairs (self1, self2); - (* Always succeeds *) - moregen true type_pairs env row1 row2; - let res = - match moregen_clty trace type_pairs env patt subj with - | () -> [] - | exception Failure res -> - (* We've found an error. Moregen splits the generic level into two - finer levels: [generic_level] and [generic_level - 1]. In order - to properly detect and print weak variables when printing this - error, we need to merge them back together, by regeneralizing the - levels of the types after they were instantiated at - [generic_level - 1] above. Because [moregen] does some - unification that we need to preserve for more legible error - messages, we have to manually perform the regeneralization rather - than backtracking. *) - current_level := generic_level - 2; - generalize_class_type subj_inst; - res - in - current_level := old_level; - res + (* Moregen splits the generic level into two finer levels: + [generic_level] and [subject_level = generic_level - 1]. + In order to properly detect and print weak variables when + printing errors, we need to merge those levels back together. + We do that by starting at level [subject_level - 1], using + [with_local_level_generalize] to first set the current level + to [subject_level], and then generalize nodes at [subject_level] + on exit. + Strictly speaking, we could avoid generalizing when there is no error, + as nodes at level [subject_level] are never unified with nodes of + the original types, but that would be rather ad hoc. + *) + with_level ~level:(subject_level - 1) begin fun () -> + with_local_level_generalize begin fun () -> + assert (!current_level = subject_level); + (* + Generic variables are first duplicated with [instance]. So, + their levels are lowered to [subject_level]. The subject is + then copied with [duplicate_type]. That way, its levels won't be + changed. + *) + let (_, subj_inst) = instance_class [] subj_sch in + let subj = duplicate_class_type subj_inst in + (* Duplicate generic variables *) + let (_, patt) = + with_level ~level:generic_level + (fun () -> instance_class [] pat_sch) in + let type_pairs = TypePairs.create 53 in + let sign1 = signature_of_class_type patt in + let sign2 = signature_of_class_type subj in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + moregen true type_pairs env row1 row2; + (* May fail *) + try moregen_clty trace type_pairs env patt subj; [] + with Failure res -> res + end + end | errors -> CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors @@ -4850,8 +4916,8 @@ let rec subtype_rec env trace t1 t2 cstrs = match (get_desc t1, get_desc t2) with (Tvar _, _) | (_, Tvar _) -> (trace, t1, t2, !univar_pairs)::cstrs - | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2 - || !Clflags.classic && not (is_optional l1 || is_optional l2) -> + | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) + when compatible_labels ~in_pattern_mode:false l1 l2 -> let cstrs = subtype_rec env @@ -4928,7 +4994,7 @@ let rec subtype_rec env trace t1 t2 cstrs = subtype_rec env trace u1' u2 cstrs | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> begin try - enter_poly env univar_pairs u1 tl1 u2 tl2 + enter_poly env u1 tl1 u2 tl2 (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) with Escape _ -> (trace, t1, t2, !univar_pairs)::cstrs @@ -4950,7 +5016,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (* need to check module subtyping *) let snap = Btype.snapshot () in match List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs' with - | () when !package_subtype env p1 fl1 p2 fl2 -> + | () when Result.is_ok (!package_subtype env p1 fl1 p2 fl2) -> Btype.backtrack snap; cstrs' @ cstrs | () | exception Unify _ -> Btype.backtrack snap; raise Not_found @@ -5074,19 +5140,22 @@ and subtype_row env trace row1 row2 cstrs = let subtype env ty1 ty2 = TypePairs.clear subtypes; - univar_pairs := []; - (* Build constraint set. *) - let cstrs = - subtype_rec env [Subtype.Diff {got = ty1; expected = ty2}] ty1 ty2 [] - in - TypePairs.clear subtypes; - (* Enforce constraints. *) - function () -> - List.iter - (function (trace0, t1, t2, pairs) -> - try unify_pairs env t1 t2 pairs with Unify {trace} -> - subtype_error ~env ~trace:trace0 ~unification_trace:(List.tl trace)) - (List.rev cstrs) + with_univar_pairs [] (fun () -> + (* Build constraint set. *) + let cstrs = + subtype_rec env [Subtype.Diff {got = ty1; expected = ty2}] ty1 ty2 [] + in + TypePairs.clear subtypes; + (* Enforce constraints. *) + function () -> + List.iter + (function (trace0, t1, t2, pairs) -> + try unify_pairs env t1 t2 pairs with Unify {trace} -> + subtype_error + ~env + ~trace:trace0 + ~unification_trace:(List.tl trace)) + (List.rev cstrs)) (*******************) (* Miscellaneous *) @@ -5235,9 +5304,8 @@ let nongen_vars_in_class_declaration cty = (* Normalize a type before printing, saving... *) (* Cannot use mark_type because deep_occur uses it too *) -let rec normalize_type_rec visited ty = - if not (TypeSet.mem ty !visited) then begin - visited := TypeSet.add ty !visited; +let rec normalize_type_rec mark ty = + if try_mark_node mark ty then begin let tm = row_of_type ty in begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then match get_desc tm with (* PR#7348 *) @@ -5296,11 +5364,11 @@ let rec normalize_type_rec visited ty = set_type_desc fi (get_desc fi') | _ -> () end; - iter_type_expr (normalize_type_rec visited) ty; + iter_type_expr (normalize_type_rec mark) ty; end let normalize_type ty = - normalize_type_rec (ref TypeSet.empty) ty + with_type_mark (fun mark -> normalize_type_rec mark ty) (*************************) diff --git a/src/ocaml/typing/ctype.mli b/src/ocaml/typing/ctype.mli index c6759b06c..753994afe 100644 --- a/src/ocaml/typing/ctype.mli +++ b/src/ocaml/typing/ctype.mli @@ -35,6 +35,15 @@ exception Incompatible (* All the following wrapper functions revert to the original level, even in case of exception. *) +val with_local_level_generalize: + ?before_generalize:('a -> unit) -> (unit -> 'a) -> 'a +val with_local_level_generalize_if: + bool -> ?before_generalize:('a -> unit) -> (unit -> 'a) -> 'a +val with_local_level_generalize_structure: (unit -> 'a) -> 'a +val with_local_level_generalize_structure_if: bool -> (unit -> 'a) -> 'a +val with_local_level_generalize_structure_if_principal: (unit -> 'a) -> 'a +val with_local_level_generalize_for_class: (unit -> 'a) -> 'a + val with_local_level: ?post:('a -> unit) -> (unit -> 'a) -> 'a (* [with_local_level (fun () -> cmd) ~post] evaluates [cmd] at a raised level. @@ -134,8 +143,6 @@ val merge_row_fields: val filter_row_fields: bool -> (label * row_field) list -> (label * row_field) list -val generalize: type_expr -> unit - (* Generalize in-place the given type *) val lower_contravariant: Env.t -> type_expr -> unit (* Lower level of type variables inside contravariant branches; to be used before generalize for expansive expressions *) @@ -143,23 +150,16 @@ val lower_variables_only: Env.t -> int -> type_expr -> unit (* Lower all variables to the given level *) val enforce_current_level: Env.t -> type_expr -> unit (* Lower whole type to !current_level *) -val generalize_structure: type_expr -> unit - (* Generalize the structure of a type, lowering variables - to !current_level *) -val generalize_class_type : class_type -> unit - (* Generalize the components of a class type *) -val generalize_class_type_structure : class_type -> unit - (* Generalize the structure of the components of a class type *) -val generalize_class_signature_spine : Env.t -> class_signature -> unit +val generalize_class_signature_spine: class_signature -> unit (* Special function to generalize methods during inference *) -val correct_levels: type_expr -> type_expr - (* Returns a copy with decreasing levels *) -val limited_generalize: type_expr -> type_expr -> unit +val limited_generalize: type_expr -> inside:type_expr -> unit (* Only generalize some part of the type Make the remaining of the type non-generalizable *) -val limited_generalize_class_type: type_expr -> class_type -> unit +val limited_generalize_class_type: type_expr -> inside:class_type -> unit (* Same, but for class types *) +val duplicate_type: type_expr -> type_expr + (* Returns a copy with non-variable nodes at generic level *) val fully_generic: type_expr -> bool val check_scope_escape : Env.t -> int -> type_expr -> unit @@ -266,6 +266,8 @@ type typedecl_extraction_result = val extract_concrete_typedecl: Env.t -> type_expr -> typedecl_extraction_result +val get_new_abstract_name : Env.t -> string -> string + val unify: Env.t -> type_expr -> type_expr -> unit (* Unify the two types given. Raise [Unify] if not possible. *) val unify_gadt: @@ -471,7 +473,8 @@ val immediacy : Env.t -> type_expr -> Type_immediacy.t (* Stubs *) val package_subtype : (Env.t -> Path.t -> (Longident.t * type_expr) list -> - Path.t -> (Longident.t * type_expr) list -> bool) ref + Path.t -> (Longident.t * type_expr) list -> + (unit,Errortrace.first_class_module) Result.t) ref (* Raises [Incompatible] *) val mcomp : Env.t -> type_expr -> type_expr -> unit diff --git a/src/ocaml/typing/datarepr.ml b/src/ocaml/typing/datarepr.ml index 9213fe833..522803115 100644 --- a/src/ocaml/typing/datarepr.ml +++ b/src/ocaml/typing/datarepr.ml @@ -23,24 +23,25 @@ open Btype (* Simplified version of Ctype.free_vars *) let free_vars ?(param=false) ty = let ret = ref TypeSet.empty in - let rec loop ty = - if try_mark_node ty then - match get_desc ty with - | Tvar _ -> - ret := TypeSet.add ty !ret - | Tvariant row -> - iter_row loop row; - if not (static_row row) then begin - match get_desc (row_more row) with - | Tvar _ when param -> ret := TypeSet.add ty !ret - | _ -> loop (row_more row) - end - (* XXX: What about Tobject ? *) - | _ -> - iter_type_expr loop ty - in - loop ty; - unmark_type ty; + with_type_mark begin fun mark -> + let rec loop ty = + if try_mark_node mark ty then + match get_desc ty with + | Tvar _ -> + ret := TypeSet.add ty !ret + | Tvariant row -> + iter_row loop row; + if not (static_row row) then begin + match get_desc (row_more row) with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop (row_more row) + end + (* XXX: What about Tobject ? *) + | _ -> + iter_type_expr loop ty + in + loop ty + end; !ret let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) diff --git a/src/ocaml/typing/datarepr.mli b/src/ocaml/typing/datarepr.mli index 38f05f74f..1ccb918e5 100644 --- a/src/ocaml/typing/datarepr.mli +++ b/src/ocaml/typing/datarepr.mli @@ -19,14 +19,14 @@ open Types val extension_descr: - current_unit:string -> Path.t -> extension_constructor -> + current_unit:(Unit_info.t option) -> Path.t -> extension_constructor -> constructor_description val labels_of_type: Path.t -> type_declaration -> (Ident.t * label_description) list val constructors_of_type: - current_unit:string -> Path.t -> type_declaration -> + current_unit:(Unit_info.t option) -> Path.t -> type_declaration -> (Ident.t * constructor_description) list diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml index 1e52f6dd3..8c2d88559 100644 --- a/src/ocaml/typing/env.ml +++ b/src/ocaml/typing/env.ml @@ -849,42 +849,57 @@ let rec print_address ppf = function (* The name of the compilation unit currently compiled. "" if outside a compilation unit. *) -module Current_unit_name : sig - val get : unit -> modname - val set : modname -> unit - val is : modname -> bool - val is_ident : Ident.t -> bool - val is_path : Path.t -> bool +module Current_unit : sig + val get : unit -> Unit_info.t option + val set : Unit_info.t -> unit + val unset : unit -> unit + + module Name : sig + val get : unit -> modname + val is : modname -> bool + val is_ident : Ident.t -> bool + val is_path : Path.t -> bool + end end = struct - let current_unit = - ref "" + let current_unit : Unit_info.t option ref = + ref None let get () = !current_unit - let set name = - current_unit := name - let is name = - !current_unit = name - let is_ident id = - Ident.persistent id && is (Ident.name id) - let is_path = function - | Pident id -> is_ident id - | Pdot _ | Papply _ | Pextra_ty _ -> false + let set cu = + current_unit := Some cu + let unset () = + current_unit := None + + module Name = struct + let get () = + match !current_unit with + | None -> "" + | Some cu -> Unit_info.modname cu + let is name = + get () = name + let is_ident id = + Ident.persistent id && is (Ident.name id) + let is_path = function + | Pident id -> is_ident id + | Pdot _ | Papply _ | Pextra_ty _ -> false + end end -let set_unit_name = Current_unit_name.set -let get_unit_name = Current_unit_name.get +let set_current_unit = Current_unit.set +let get_current_unit = Current_unit.get +let get_current_unit_name = Current_unit.Name.get let find_same_module id tbl = match IdTbl.find_same id tbl with | x -> x | exception Not_found - when Ident.persistent id && not (Current_unit_name.is_ident id) -> + when Ident.persistent id && not (Current_unit.Name.is_ident id) -> Mod_persistent let find_name_module ~mark name tbl = match IdTbl.find_name wrap_module ~mark name tbl with | x -> x - | exception Not_found when not (Current_unit_name.is name) -> + | exception Not_found when not (Current_unit.Name.is name) -> let path = Pident(Ident.create_persistent name) in path, Mod_persistent @@ -898,7 +913,7 @@ let short_paths_components name pm = let add_persistent_structure id env = if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure"; - if Current_unit_name.is_ident id then env + if Current_unit.Name.is_ident id then env else begin let material = (* This addition only observably changes the environment if it shadows a @@ -1030,7 +1045,7 @@ let reset_declaration_caches () = () let reset_cache () = - Current_unit_name.set ""; + Current_unit.unset (); Persistent_env.clear !persistent_env; reset_declaration_caches (); () @@ -1355,7 +1370,7 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = properly populated. *) assert false | exception Not_found - when Ident.persistent id && not (Current_unit_name.is_ident id) -> + when Ident.persistent id && not (Current_unit.Name.is_ident id) -> Shape.for_persistent_unit (Ident.name id) end | Module_type -> @@ -1796,16 +1811,6 @@ let module_declaration_address env id presence md = | Mp_present -> Lazy_backtrack.create_forced (Aident id) -let is_identchar c = - (* This should be kept in sync with the [identchar_latin1] character class - in [lexer.mll] *) - match c with - | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' - | '\216'..'\246' | '\248'..'\255' | '\'' | '0'..'9' -> - true - | _ -> - false - let rec components_of_module_maker {cm_env; cm_prefixing_subst; cm_path; cm_addr; cm_mty; cm_shape} : _ result = @@ -1853,7 +1858,7 @@ let rec components_of_module_maker | Type_variant (_,repr) -> let cstrs = List.map snd (Datarepr.constructors_of_type path final_decl - ~current_unit:(get_unit_name ())) + ~current_unit:(get_current_unit ())) in List.iter (fun descr -> @@ -1891,7 +1896,7 @@ let rec components_of_module_maker | SigL_typext(id, ext, _, _) -> let ext' = Subst.extension_constructor sub ext in let descr = - Datarepr.extension_descr ~current_unit:(get_unit_name ()) path + Datarepr.extension_descr ~current_unit:(get_current_unit ()) path ext' in let addr = next_address () in @@ -2012,7 +2017,8 @@ and check_value_name name loc = (* Note: we could also check here general validity of the identifier, to protect against bad identifiers forged by -pp or -ppx preprocessors. *) - if String.length name > 0 && not (is_identchar name.[0]) then + if String.length name > 0 && not + (Utf8_lexeme.starts_like_a_valid_identifier name) then for i = 1 to String.length name - 1 do if name.[i] = '#' then error (Illegal_value_name(loc, name)) @@ -2111,7 +2117,7 @@ and store_type ~check ~long_path ~predef id info shape env = match info.type_kind with | Type_variant (_,repr) -> let constructors = Datarepr.constructors_of_type path info - ~current_unit:(get_unit_name ()) + ~current_unit:(get_current_unit ()) in Type_variant (List.map snd constructors, repr), List.fold_left @@ -2162,7 +2168,8 @@ and store_type_infos ~tda_shape id info env = and store_extension ~check ~rebind id addr ext shape env = let loc = ext.ext_loc in let cstr = - Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext + Datarepr.extension_descr + ~current_unit:(get_current_unit ()) (Pident id) ext in let cda = { cda_description = cstr; @@ -2684,7 +2691,7 @@ let read_signature u = let unit_name_of_filename fn = match Filename.extension fn with | ".cmi" -> - let modname = Unit_info.modname_from_source fn in + let modname = Unit_info.strict_modname_from_source fn in if Unit_info.is_unit_name modname then Some modname else None | _ -> None @@ -3441,7 +3448,7 @@ let bound_module name env = match IdTbl.find_name wrap_module ~mark:false name env.modules with | _ -> true | exception Not_found -> - if Current_unit_name.is name then false + if Current_unit.Name.is name then false else begin match find_pers_mod ~allow_hidden:false name with | _ -> true @@ -3670,15 +3677,16 @@ let env_of_only_summary env_from_summary env = (* Error report *) -open Format +open Format_doc (* Forward declarations *) -let print_longident = - ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit) +let print_longident : Longident.t printer ref = ref (fun _ _ -> assert false) -let print_path = - ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit) +let pp_longident ppf l = !print_longident ppf l + +let print_path: Path.t printer ref = ref (fun _ _ -> assert false) +let pp_path ppf l = !print_path ppf l let spellcheck ppf extract env lid = let choices ~path name = Misc.spellcheck (extract path env) name in @@ -3718,10 +3726,11 @@ let extract_instance_variables env = module Style = Misc.Style -let report_lookup_error _loc env ppf = function +let quoted_longident = Style.as_inline_code pp_longident + +let report_lookup_error_doc _loc env ppf = function | Unbound_value(lid, hint) -> begin - fprintf ppf "Unbound value %a" - (Style.as_inline_code !print_longident) lid; + fprintf ppf "Unbound value %a" quoted_longident lid; spellcheck ppf extract_values env lid; match hint with | No_hint -> () @@ -3737,52 +3746,52 @@ let report_lookup_error _loc env ppf = function end | Unbound_type lid -> fprintf ppf "Unbound type constructor %a" - (Style.as_inline_code !print_longident) lid; + quoted_longident lid; spellcheck ppf extract_types env lid; | Unbound_module lid -> begin fprintf ppf "Unbound module %a" - (Style.as_inline_code !print_longident) lid; + quoted_longident lid; match find_modtype_by_name lid env with | exception Not_found -> spellcheck ppf extract_modules env lid; | _ -> fprintf ppf "@.@[@{Hint@}: There is a module type named %a, %s@]" - (Style.as_inline_code !print_longident) lid + quoted_longident lid "but module types are not modules" end | Unbound_constructor lid -> fprintf ppf "Unbound constructor %a" - (Style.as_inline_code !print_longident) lid; + quoted_longident lid; spellcheck ppf extract_constructors env lid; | Unbound_label lid -> fprintf ppf "Unbound record field %a" - (Style.as_inline_code !print_longident) lid; + quoted_longident lid; spellcheck ppf extract_labels env lid; | Unbound_class lid -> begin fprintf ppf "Unbound class %a" - (Style.as_inline_code !print_longident) lid; + quoted_longident lid; match find_cltype_by_name lid env with | exception Not_found -> spellcheck ppf extract_classes env lid; | _ -> fprintf ppf "@.@[@{Hint@}: There is a class type named %a, %s@]" - (Style.as_inline_code !print_longident) lid + quoted_longident lid "but classes are not class types" end | Unbound_modtype lid -> begin fprintf ppf "Unbound module type %a" - (Style.as_inline_code !print_longident) lid; + quoted_longident lid; match find_module_by_name lid env with | exception Not_found -> spellcheck ppf extract_modtypes env lid; | _ -> fprintf ppf "@.@[@{Hint@}: There is a module named %a, %s@]" - (Style.as_inline_code !print_longident) lid + quoted_longident lid "but modules are not module types" end | Unbound_cltype lid -> fprintf ppf "Unbound class type %a" - (Style.as_inline_code !print_longident) lid; + quoted_longident lid; spellcheck ppf extract_cltypes env lid; | Unbound_instance_variable s -> fprintf ppf "Unbound instance variable %a" Style.inline_code s; @@ -3795,47 +3804,47 @@ let report_lookup_error _loc env ppf = function fprintf ppf "The instance variable %a@ \ cannot be accessed from the definition of another instance variable" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Masked_self_variable lid -> fprintf ppf "The self variable %a@ \ cannot be accessed from the definition of an instance variable" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Masked_ancestor_variable lid -> fprintf ppf "The ancestor variable %a@ \ cannot be accessed from the definition of an instance variable" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Illegal_reference_to_recursive_module -> fprintf ppf "Illegal recursive module reference" | Structure_used_as_functor lid -> fprintf ppf "@[The module %a is a structure, it cannot be applied@]" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Abstract_used_as_functor lid -> fprintf ppf "@[The module %a is abstract, it cannot be applied@]" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Functor_used_as_structure lid -> fprintf ppf "@[The module %a is a functor, \ - it cannot have any components@]" !print_longident lid + it cannot have any components@]" pp_longident lid | Abstract_used_as_structure lid -> fprintf ppf "@[The module %a is abstract, \ it cannot have any components@]" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Generative_used_as_applicative lid -> fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ applied@ in@ type@ expressions@]" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Cannot_scrape_alias(lid, p) -> let cause = - if Current_unit_name.is_path p then "is the current compilation unit" + if Current_unit.Name.is_path p then "is the current compilation unit" else "is missing" in fprintf ppf "The module %a is an alias for module %a, which %s" - (Style.as_inline_code !print_longident) lid - (Style.as_inline_code !print_path) p cause + quoted_longident lid + (Style.as_inline_code pp_path) p cause -let report_error ppf = function +let report_error_doc ppf = function | Missing_module(_, path1, path2) -> fprintf ppf "@[@["; if Path.same path1 path2 then @@ -3852,7 +3861,7 @@ let report_error ppf = function | Illegal_value_name(_loc, name) -> fprintf ppf "%a is not a valid value identifier." Style.inline_code name - | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err + | Lookup_error(loc, t, err) -> report_lookup_error_doc loc t ppf err let () = Location.register_error_of_exn @@ -4174,8 +4183,23 @@ let cleanup_functor_caches ~stamp = Stamped_hashtable.backtrack !stamped_changelog ~stamp let cleanup_usage_tables ~stamp = +<<<<<<< Stamped_hashtable.backtrack value_declarations_changelog ~stamp; Stamped_hashtable.backtrack type_declarations_changelog ~stamp; Stamped_hashtable.backtrack module_declarations_changelog ~stamp; Stamped_hashtable.backtrack used_constructors_changelog ~stamp; Stamped_hashtable.backtrack used_labels_changelog ~stamp +======= + let error_of_printer = + if loc = Location.none + then Location.error_of_printer_file + else Location.error_of_printer ~loc ?sub:None ?footnote:None + in + Some (error_of_printer report_error_doc err) + | _ -> + None + ) + +let report_lookup_error = Format_doc.compat2 report_lookup_error_doc +let report_error = Format_doc.compat report_error_doc +>>>>>>> diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli index aa005a4b8..f20139ce1 100644 --- a/src/ocaml/typing/env.mli +++ b/src/ocaml/typing/env.mli @@ -396,9 +396,10 @@ val reset_cache: unit -> unit (* To be called before each toplevel phrase. *) val reset_cache_toplevel: unit -> unit -(* Remember the name of the current compilation unit. *) -val set_unit_name: string -> unit -val get_unit_name: unit -> string +(* Remember the current compilation unit. *) +val set_current_unit: Unit_info.t -> unit +val get_current_unit : unit -> Unit_info.t option +val get_current_unit_name: unit -> string (* Read, save a signature to/from a file *) val read_signature: Unit_info.Artifact.t -> signature @@ -455,12 +456,14 @@ type error = exception Error of error -open Format -val report_error: formatter -> error -> unit - -val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer +val report_lookup_error: + Location.t -> t -> lookup_error Format_doc.format_printer +val report_lookup_error_doc: + Location.t -> t -> lookup_error Format_doc.printer val in_signature: bool -> t -> t val is_in_signature: t -> bool @@ -490,9 +493,9 @@ val strengthen: (* Forward declaration to break mutual recursion with Ctype. *) val same_constr: (t -> type_expr -> type_expr -> bool) ref (* Forward declaration to break mutual recursion with Printtyp. *) -val print_longident: (Format.formatter -> Longident.t -> unit) ref +val print_longident: Longident.t Format_doc.printer ref (* Forward declaration to break mutual recursion with Printtyp. *) -val print_path: (Format.formatter -> Path.t -> unit) ref +val print_path: Path.t Format_doc.printer ref (* Forward declaration to break mutual recursion with Printtyp *) diff --git a/src/ocaml/typing/envaux.ml b/src/ocaml/typing/envaux.ml index 90e0da92c..df75c5d5b 100644 --- a/src/ocaml/typing/envaux.ml +++ b/src/ocaml/typing/envaux.ml @@ -101,17 +101,19 @@ let env_of_only_summary env = (* Error report *) -open Format +open Format_doc module Style = Misc.Style -let report_error ppf = function +let report_error_doc ppf = function | Module_not_found p -> fprintf ppf "@[Cannot find module %a@].@." - (Style.as_inline_code Printtyp.path) p + (Style.as_inline_code Printtyp.Doc.path) p let () = Location.register_error_of_exn (function - | Error err -> Some (Location.error_of_printer_file report_error err) + | Error err -> Some (Location.error_of_printer_file report_error_doc err) | _ -> None ) + +let report_error = Format_doc.compat report_error_doc diff --git a/src/ocaml/typing/envaux.mli b/src/ocaml/typing/envaux.mli index 2869890a1..5fbb8410b 100644 --- a/src/ocaml/typing/envaux.mli +++ b/src/ocaml/typing/envaux.mli @@ -14,8 +14,6 @@ (* *) (**************************************************************************) -open Format - (* Convert environment summaries to environments *) val env_from_summary : Env.summary -> Subst.t -> Env.t @@ -33,4 +31,5 @@ type error = exception Error of error -val report_error: formatter -> error -> unit +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer diff --git a/src/ocaml/typing/errortrace.ml b/src/ocaml/typing/errortrace.ml index 407b3438e..f0a714730 100644 --- a/src/ocaml/typing/errortrace.ml +++ b/src/ocaml/typing/errortrace.ml @@ -16,7 +16,7 @@ (**************************************************************************) open Types -open Format +open Format_doc type position = First | Second @@ -98,14 +98,21 @@ type 'variety obj = (* Unification *) | Self_cannot_be_closed : unification obj +type first_class_module = + | Package_cannot_scrape of Path.t + | Package_inclusion of Format_doc.doc + | Package_coercion of Format_doc.doc + type ('a, 'variety) elt = (* Common *) | Diff : 'a diff -> ('a, _) elt | Variant : 'variety variant -> ('a, 'variety) elt | Obj : 'variety obj -> ('a, 'variety) elt | Escape : 'a escape -> ('a, _) elt + | Function_label_mismatch of Asttypes.arg_label diff | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt (* Could move [Incompatible_fields] into [obj] *) + | First_class_module: first_class_module -> ('a,_) elt (* Unification & Moregen; included in Equality for simplicity *) | Rec_occur : type_expr * type_expr -> ('a, _) elt @@ -125,7 +132,8 @@ let map_elt (type variety) f : ('a, variety) elt -> ('b, variety) elt = function Escape { kind = Equation (f x); context } | Escape {kind = (Univ _ | Self | Constructor _ | Module_type _ | Constraint); _} - | Variant _ | Obj _ | Incompatible_fields _ | Rec_occur (_, _) as x -> x + | Variant _ | Obj _ | Function_label_mismatch _ | Incompatible_fields _ + | Rec_occur (_, _) | First_class_module _ as x -> x let map f t = List.map (map_elt f) t diff --git a/src/ocaml/typing/errortrace.mli b/src/ocaml/typing/errortrace.mli index f3cfe4855..2377748a4 100644 --- a/src/ocaml/typing/errortrace.mli +++ b/src/ocaml/typing/errortrace.mli @@ -20,7 +20,7 @@ open Types type position = First | Second val swap_position : position -> position -val print_pos : Format.formatter -> position -> unit +val print_pos : position Format_doc.printer type expanded_type = { ty: type_expr; expanded: type_expr } @@ -84,13 +84,20 @@ type 'variety obj = (* Unification *) | Self_cannot_be_closed : unification obj +type first_class_module = + | Package_cannot_scrape of Path.t + | Package_inclusion of Format_doc.doc + | Package_coercion of Format_doc.doc + type ('a, 'variety) elt = (* Common *) | Diff : 'a diff -> ('a, _) elt | Variant : 'variety variant -> ('a, 'variety) elt | Obj : 'variety obj -> ('a, 'variety) elt | Escape : 'a escape -> ('a, _) elt + | Function_label_mismatch of Asttypes.arg_label diff | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt + | First_class_module: first_class_module -> ('a,_) elt (* Unification & Moregen; included in Equality for simplicity *) | Rec_occur : type_expr * type_expr -> ('a, _) elt diff --git a/src/ocaml/typing/ident.ml b/src/ocaml/typing/ident.ml index 149feff92..a26db8b7d 100644 --- a/src/ocaml/typing/ident.ml +++ b/src/ocaml/typing/ident.ml @@ -16,7 +16,8 @@ open Local_store let lowest_scope = 0 -let highest_scope = 100000000 +let highest_scope = 100_000_000 + (* assumed to fit in 27 bits, see Types.scope_field *) type t = | Local of { name: string; stamp: int } @@ -111,6 +112,9 @@ let stamp = function | Scoped { stamp; _ } -> stamp | _ -> 0 +let compare_stamp id1 id2 = + compare (stamp id1) (stamp id2) + let scope = function | Scoped { scope; _ } -> scope | Local _ -> highest_scope @@ -134,21 +138,37 @@ let is_predef = function | _ -> false let print ~with_scope ppf = - let open Format in + let open Format_doc in function | Global name -> fprintf ppf "%s!" name | Predef { name; stamp = n } -> +<<<<<<< fprintf ppf "%s/%i!" name n +======= + fprintf ppf "%s%s!" name + (if !Clflags.unique_ids then asprintf "/%i" n else "") +>>>>>>> | Local { name; stamp = n } -> +<<<<<<< fprintf ppf "%s/%i" name n +======= + fprintf ppf "%s%s" name + (if !Clflags.unique_ids then asprintf "/%i" n else "") +>>>>>>> | Scoped { name; stamp = n; scope } -> +<<<<<<< fprintf ppf "%s/%i%s" name n (if with_scope then sprintf "[%i]" scope else "") +======= + fprintf ppf "%s%s%s" name + (if !Clflags.unique_ids then asprintf "/%i" n else "") + (if with_scope then asprintf "[%i]" scope else "") +>>>>>>> let print_with_scope ppf id = print ~with_scope:true ppf id -let print ppf id = print ~with_scope:false ppf id - +let doc_print ppf id = print ~with_scope:false ppf id +let print ppf id = Format_doc.compat doc_print ppf id (* For the documentation of ['a Ident.tbl], see ident.mli. The implementation is a copy-paste specialization of diff --git a/src/ocaml/typing/ident.mli b/src/ocaml/typing/ident.mli index cfc4ca10b..e878c1bea 100644 --- a/src/ocaml/typing/ident.mli +++ b/src/ocaml/typing/ident.mli @@ -24,7 +24,8 @@ include Identifiable.S with type t := t - [compare] compares identifiers by binding location *) -val print_with_scope : Format.formatter -> t -> unit +val doc_print: t Format_doc.printer +val print_with_scope : t Format_doc.printer (** Same as {!print} except that it will also add a "[n]" suffix if the scope of the argument is [n]. *) @@ -50,7 +51,11 @@ val same: t -> t -> bool [create_*], or if they are both persistent and have the same name. *) +val compare_stamp: t -> t -> int + (** Compare only the internal stamps, 0 if absent *) + val compare: t -> t -> int + (** Compare identifiers structurally, including the name *) val global: t -> bool val is_predef: t -> bool diff --git a/src/ocaml/typing/includeclass.ml b/src/ocaml/typing/includeclass.ml index 39f00f9cf..dfdc686ad 100644 --- a/src/ocaml/typing/includeclass.ml +++ b/src/ocaml/typing/includeclass.ml @@ -40,8 +40,9 @@ let class_declarations env cty1 cty2 = cty1.cty_params cty1.cty_type cty2.cty_params cty2.cty_type -open Format +open Format_doc open Ctype +module Printtyp=Printtyp.Doc (* let rec hide_params = function @@ -50,6 +51,7 @@ let rec hide_params = function *) let include_err mode ppf = + let msg fmt = Format_doc.Doc.msg fmt in function | CM_Virtual_class -> fprintf ppf "A class cannot be changed from virtual to concrete" @@ -57,12 +59,10 @@ let include_err mode ppf = fprintf ppf "The classes do not have the same number of type parameters" | CM_Type_parameter_mismatch (n, env, err) -> - Printtyp.report_equality_error ppf mode env err - (function ppf -> - fprintf ppf "The %d%s type parameter has type" + Errortrace_report.equality ppf mode env err + (msg "The %d%s type parameter has type" n (Misc.ordinal_suffix n)) - (function ppf -> - fprintf ppf "but is expected to have type") + (msg "but is expected to have type") | CM_Class_type_mismatch (env, cty1, cty2) -> Printtyp.wrap_printing_env ~error:true env (fun () -> fprintf ppf @@ -71,24 +71,18 @@ let include_err mode ppf = "is not matched by the class type" Printtyp.class_type cty2) | CM_Parameter_mismatch (n, env, err) -> - Printtyp.report_moregen_error ppf mode env err - (function ppf -> - fprintf ppf "The %d%s parameter has type" + Errortrace_report.moregen ppf mode env err + (msg "The %d%s parameter has type" n (Misc.ordinal_suffix n)) - (function ppf -> - fprintf ppf "but is expected to have type") + (msg "but is expected to have type") | CM_Val_type_mismatch (lab, env, err) -> - Printtyp.report_comparison_error ppf mode env err - (function ppf -> - fprintf ppf "The instance variable %s@ has type" lab) - (function ppf -> - fprintf ppf "but is expected to have type") + Errortrace_report.comparison ppf mode env err + (msg "The instance variable %s@ has type" lab) + (msg "but is expected to have type") | CM_Meth_type_mismatch (lab, env, err) -> - Printtyp.report_comparison_error ppf mode env err - (function ppf -> - fprintf ppf "The method %s@ has type" lab) - (function ppf -> - fprintf ppf "but is expected to have type") + Errortrace_report.comparison ppf mode env err + (msg "The method %s@ has type" lab) + (msg "but is expected to have type") | CM_Non_mutable_value lab -> fprintf ppf "@[The non-mutable instance variable %s cannot become mutable@]" lab @@ -110,9 +104,11 @@ let include_err mode ppf = | CM_Private_method lab -> fprintf ppf "@[The private method %s cannot become public@]" lab -let report_error mode ppf = function +let report_error_doc mode ppf = function | [] -> () | err :: errs -> let print_errs ppf errs = List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in fprintf ppf "@[%a%a@]" (include_err mode) err print_errs errs + +let report_error mode = Format_doc.compat (report_error_doc mode) diff --git a/src/ocaml/typing/includeclass.mli b/src/ocaml/typing/includeclass.mli index 84de6212c..a4d4d8588 100644 --- a/src/ocaml/typing/includeclass.mli +++ b/src/ocaml/typing/includeclass.mli @@ -17,7 +17,6 @@ open Types open Ctype -open Format val class_types: Env.t -> class_type -> class_type -> class_match_failure list @@ -30,4 +29,6 @@ val class_declarations: class_match_failure list val report_error : - Printtyp.type_or_scheme -> formatter -> class_match_failure list -> unit + Out_type.type_or_scheme -> class_match_failure list Format_doc.format_printer +val report_error_doc : + Out_type.type_or_scheme -> class_match_failure list Format_doc.printer diff --git a/src/ocaml/typing/includecore.ml b/src/ocaml/typing/includecore.ml index 595c07e93..e23315f1e 100644 --- a/src/ocaml/typing/includecore.ml +++ b/src/ocaml/typing/includecore.ml @@ -70,6 +70,26 @@ type value_mismatch = exception Dont_match of value_mismatch +(* A value description [vd1] is consistent with the value description [vd2] if + there is a context E such that [E |- vd1 <: vd2] for the ordinary subtyping. + For values, this is the case as soon as the kind of [vd1] is a subkind of the + [vd2] kind. *) +let value_descriptions_consistency env vd1 vd2 = + match (vd1.val_kind, vd2.val_kind) with + | (Val_prim p1, Val_prim p2) -> begin + match primitive_descriptions p1 p2 with + | None -> Tcoerce_none + | Some err -> raise (Dont_match (Primitive_mismatch err)) + end + | (Val_prim p, _) -> + let pc = + { pc_desc = p; pc_type = vd2.Types.val_type; + pc_env = env; pc_loc = vd1.Types.val_loc; } + in + Tcoerce_primitive pc + | (_, Val_prim _) -> raise (Dont_match Not_a_primitive) + | (_, _) -> Tcoerce_none + let value_descriptions ~loc env name (vd1 : Types.value_description) (vd2 : Types.value_description) = @@ -81,22 +101,7 @@ let value_descriptions ~loc env name name; match Ctype.moregeneral env true vd1.val_type vd2.val_type with | exception Ctype.Moregen err -> raise (Dont_match (Type err)) - | () -> begin - match (vd1.val_kind, vd2.val_kind) with - | (Val_prim p1, Val_prim p2) -> begin - match primitive_descriptions p1 p2 with - | None -> Tcoerce_none - | Some err -> raise (Dont_match (Primitive_mismatch err)) - end - | (Val_prim p, _) -> - let pc = - { pc_desc = p; pc_type = vd2.Types.val_type; - pc_env = env; pc_loc = vd1.Types.val_loc; } - in - Tcoerce_primitive pc - | (_, Val_prim _) -> raise (Dont_match Not_a_primitive) - | (_, _) -> Tcoerce_none - end + | () -> value_descriptions_consistency env vd1 vd2 (* Inclusion between manifest types (particularly for private row types) *) @@ -203,9 +208,11 @@ type type_mismatch = | Immediate of Type_immediacy.Violation.t module Style = Misc.Style +module Fmt = Format_doc +module Printtyp = Printtyp.Doc let report_primitive_mismatch first second ppf err = - let pr fmt = Format.fprintf ppf fmt in + let pr fmt = Fmt.fprintf ppf fmt in match (err : primitive_mismatch) with | Name -> pr "The names of the primitives are not the same" @@ -226,7 +233,7 @@ let report_primitive_mismatch first second ppf err = n (Misc.ordinal_suffix n) let report_value_mismatch first second env ppf err = - let pr fmt = Format.fprintf ppf fmt in + let pr fmt = Fmt.fprintf ppf fmt in pr "@ "; match (err : value_mismatch) with | Primitive_mismatch pm -> @@ -234,14 +241,16 @@ let report_value_mismatch first second env ppf err = | Not_a_primitive -> pr "The implementation is not a primitive." | Type trace -> - Printtyp.report_moregen_error ppf Type_scheme env trace - (fun ppf -> Format.fprintf ppf "The type") - (fun ppf -> Format.fprintf ppf "is not compatible with the type") + let msg = Fmt.Doc.msg in + Errortrace_report.moregen ppf Type_scheme env trace + (msg "The type") + (msg "is not compatible with the type") let report_type_inequality env ppf err = - Printtyp.report_equality_error ppf Type_scheme env err - (fun ppf -> Format.fprintf ppf "The type") - (fun ppf -> Format.fprintf ppf "is not equal to the type") + let msg = Fmt.Doc.msg in + Errortrace_report.equality ppf Type_scheme env err + (msg "The type") + (msg "is not equal to the type") let report_privacy_mismatch ppf err = let singular, item = @@ -251,7 +260,7 @@ let report_privacy_mismatch ppf err = | Private_record_type -> true, "record constructor" | Private_extensible_variant -> true, "extensible variant" | Private_row_type -> true, "row type" - in Format.fprintf ppf "%s %s would be revealed." + in Format_doc.fprintf ppf "%s %s would be revealed." (if singular then "A private" else "Private") item @@ -260,20 +269,20 @@ let report_label_mismatch first second env ppf err = | Type err -> report_type_inequality env ppf err | Mutability ord -> - Format.fprintf ppf "%s is mutable and %s is not." + Format_doc.fprintf ppf "%s is mutable and %s is not." (String.capitalize_ascii (choose ord first second)) (choose_other ord first second) let pp_record_diff first second prefix decl env ppf (x : record_change) = match x with | Delete cd -> - Format.fprintf ppf "%aAn extra field, %a, is provided in %s %s." + Fmt.fprintf ppf "%aAn extra field, %a, is provided in %s %s." prefix x Style.inline_code (Ident.name cd.delete.ld_id) first decl | Insert cd -> - Format.fprintf ppf "%aA field, %a, is missing in %s %s." + Fmt.fprintf ppf "%aA field, %a, is missing in %s %s." prefix x Style.inline_code (Ident.name cd.insert.ld_id) first decl | Change Type {got=lbl1; expected=lbl2; reason} -> - Format.fprintf ppf + Fmt.fprintf ppf "@[%aFields do not match:@;<1 2>\ %a@ is not the same as:\ @;<1 2>%a@ %a@]" @@ -282,34 +291,34 @@ let pp_record_diff first second prefix decl env ppf (x : record_change) = (Style.as_inline_code Printtyp.label) lbl2 (report_label_mismatch first second env) reason | Change Name n -> - Format.fprintf ppf "%aFields have different names, %a and %a." + Fmt.fprintf ppf "%aFields have different names, %a and %a." prefix x Style.inline_code n.got Style.inline_code n.expected | Swap sw -> - Format.fprintf ppf "%aFields %a and %a have been swapped." + Fmt.fprintf ppf "%aFields %a and %a have been swapped." prefix x Style.inline_code sw.first Style.inline_code sw.last | Move {name; got; expected } -> - Format.fprintf ppf + Fmt.fprintf ppf "@[<2>%aField %a has been moved@ from@ position %d@ to %d.@]" prefix x Style.inline_code name expected got let report_patch pr_diff first second decl env ppf patch = - let nl ppf () = Format.fprintf ppf "@," in + let nl ppf () = Fmt.fprintf ppf "@," in let no_prefix _ppf _ = () in match patch with | [ elt ] -> - Format.fprintf ppf "@[%a@]" + Fmt.fprintf ppf "@[%a@]" (pr_diff first second no_prefix decl env) elt | _ -> let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in - Format.fprintf ppf "@[%a@]" - (Format.pp_print_list ~pp_sep:nl pp_diff) patch + Fmt.fprintf ppf "@[%a@]" + (Fmt.pp_print_list ~pp_sep:nl pp_diff) patch let report_record_mismatch first second decl env ppf err = - let pr fmt = Format.fprintf ppf fmt in + let pr fmt = Fmt.fprintf ppf fmt in match err with | Label_mismatch patch -> report_patch pp_record_diff first second decl env ppf patch @@ -319,7 +328,7 @@ let report_record_mismatch first second decl env ppf err = "uses unboxed float representation" let report_constructor_mismatch first second decl env ppf err = - let pr fmt = Format.fprintf ppf fmt in + let pr fmt = Fmt.fprintf ppf fmt in match (err : constructor_mismatch) with | Type err -> report_type_inequality env ppf err | Arity -> pr "They have different arities." @@ -337,13 +346,13 @@ let report_constructor_mismatch first second decl env ppf err = let pp_variant_diff first second prefix decl env ppf (x : variant_change) = match x with | Delete cd -> - Format.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s." + Fmt.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s." prefix x Style.inline_code (Ident.name cd.delete.cd_id) first decl | Insert cd -> - Format.fprintf ppf "%aA constructor, %a, is missing in %s %s." + Fmt.fprintf ppf "%aA constructor, %a, is missing in %s %s." prefix x Style.inline_code (Ident.name cd.insert.cd_id) first decl | Change Type {got; expected; reason} -> - Format.fprintf ppf + Fmt.fprintf ppf "@[%aConstructors do not match:@;<1 2>\ %a@ is not the same as:\ @;<1 2>%a@ %a@]" @@ -352,24 +361,24 @@ let pp_variant_diff first second prefix decl env ppf (x : variant_change) = (Style.as_inline_code Printtyp.constructor) expected (report_constructor_mismatch first second decl env) reason | Change Name n -> - Format.fprintf ppf + Fmt.fprintf ppf "%aConstructors have different names, %a and %a." prefix x Style.inline_code n.got Style.inline_code n.expected | Swap sw -> - Format.fprintf ppf + Fmt.fprintf ppf "%aConstructors %a and %a have been swapped." prefix x Style.inline_code sw.first Style.inline_code sw.last | Move {name; got; expected} -> - Format.fprintf ppf + Fmt.fprintf ppf "@[<2>%aConstructor %a has been moved@ from@ position %d@ to %d.@]" prefix x Style.inline_code name expected got let report_extension_constructor_mismatch first second decl env ppf err = - let pr fmt = Format.fprintf ppf fmt in + let pr fmt = Fmt.fprintf ppf fmt in match (err : extension_constructor_mismatch) with | Constructor_privacy -> pr "Private extension constructor(s) would be revealed." @@ -385,8 +394,8 @@ let report_extension_constructor_mismatch first second decl env ppf err = let report_private_variant_mismatch first second decl env ppf err = - let pr fmt = Format.fprintf ppf fmt in - let pp_tag ppf x = Format.fprintf ppf "`%s" x in + let pr fmt = Fmt.fprintf ppf fmt in + let pp_tag ppf x = Fmt.fprintf ppf "`%s" x in match (err : private_variant_mismatch) with | Only_outer_closed -> (* It's only dangerous in one direction, so we don't have a position *) @@ -403,14 +412,14 @@ let report_private_variant_mismatch first second decl env ppf err = report_type_inequality env ppf err let report_private_object_mismatch env ppf err = - let pr fmt = Format.fprintf ppf fmt in + let pr fmt = Fmt.fprintf ppf fmt in match (err : private_object_mismatch) with | Missing s -> pr "The implementation is missing the method %a" Style.inline_code s | Types err -> report_type_inequality env ppf err let report_kind_mismatch first second ppf (kind1, kind2) = - let pr fmt = Format.fprintf ppf fmt in + let pr fmt = Fmt.fprintf ppf fmt in let kind_to_string = function | Kind_abstract -> "abstract" | Kind_record -> "a record" @@ -423,7 +432,7 @@ let report_kind_mismatch first second ppf (kind1, kind2) = (kind_to_string kind2) let report_type_mismatch first second decl env ppf err = - let pr fmt = Format.fprintf ppf fmt in + let pr fmt = Fmt.fprintf ppf fmt in pr "@ "; match err with | Arity -> @@ -543,14 +552,37 @@ module Record_diffing = struct | None -> Ok () let weight: Diff.change -> _ = function - | Insert _ -> 10 - | Delete _ -> 10 + | Insert _ | Delete _ -> + (* Insertion and deletion are symmetrical for definitions *) + 100 | Keep _ -> 0 - | Change (_,_,Diffing_with_keys.Name t ) -> - if t.types_match then 10 else 15 - | Change _ -> 10 - - + (* [Keep] must have the smallest weight. *) + | Change (_,_,c) -> + (* Constraints: + - [ Change < Insert + Delete ], otherwise [Change] are never optimal + + - [ Swap < Move ] => [ 2 Change < Insert + Delete ] => + [ Change < Delete ], in order to favour consecutive [Swap]s + over [Move]s. + + - For some D and a large enough R, + [Delete^D Keep^R Insert^D < Change^(D+R)] + => [ Change > (2 D)/(D+R) Delete ]. + Note that the case [D=1,R=1] is incompatible with the inequation + above. If we choose [R = D + 1] for [D<5], we can specialize the + inequation to [ Change > 10 / 11 Delete ]. *) + match c with + (* With [Type + if t.types_match then 98 else 99 + | Diffing_with_keys.Type _ -> 50 + (* With the uniqueness constraint on keys, the only relevant constraint + is [Type-only change < Name change]. Indeed, names can only match at + one position. In other words, if a [ Type ] patch is admissible, the + only admissible patches at this position are of the form [Delete^D + Name_change]. And with the constranit [Type_change < Name_change], + we have [Type_change Delete^D < Delete^D Name_change]. *) let key (x: Defs.left) = Ident.name x.ld_id let diffing loc env params1 params2 cstrs_1 cstrs_2 = @@ -662,13 +694,12 @@ module Variant_diffing = struct let update _ st = st let weight: D.change -> _ = function - | Insert _ -> 10 - | Delete _ -> 10 + | Insert _ | Delete _ -> 100 | Keep _ -> 0 - | Change (_,_,Diffing_with_keys.Name t) -> - if t.types_match then 10 else 15 - | Change _ -> 10 - + | Change (_,_,Diffing_with_keys.Name c) -> + if c.types_match then 98 else 99 + | Change (_,_,Diffing_with_keys.Type _) -> 50 + (** See {!Variant_diffing.weight} for an explanation *) let test loc env (params1,params2) ({pos; data=cd1}: D.left) @@ -890,6 +921,17 @@ let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = | () -> None end +(* A type declarations [td1] is consistent with the type declaration [td2] if + there is a context E such E |- td1 <: td2 for the ordinary subtyping. For + types, this is the case as soon as the two type declarations share the same + arity and the privacy of [td1] is less than the privacy of [td2] (consider a + context E where all type constructors are equal). *) +let type_declarations_consistency env decl1 decl2 = + if decl1.type_arity <> decl2.type_arity then Some Arity + else match privacy_mismatch env decl1 decl2 with + | Some err -> Some (Privacy err) + | None -> None + let type_declarations ?(equality = false) ~loc env ~mark name decl1 path decl2 = Builtin_attributes.check_alerts_inclusion @@ -898,12 +940,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name loc decl1.type_attributes decl2.type_attributes name; - if decl1.type_arity <> decl2.type_arity then Some Arity else - let err = - match privacy_mismatch env decl1 decl2 with - | Some err -> Some (Privacy err) - | None -> None - in + let err = type_declarations_consistency env decl1 decl2 in if err <> None then err else let err = match (decl1.type_manifest, decl2.type_manifest) with (_, None) -> diff --git a/src/ocaml/typing/includecore.mli b/src/ocaml/typing/includecore.mli index 50825976c..bed53fb03 100644 --- a/src/ocaml/typing/includecore.mli +++ b/src/ocaml/typing/includecore.mli @@ -118,6 +118,21 @@ val extension_constructors: loc:Location.t -> Env.t -> mark:bool -> Ident.t -> extension_constructor -> extension_constructor -> extension_constructor_mismatch option + +(** The functions [value_descriptions_consistency] and + [type_declarations_consistency] check if two declaration are consistent. + Declarations are consistent when there exists an environment such that the + first declaration is a subtype of the second one. + + Notably, if a type declaration [td1] is consistent with [td2] then a type + expression [te] which is well-formed with the [td2] declaration in scope + is still well-formed with the [td1] declaration: [E, td2 |- te] => [E, td1 + |- te]. *) +val value_descriptions_consistency: + Env.t -> value_description -> value_description -> module_coercion +val type_declarations_consistency: + Env.t -> type_declaration -> type_declaration -> type_mismatch option + (* val class_types: Env.t -> class_type -> class_type -> bool @@ -126,14 +141,14 @@ val class_types: val report_value_mismatch : string -> string -> Env.t -> - Format.formatter -> value_mismatch -> unit + value_mismatch Format_doc.printer val report_type_mismatch : string -> string -> string -> Env.t -> - Format.formatter -> type_mismatch -> unit + type_mismatch Format_doc.printer val report_extension_constructor_mismatch : string -> string -> string -> Env.t -> - Format.formatter -> extension_constructor_mismatch -> unit + extension_constructor_mismatch Format_doc.printer diff --git a/src/ocaml/typing/includemod.ml b/src/ocaml/typing/includemod.ml index b43602c51..f94d6f8d0 100644 --- a/src/ocaml/typing/includemod.ml +++ b/src/ocaml/typing/includemod.ml @@ -150,62 +150,64 @@ let mark_positive = function | Mark_both | Mark_positive -> true | Mark_negative | Mark_neither -> false -(* All functions "blah env x1 x2" check that x1 is included in x2, - i.e. that x1 is the type of an implementation that fulfills the - specification x2. If not, Error is raised with a backtrace of the error. *) - -(* Inclusion between value descriptions *) - -let value_descriptions ~loc env ~mark subst id vd1 vd2 = - Cmt_format.record_value_dependency vd1 vd2; - if mark_positive mark then - Env.mark_value_used vd1.val_uid; - let vd2 = Subst.value_description subst vd2 in - try - Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2) - with Includecore.Dont_match err -> - Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) - -(* Inclusion between type declarations *) - -let type_declarations ~loc env ~mark ?old_env:_ subst id decl1 decl2 = - let mark = mark_positive mark in - if mark then - Env.mark_type_used decl1.type_uid; - let decl2 = Subst.type_declaration subst decl2 in - match - Includecore.type_declarations ~loc env ~mark - (Ident.name id) decl1 (Path.Pident id) decl2 - with - | None -> Ok Tcoerce_none - | Some err -> - Error Error.(Core(Type_declarations (diff decl1 decl2 err))) - -(* Inclusion between extension constructors *) - -let extension_constructors ~loc env ~mark subst id ext1 ext2 = - let mark = mark_positive mark in - let ext2 = Subst.extension_constructor subst ext2 in - match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with - | None -> Ok Tcoerce_none - | Some err -> - Error Error.(Core(Extension_constructors(diff ext1 ext2 err))) - -(* Inclusion between class declarations *) - -let class_type_declarations ~loc ~old_env:_ env subst decl1 decl2 = - let decl2 = Subst.cltype_declaration subst decl2 in - match Includeclass.class_type_declarations ~loc env decl1 decl2 with - [] -> Ok Tcoerce_none - | reason -> - Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason))) - -let class_declarations ~old_env:_ env subst decl1 decl2 = - let decl2 = Subst.class_declaration subst decl2 in - match Includeclass.class_declarations env decl1 decl2 with - [] -> Ok Tcoerce_none - | reason -> - Error Error.(Core(Class_declarations(diff decl1 decl2 reason))) +module Core_inclusion = struct + (* All functions "blah env x1 x2" check that x1 is included in x2, + i.e. that x1 is the type of an implementation that fulfills the + specification x2. If not, Error is raised with a backtrace of the error. *) + + (* Inclusion between value descriptions *) + + let value_descriptions ~loc env ~mark subst id vd1 vd2 = + Cmt_format.record_value_dependency vd1 vd2; + if mark_positive mark then + Env.mark_value_used vd1.val_uid; + let vd2 = Subst.value_description subst vd2 in + try + Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2) + with Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) + + (* Inclusion between type declarations *) + + let type_declarations ~loc env ~mark subst id decl1 decl2 = + let mark = mark_positive mark in + if mark then + Env.mark_type_used decl1.type_uid; + let decl2 = Subst.type_declaration subst decl2 in + match + Includecore.type_declarations ~loc env ~mark + (Ident.name id) decl1 (Path.Pident id) decl2 + with + | None -> Ok Tcoerce_none + | Some err -> + Error Error.(Core(Type_declarations (diff decl1 decl2 err))) + + (* Inclusion between extension constructors *) + + let extension_constructors ~loc env ~mark subst id ext1 ext2 = + let mark = mark_positive mark in + let ext2 = Subst.extension_constructor subst ext2 in + match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with + | None -> Ok Tcoerce_none + | Some err -> + Error Error.(Core(Extension_constructors(diff ext1 ext2 err))) + + (* Inclusion between class declarations *) + + let class_type_declarations ~loc env ~mark:_ subst _id decl1 decl2 = + let decl2 = Subst.cltype_declaration subst decl2 in + match Includeclass.class_type_declarations ~loc env decl1 decl2 with + [] -> Ok Tcoerce_none + | reason -> + Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason))) + + let class_declarations ~loc:_ env ~mark:_ subst _id decl1 decl2 = + let decl2 = Subst.class_declaration subst decl2 in + match Includeclass.class_declarations env decl1 decl2 with + [] -> Ok Tcoerce_none + | reason -> + Error Error.(Core(Class_declarations(diff decl1 decl2 reason))) +end (* Expand a module type identifier when possible *) @@ -308,7 +310,7 @@ let rec print_coercion ppf c = print_coercion out | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> pr "prim %s@ (%a)" pc_desc.Primitive.prim_name - Printtyp.raw_type_expr pc_type + Rawprinttyp.type_expr pc_type | Tcoerce_alias (_, p, c) -> pr "@[<2>alias %a@ (%a)@]" Printtyp.path p @@ -407,6 +409,24 @@ module Sign_diff = struct } end +(** Core type system subtyping-like relation that we want to lift at the module + level. We have two relations that we want to lift: + + - the normal subtyping relation [<:]. + - the coarse-grain consistency relation [C], which is defined by + [d1 C d2] if there is an environment [E] such that [E |- d1 <: d2]. *) +type 'a core_incl = + loc:Location.t -> Env.t -> mark:mark -> Subst.t -> Ident.t -> + 'a -> 'a -> (module_coercion, Error.sigitem_symptom) result + +type core_relation = { + value_descriptions: Types.value_description core_incl; + type_declarations: Types.type_declaration core_incl; + extension_constructors: Types.extension_constructor core_incl; + class_declarations: Types.class_declaration core_incl; + class_type_declarations: Types.class_type_declaration core_incl; +} + (** In the group of mutual functions below, the [~in_eq] argument is [true] when we are in fact checking equality of module types. @@ -423,14 +443,14 @@ end described above. *) -let rec modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape = - match try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape with +let rec modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape = + match try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape with | Ok _ as ok -> ok | Error reason -> let mty2 = Subst.modtype Make_local subst mty2 in Error Error.(diff mty1 mty2 reason) -and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = +and try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = match mty1, mty2 with | (Mty_alias p1, Mty_alias p2) -> if Env.is_functor_arg p2 env then @@ -448,8 +468,8 @@ and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = begin match expand_module_alias ~strengthen:false env p1 with | Error e -> Error (Error.Mt_core e) | Ok mty1 -> - match strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark - subst mty1 p1 mty2 orig_shape + match strengthened_modtypes ~core ~in_eq ~loc ~aliasable:true env + ~mark subst mty1 p1 mty2 orig_shape with | Ok _ as x -> x | Error reason -> Error (Error.After_alias_expansion reason) @@ -462,20 +482,21 @@ and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = else begin match expand_modtype_path env p1, expand_modtype_path env p2 with | Some mty1, Some mty2 -> - try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape + try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape | None, _ | _, None -> Error (Error.Mt_core Abstract_module_type) end | (Mty_ident p1, _) -> let p1 = Env.normalize_modtype_path env p1 in begin match expand_modtype_path env p1 with | Some p1 -> - try_modtypes ~in_eq ~loc env ~mark subst p1 mty2 orig_shape + try_modtypes ~core ~in_eq ~loc env ~mark subst p1 mty2 orig_shape | None -> Error (Error.Mt_core Abstract_module_type) end | (_, Mty_ident p2) -> let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in begin match expand_modtype_path env p2 with - | Some p2 -> try_modtypes ~in_eq ~loc env ~mark subst mty1 p2 orig_shape + | Some p2 -> + try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 p2 orig_shape | None -> begin match mty1 with | Mty_functor _ -> @@ -487,14 +508,14 @@ and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = end | (Mty_signature sig1, Mty_signature sig2) -> begin match - signatures ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape + signatures ~core ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape with | Ok _ as ok -> ok | Error e -> Error (Error.Signature e) end | Mty_functor (param1, res1), Mty_functor (param2, res2) -> let cc_arg, env, subst = - functor_param ~in_eq ~loc env ~mark:(negate_mark mark) + functor_param ~core ~in_eq ~loc env ~mark:(negate_mark mark) subst param1 param2 in let var, res_shape = @@ -502,16 +523,18 @@ and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = | Some (var, res_shape) -> var, res_shape | None -> (* Using a fresh variable with a placeholder uid here is fine: users - will never try to jump to the definition of that variable. - If they try to jump to the parameter from inside the functor, - they will use the variable shape that is stored in the local - environment. *) + will never try to jump to the definition of that variable. If + they try to jump to the parameter from inside the functor, they + will use the variable shape that is stored in the local + environment. *) let var, shape_var = Shape.fresh_var Uid.internal_not_actually_unique in var, Shape.app orig_shape ~arg:shape_var in - let cc_res = modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape in + let cc_res = + modtypes ~core ~in_eq ~loc env ~mark subst res1 res2 res_shape + in begin match cc_arg, cc_res with | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) -> let final_shape = @@ -555,7 +578,7 @@ and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = (* Functor parameters *) -and functor_param ~in_eq ~loc env ~mark subst param1 param2 = +and functor_param ~core ~in_eq ~loc env ~mark subst param1 param2 = match param1, param2 with | Unit, Unit -> Ok Tcoerce_none, env, subst @@ -563,7 +586,7 @@ and functor_param ~in_eq ~loc env ~mark subst param1 param2 = let arg2' = Subst.modtype Keep subst arg2 in let cc_arg = match - modtypes ~in_eq ~loc env ~mark Subst.identity arg2' arg1 + modtypes ~core ~in_eq ~loc env ~mark Subst.identity arg2' arg1 Shape.dummy_mod with | Ok (cc, _) -> Ok cc @@ -591,27 +614,28 @@ and equate_one_functor_param subst env arg2' name1 name2 = | None, None -> env, subst -and strengthened_modtypes ~in_eq ~loc ~aliasable env ~mark +and strengthened_modtypes ~core ~in_eq ~loc ~aliasable env ~mark subst mty1 path1 mty2 shape = match mty1, mty2 with | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> Ok (Tcoerce_none, shape) | _, _ -> let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in - modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape + modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape -and strengthened_module_decl ~loc ~aliasable env ~mark +and strengthened_module_decl ~core ~loc ~aliasable env ~mark subst md1 path1 md2 shape = match md1.md_type, md2.md_type with | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> Ok (Tcoerce_none, shape) | _, _ -> let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in - modtypes ~in_eq:false ~loc env ~mark subst md1.md_type md2.md_type shape + modtypes ~core ~in_eq:false ~loc env ~mark subst + md1.md_type md2.md_type shape (* Inclusion between signatures *) -and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = +and signatures ~core ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = (* Environment used to check inclusion of components *) let new_env = Env.add_signature sig1 (Env.in_signature true env) in @@ -656,12 +680,12 @@ and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = Return a coercion list indicating, for all run-time components of sig2, the position of the matching run-time components of sig1 and the coercion to be applied to it. *) - let rec pair_components subst paired unpaired = function + let rec pair_components ~core subst paired unpaired = function [] -> let open Sign_diff in let d = - signature_components ~in_eq ~loc env ~mark new_env subst mod_shape - Shape.Map.empty + signature_components ~core ~in_eq ~loc env ~mark new_env subst + mod_shape Shape.Map.empty (List.rev paired) in begin match unpaired, d.errors, d.runtime_coercions, d.leftovers with @@ -710,21 +734,21 @@ and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = | Sig_class _ | Sig_class_type _ -> subst in - pair_components new_subst + pair_components ~core new_subst ((item1, item2, pos1) :: paired) unpaired rem | exception Not_found -> let unpaired = if report then item2 :: unpaired else unpaired in - pair_components subst paired unpaired rem + pair_components ~core subst paired unpaired rem end in (* Do the pairing and checking, and return the final coercion *) - pair_components subst [] [] sig2 + pair_components ~core subst [] [] sig2 (* Inclusion between signature components *) -and signature_components ~in_eq ~loc old_env ~mark env subst +and signature_components ~core ~in_eq ~loc old_env ~mark env subst orig_shape shape_map paired = match paired with | [] -> Sign_diff.{ empty with shape_map } @@ -734,7 +758,8 @@ and signature_components ~in_eq ~loc old_env ~mark env subst match sigi1, sigi2 with | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) -> let item = - value_descriptions ~loc env ~mark subst id1 valdecl1 valdecl2 + core.value_descriptions ~loc env ~mark subst id1 + valdecl1 valdecl2 in let item = mark_error_as_recoverable item in let present_at_runtime = match valdecl2.val_kind with @@ -745,7 +770,7 @@ and signature_components ~in_eq ~loc old_env ~mark env subst id1, item, shape_map, present_at_runtime | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) -> let item = - type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2 + core.type_declarations ~loc env ~mark subst id1 tydec1 tydec2 in let item = mark_error_as_unrecoverable item in (* Right now we don't filter hidden constructors / labels from the @@ -754,7 +779,7 @@ and signature_components ~in_eq ~loc old_env ~mark env subst id1, item, shape_map, false | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> let item = - extension_constructors ~loc env ~mark subst id1 ext1 ext2 + core.extension_constructors ~loc env ~mark subst id1 ext1 ext2 in let item = mark_error_as_unrecoverable item in let shape_map = @@ -767,8 +792,8 @@ and signature_components ~in_eq ~loc old_env ~mark env subst Shape.(proj orig_shape (Item.module_ id1)) in let item = - module_declarations ~in_eq ~loc env ~mark subst id1 mty1 mty2 - orig_shape + module_declarations ~core ~in_eq ~loc env ~mark subst id1 + mty1 mty2 orig_shape in let item, shape_map = match item with @@ -796,7 +821,7 @@ and signature_components ~in_eq ~loc old_env ~mark env subst end | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> let item = - modtype_infos ~in_eq ~loc env ~mark subst id1 info1 info2 + modtype_infos ~core ~in_eq ~loc env ~mark subst id1 info1 info2 in let shape_map = Shape.Map.add_module_type_proj shape_map id1 orig_shape @@ -805,7 +830,7 @@ and signature_components ~in_eq ~loc old_env ~mark env subst id1, item, shape_map, false | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> let item = - class_declarations ~old_env env subst decl1 decl2 + core.class_declarations ~loc env ~mark subst id1 decl1 decl2 in let shape_map = Shape.Map.add_class_proj shape_map id1 orig_shape @@ -814,7 +839,7 @@ and signature_components ~in_eq ~loc old_env ~mark env subst id1, item, shape_map, true | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> let item = - class_type_declarations ~loc ~old_env env subst info1 info2 + core.class_type_declarations ~loc env ~mark subst id1 info1 info2 in let item = mark_error_as_unrecoverable item in let shape_map = @@ -841,7 +866,7 @@ and signature_components ~in_eq ~loc old_env ~mark env subst in let rest = if continue then - signature_components ~in_eq ~loc old_env ~mark env subst + signature_components ~core ~in_eq ~loc old_env ~mark env subst orig_shape shape_map rem else Sign_diff.{ empty with leftovers=rem } in @@ -862,7 +887,7 @@ and module_declarations ~in_eq ~loc env ~mark subst id1 md1 md2 orig_shape = (* Inclusion between module type specifications *) -and modtype_infos ~in_eq ~loc env ~mark subst id info1 info2 = +and modtype_infos ~core ~in_eq ~loc env ~mark subst id info1 info2 = Builtin_attributes.check_alerts_inclusion ~def:info1.mtd_loc ~use:info2.mtd_loc @@ -875,17 +900,18 @@ and modtype_infos ~in_eq ~loc env ~mark subst id info1 info2 = (None, None) -> Ok Tcoerce_none | (Some _, None) -> Ok Tcoerce_none | (Some mty1, Some mty2) -> - check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 + check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 | (None, Some mty2) -> let mty1 = Mty_ident(Path.Pident id) in - check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 in + check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 in match r with | Ok _ as ok -> ok | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e)) -and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = +and check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 = let c1 = - modtypes ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 Shape.dummy_mod + modtypes ~core ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 + Shape.dummy_mod in let c2 = (* For nested module type paths, we check only one side of the equivalence: @@ -896,7 +922,7 @@ and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = else let mark = negate_mark mark in Some ( - modtypes ~in_eq:true ~loc env ~mark Subst.identity + modtypes ~core ~in_eq:true ~loc env ~mark Subst.identity mty2 mty1 Shape.dummy_mod ) in @@ -922,7 +948,34 @@ let can_alias env path = in no_apply path && not (Env.is_functor_arg path env) - +let core_inclusion = Core_inclusion.{ + type_declarations; + value_descriptions; + extension_constructors; + class_type_declarations; + class_declarations; +} + +let core_consistency = + let type_declarations ~loc:_ env ~mark:_ _ _ d1 d2 = + match Includecore.type_declarations_consistency env d1 d2 with + | None -> Ok Tcoerce_none + | Some err -> Error Error.(Core(Type_declarations (diff d1 d2 err))) + in + let value_descriptions ~loc:_ env ~mark:_ _ _ vd1 vd2 = + match Includecore.value_descriptions_consistency env vd1 vd2 with + | x -> Ok x + | exception Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) + in + let accept ~loc:_ _env ~mark:_ _subst _id _d1 _d2 = Ok Tcoerce_none in + { + type_declarations; + value_descriptions; + class_declarations=accept; + class_type_declarations=accept; + extension_constructors=accept; + } type explanation = Env.t * Error.all exception Error of explanation @@ -941,8 +994,8 @@ exception Apply_error of { let check_modtype_inclusion_raw ~loc env mty1 path1 mty2 = let aliasable = can_alias env path1 in - strengthened_modtypes ~in_eq:false ~loc ~aliasable env ~mark:Mark_both - Subst.identity mty1 path1 mty2 Shape.dummy_mod + strengthened_modtypes ~core:core_inclusion ~in_eq:false ~loc ~aliasable env + ~mark:Mark_both Subst.identity mty1 path1 mty2 Shape.dummy_mod |> Result.map fst let check_modtype_inclusion ~loc env mty1 path1 mty2 = @@ -977,9 +1030,10 @@ let () = interface. *) let compunit env ~mark impl_name impl_sig intf_name intf_sig unit_shape = + let loc = Location.in_file impl_name in match - signatures ~in_eq:false ~loc:(Location.in_file impl_name) env ~mark - Subst.identity impl_sig intf_sig unit_shape + signatures ~core:core_inclusion ~in_eq:false ~loc env + ~mark Subst.identity impl_sig intf_sig unit_shape with Result.Error reasons -> let cdiff = Error.In_Compilation_unit(Error.diff impl_name intf_name reasons) in @@ -1082,8 +1136,8 @@ module Functor_inclusion_diff = struct let test st mty1 mty2 = let loc = Location.none in let res, _, _ = - functor_param ~in_eq:false ~loc st.env ~mark:Mark_neither - st.subst mty1 mty2 + functor_param ~core:core_inclusion ~in_eq:false ~loc st.env + ~mark:Mark_neither st.subst mty1 mty2 in res let update = update @@ -1177,8 +1231,9 @@ module Functor_app_diff = struct Result.Error (Error.Incompatible_params(arg,param)) | ( Anonymous | Named _ | Empty_struct ), Named (_, param) -> match - modtypes ~in_eq:false ~loc state.env ~mark:Mark_neither - state.subst arg_mty param Shape.dummy_mod + modtypes ~core:core_inclusion ~in_eq:false ~loc state.env + ~mark:Mark_neither state.subst arg_mty param + Shape.dummy_mod with | Error mty -> Result.Error (Error.Mismatch mty) | Ok (cc, _) -> Ok cc @@ -1199,36 +1254,45 @@ end (* Hide the context and substitution parameters to the outside world *) let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 = - match modtypes ~in_eq:false ~loc env ~mark + match modtypes ~core:core_inclusion ~in_eq:false ~loc env ~mark Subst.identity mty1 mty2 shape with | Ok (cc, shape) -> cc, shape | Error reason -> raise (Error (env, Error.(In_Module_type reason))) +let modtypes_consistency ~loc env mty1 mty2 = + match modtypes ~core:core_consistency ~in_eq:false ~loc env ~mark:Mark_neither + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok _ -> () + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + let modtypes ~loc env ~mark mty1 mty2 = - match modtypes ~in_eq:false ~loc env ~mark + match modtypes ~core:core_inclusion ~in_eq:false ~loc env ~mark Subst.identity mty1 mty2 Shape.dummy_mod with | Ok (cc, _) -> cc | Error reason -> raise (Error (env, Error.(In_Module_type reason))) let signatures env ~mark sig1 sig2 = - match signatures ~in_eq:false ~loc:Location.none env ~mark - Subst.identity sig1 sig2 Shape.dummy_mod + match signatures ~core:core_inclusion ~in_eq:false ~loc:Location.none env + ~mark Subst.identity sig1 sig2 Shape.dummy_mod with | Ok (cc, _) -> cc | Error reason -> raise (Error(env,Error.(In_Signature reason))) let type_declarations ~loc env ~mark id decl1 decl2 = - match type_declarations ~loc env ~mark Subst.identity id decl1 decl2 with + match Core_inclusion.type_declarations ~loc env ~mark + Subst.identity id decl1 decl2 + with | Ok _ -> () | Error (Error.Core reason) -> raise (Error(env,Error.(In_Type_declaration(id,reason)))) | Error _ -> assert false let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 = - match strengthened_module_decl ~loc ~aliasable env ~mark Subst.identity - md1 path1 md2 Shape.dummy_mod with + match strengthened_module_decl ~core:core_inclusion ~loc ~aliasable env ~mark + Subst.identity md1 path1 md2 Shape.dummy_mod with | Ok (x, _shape) -> x | Error mdiff -> raise (Error(env,Error.(In_Module_type mdiff))) @@ -1240,7 +1304,9 @@ let expand_module_alias ~strengthen env path = raise (Error(env,In_Expansion(Error.Unbound_module_path path))) let check_modtype_equiv ~loc env id mty1 mty2 = - match check_modtype_equiv ~in_eq:false ~loc env ~mark:Mark_both mty1 mty2 with + match check_modtype_equiv ~core:core_inclusion ~in_eq:false ~loc env + ~mark:Mark_both mty1 mty2 + with | Ok _ -> () | Error e -> raise (Error(env, diff --git a/src/ocaml/typing/includemod.mli b/src/ocaml/typing/includemod.mli index a57d51b67..d0e04178b 100644 --- a/src/ocaml/typing/includemod.mli +++ b/src/ocaml/typing/includemod.mli @@ -155,6 +155,10 @@ val modtypes: loc:Location.t -> Env.t -> mark:mark -> module_type -> module_type -> module_coercion + +val modtypes_consistency: + loc:Location.t -> Env.t -> module_type -> module_type -> unit + val modtypes_with_shape: shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark -> module_type -> module_type -> module_coercion * Shape.t diff --git a/src/ocaml/typing/includemod_errorprinter.ml b/src/ocaml/typing/includemod_errorprinter.ml index 0ffd000bb..c1c08ff82 100644 --- a/src/ocaml/typing/includemod_errorprinter.ml +++ b/src/ocaml/typing/includemod_errorprinter.ml @@ -14,6 +14,8 @@ (**************************************************************************) module Style = Misc.Style +module Fmt = Format_doc +module Printtyp = Printtyp.Doc module Context = struct type pos = @@ -34,28 +36,28 @@ module Context = struct let rec context ppf = function Module id :: rem -> - Format.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem + Fmt.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem | Modtype id :: rem -> - Format.fprintf ppf "@[<2>module type %a =@ %a@]" + Fmt.fprintf ppf "@[<2>module type %a =@ %a@]" Printtyp.ident id context_mty rem | Body x :: rem -> - Format.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem + Fmt.fprintf ppf "(%s) ->@ %a" (argname x) context_mty rem | Arg x :: rem -> - Format.fprintf ppf "functor (%s : %a) -> ..." + Fmt.fprintf ppf "(%s : %a) -> ..." (argname x) context_mty rem | [] -> - Format.fprintf ppf "" + Fmt.fprintf ppf "" and context_mty ppf = function (Module _ | Modtype _) :: _ as rem -> - Format.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + Fmt.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem | cxt -> context ppf cxt and args ppf = function Body x :: rem -> - Format.fprintf ppf "(%s)%a" (argname x) args rem + Fmt.fprintf ppf "(%s)%a" (argname x) args rem | Arg x :: rem -> - Format.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem + Fmt.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem | cxt -> - Format.fprintf ppf " :@ %a" context_mty cxt + Fmt.fprintf ppf " :@ %a" context_mty cxt and argname = function | Types.Unit -> "" | Types.Named (None, _) -> "_" @@ -64,25 +66,24 @@ module Context = struct let alt_pp ppf cxt = if cxt = [] then () else if List.for_all (function Module _ -> true | _ -> false) cxt then - Format.fprintf ppf "in module %a," + Fmt.fprintf ppf ",@ in module %a" (Style.as_inline_code Printtyp.path) (path_of_context cxt) else - Format.fprintf ppf "@[at position@ %a,@]" + Fmt.fprintf ppf ",@ @[at position@ %a@]" (Style.as_inline_code context) cxt let pp ppf cxt = if cxt = [] then () else if List.for_all (function Module _ -> true | _ -> false) cxt then - Format.fprintf ppf "In module %a:@ " + Fmt.fprintf ppf "In module %a:@ " (Style.as_inline_code Printtyp.path) (path_of_context cxt) else - Format.fprintf ppf "@[At position@ %a@]@ " + Fmt.fprintf ppf "@[At position@ %a@]@ " (Style.as_inline_code context) cxt end -module Illegal_permutation = struct - (** Extraction of information in case of illegal permutation - in a module type *) +module Runtime_coercion = struct + (** Extraction of a small change from a non-identity runtime coercion *) (** When examining coercions, we only have runtime component indices, we use thus a limited version of {!pos}. *) @@ -95,43 +96,50 @@ module Illegal_permutation = struct | None -> g y | Some _ as v -> v - (** We extract a lone transposition from a full tree of permutations. *) - let rec transposition_under path (coerc:Typedtree.module_coercion) = + type change = + | Transposition of int * int + | Primitive_coercion of string + | Alias_coercion of Path.t + + (** We extract a small change from a full coercion. *) + let rec first_change_under path (coerc:Typedtree.module_coercion) = match coerc with | Tcoerce_structure(c,_) -> either - (not_fixpoint path 0) c + (first_item_transposition path 0) c (first_non_id path 0) c | Tcoerce_functor(arg,res) -> either - (transposition_under (InArg::path)) arg - (transposition_under (InBody::path)) res + (first_change_under (InArg::path)) arg + (first_change_under (InBody::path)) res | Tcoerce_none -> None - | Tcoerce_alias _ | Tcoerce_primitive _ -> - (* these coercions are not inversible, and raise an error earlier when - checking for module type equivalence *) - assert false + | Tcoerce_alias _ | Tcoerce_primitive _ -> None + (* we search the first point which is not invariant at the current level *) - and not_fixpoint path pos = function + and first_item_transposition path pos = function | [] -> None | (n, _) :: q -> - if n = pos then - not_fixpoint path (pos+1) q + if n < 0 || n = pos then + (* when n < 0, this is not a transposition but a kind coercion, + which will be covered in the first_non_id case *) + first_item_transposition path (pos+1) q else - Some(List.rev path, pos, n) + Some(List.rev path, Transposition (pos, n)) (* we search the first item with a non-identity inner coercion *) and first_non_id path pos = function | [] -> None | (_, Typedtree.Tcoerce_none) :: q -> first_non_id path (pos + 1) q + | (_, Typedtree.Tcoerce_alias (_,p,_)) :: _ -> + Some (List.rev path, Alias_coercion p) + | (_, Typedtree.Tcoerce_primitive p) :: _ -> + let name = Primitive.byte_name p.pc_desc in + Some (List.rev path, Primitive_coercion name) | (_,c) :: q -> either - (transposition_under (Item pos :: path)) c + (first_change_under (Item pos :: path)) c (first_non_id path (pos + 1)) q - let transposition c = - match transposition_under [] c with - | None -> raise Not_found - | Some x -> x + let first_change c = first_change_under [] c let rec runtime_item k = function | [] -> raise Not_found @@ -168,23 +176,64 @@ module Illegal_permutation = struct let item mt k = Includemod.item_ident_name (runtime_item k mt) let pp_item ppf (id,_,kind) = - Format.fprintf ppf "%s %a" + Fmt.fprintf ppf "%s %a" (Includemod.kind_of_field_desc kind) Style.inline_code (Ident.name id) - let pp ctx_printer env ppf (mty,c) = + let illegal_permutation ctx_printer env ppf (mty,c) = + match first_change c with + | None | Some (_, (Primitive_coercion _ | Alias_coercion _)) -> + (* those kind coercions are not inversible, and raise an error earlier + when checking for module type equivalence *) + assert false + | Some (path, Transposition (k,l)) -> try - let p, k, l = transposition c in - let ctx, mt = find env p mty in - Format.fprintf ppf + let ctx, mt = find env path mty in + Fmt.fprintf ppf "@[Illegal permutation of runtime components in a module type.@ \ - @[For example,@ %a@]@ @[the %a@ and the %a are not in the same order@ \ + @[For example%a,@]@ @[the %a@ and the %a are not in the same order@ \ in the expected and actual module types.@]@]" ctx_printer ctx pp_item (item mt k) pp_item (item mt l) with Not_found -> (* this should not happen *) - Format.fprintf ppf + Fmt.fprintf ppf "Illegal permutation of runtime components in a module type." + let in_package_subtype ctx_printer env mty c ppf = + match first_change c with + | None -> + (* The coercion looks like the identity but was not simplified to + [Tcoerce_none], this only happens when the two first-class module + types differ by runtime size *) + Fmt.fprintf ppf + "The two first-class module types differ by their runtime size." + | Some (path, c) -> + try + let ctx, mt = find env path mty in + match c with + | Primitive_coercion prim_name -> + Fmt.fprintf ppf + "@[The two first-class module types differ by a coercion of@ \ + the primitive %a@ to a value%a.@]" + Style.inline_code prim_name + ctx_printer ctx + | Alias_coercion path -> + Fmt.fprintf ppf + "@[The two first-class module types differ by a coercion of@ \ + a module alias %a@ to a module%a.@]" + (Style.as_inline_code Printtyp.path) path + ctx_printer ctx + | Transposition (k,l) -> + Fmt.fprintf ppf + "@[@[The two first-class module types do not share@ \ + the same positions for runtime components.@]@ \ + @[For example,%a@ the %a@ occurs at the expected position of@ \ + the %a.@]@]" + ctx_printer ctx pp_item (item mt k) pp_item (item mt l) + with Not_found -> + Fmt.fprintf ppf + "@[The two packages types do not share@ \ + the@ same@ positions@ for@ runtime@ components.@]" + end @@ -204,7 +253,7 @@ let is_big obj = let show_loc msg ppf loc = let pos = loc.Location.loc_start in if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then () - else Format.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg + else Fmt.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.Doc.loc loc msg let show_locs ppf (loc1, loc2) = show_loc "Expected declaration" ppf loc2; @@ -212,10 +261,10 @@ let show_locs ppf (loc1, loc2) = let dmodtype mty = - let tmty = Printtyp.tree_of_modtype mty in - Format.dprintf "%a" !Oprint.out_module_type tmty + let tmty = Out_type.tree_of_modtype mty in + Fmt.dprintf "%a" !Oprint.out_module_type tmty -let space ppf () = Format.fprintf ppf "@ " +let space ppf () = Fmt.fprintf ppf "@ " (** In order to display a list of functor arguments in a compact format, @@ -264,8 +313,8 @@ module With_shorthand = struct let make side pos = match side with - | Got -> Format.sprintf "$S%d" pos - | Expected -> Format.sprintf "$T%d" pos + | Got -> Fmt.asprintf "$S%d" pos + | Expected -> Fmt.asprintf "$T%d" pos | Unneeded -> "..." (** Add shorthands to a patch *) @@ -311,43 +360,43 @@ module With_shorthand = struct (** Printing of arguments with shorthands *) let pp ppx = function | Original x -> ppx x - | Synthetic s -> Format.dprintf "%s" s.name + | Synthetic s -> Fmt.dprintf "%s" s.name let pp_orig ppx = function | Original x | Synthetic { item=x; _ } -> ppx x let definition x = match functor_param x with - | Unit -> Format.dprintf "()" + | Unit -> Fmt.dprintf "()" | Named(_,short_mty) -> match short_mty with | Original mty -> dmodtype mty | Synthetic {name; item = mty} -> - Format.dprintf + Fmt.dprintf "%s@ =@ %t" name (dmodtype mty) let param x = match functor_param x with - | Unit -> Format.dprintf "()" + | Unit -> Fmt.dprintf "()" | Named (_, short_mty) -> pp dmodtype short_mty let qualified_param x = match functor_param x with - | Unit -> Format.dprintf "()" + | Unit -> Fmt.dprintf "()" | Named (None, Original (Mty_signature []) ) -> - Format.dprintf "(sig end)" + Fmt.dprintf "(sig end)" | Named (None, short_mty) -> pp dmodtype short_mty | Named (Some p, short_mty) -> - Format.dprintf "(%s : %t)" + Fmt.dprintf "(%s : %t)" (Ident.name p) (pp dmodtype short_mty) let definition_of_argument ua = let arg, mty = ua.item in match (arg: Err.functor_arg_descr) with - | Unit -> Format.dprintf "()" - | Empty_struct -> Format.dprintf "(struct end)" + | Unit -> Fmt.dprintf "()" + | Empty_struct -> Fmt.dprintf "(struct end)" | Named p -> let mty = modtype { ua with item = mty } in - Format.dprintf + Fmt.dprintf "%a@ :@ %t" Printtyp.path p (pp_orig dmodtype mty) @@ -356,14 +405,14 @@ module With_shorthand = struct begin match short_mty with | Original mty -> dmodtype mty | Synthetic {name; item=mty} -> - Format.dprintf "%s@ :@ %t" name (dmodtype mty) + Fmt.dprintf "%s@ :@ %t" name (dmodtype mty) end let arg ua = let arg, mty = ua.item in match (arg: Err.functor_arg_descr) with - | Unit -> Format.dprintf "()" - | Empty_struct -> Format.dprintf "(struct end)" + | Unit -> Fmt.dprintf "()" + | Empty_struct -> Fmt.dprintf "(struct end)" | Named p -> fun ppf -> Printtyp.path ppf p | Anonymous -> let short_mty = modtype { ua with item=mty } in @@ -379,17 +428,38 @@ module Functor_suberror = struct | Types.Named (Some _ as x,_) -> x | Types.(Unit | Named(None,_)) -> None - (** Print the list of params with style *) + +(** Print a list of functor parameters with style while adjusting the printing + environment for each functor argument. + + Currently, we are disabling disambiguation for functor argument name to + avoid the need to track the moving association between identifiers and + syntactic names in situation like: + + got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T) + expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T) +*) let pretty_params sep proj printer patch = - let elt (x,param) = + let pp_param (x,param) = let sty = Diffing.(style @@ classify x) in - Format.dprintf "%a%t%a" - Format.pp_open_stag (Style.Style sty) + Fmt.dprintf "%a%t%a" + Fmt.pp_open_stag (Style.Style sty) (printer param) - Format.pp_close_stag () + Fmt.pp_close_stag () + in + let rec pp_params = function + | [] -> ignore + | [_,param] -> pp_param param + | (id,param) :: q -> + Fmt.dprintf "%t%a%t" + (pp_param param) sep () (hide_id id q) + and hide_id id q = + match id with + | None -> pp_params q + | Some id -> Out_type.Ident_names.with_fuzzy id (fun () -> pp_params q) in let params = List.filter_map proj @@ List.map snd patch in - Printtyp.functor_parameters ~sep elt params + pp_params params let expected d = let extract: _ Diffing.change -> _ = function @@ -425,17 +495,17 @@ module Functor_suberror = struct pretty_params space extract With_shorthand.qualified_param d let insert mty = - Format.dprintf + Fmt.dprintf "An argument appears to be missing with module type@;<1 2>@[%t@]" (With_shorthand.definition mty) let delete mty = - Format.dprintf + Fmt.dprintf "An extra argument is provided of module type@;<1 2>@[%t@]" (With_shorthand.definition mty) let ok x y = - Format.dprintf + Fmt.dprintf "Module types %t and %t match" (With_shorthand.param x) (With_shorthand.param y) @@ -443,17 +513,17 @@ module Functor_suberror = struct let diff g e more = let g = With_shorthand.definition g in let e = With_shorthand.definition e in - Format.dprintf + Fmt.dprintf "Module types do not match:@ @[%t@]@;<1 -2>does not include@ \ @[%t@]%t" g e (more ()) let incompatible = function | Types.Unit -> - Format.dprintf + Fmt.dprintf "The functor was expected to be applicative at this position" | Types.Named _ -> - Format.dprintf + Fmt.dprintf "The functor was expected to be generative at this position" let patch env got expected = @@ -479,7 +549,7 @@ module Functor_suberror = struct pretty_params space extract With_shorthand.arg d let delete mty = - Format.dprintf + Fmt.dprintf "The following extra argument is provided@;<1 2>@[%t@]" (With_shorthand.definition_of_argument mty) @@ -488,10 +558,10 @@ module Functor_suberror = struct let ok x y = let pp_orig_name = match With_shorthand.functor_param y with | With_shorthand.Named (_, Original mty) -> - Format.dprintf " %t" (dmodtype mty) + Fmt.dprintf " %t" (dmodtype mty) | _ -> ignore in - Format.dprintf + Fmt.dprintf "Module %t matches the expected module type%t" (With_shorthand.arg x) pp_orig_name @@ -499,7 +569,7 @@ module Functor_suberror = struct let diff g e more = let g = With_shorthand.definition_of_argument g in let e = With_shorthand.definition e in - Format.dprintf + Fmt.dprintf "Modules do not match:@ @[%t@]@;<1 -2>\ is not included in@ @[%t@]%t" g e (more ()) @@ -510,10 +580,10 @@ module Functor_suberror = struct let single_diff g e more = let _arg, mty = g.With_shorthand.item in let e = match e.With_shorthand.item with - | Types.Unit -> Format.dprintf "()" + | Types.Unit -> Fmt.dprintf "()" | Types.Named(_, mty) -> dmodtype mty in - Format.dprintf + Fmt.dprintf "Modules do not match:@ @[%t@]@;<1 -2>\ is not included in@ @[%t@]%t" (dmodtype mty) e (more ()) @@ -521,10 +591,10 @@ module Functor_suberror = struct let incompatible = function | Unit -> - Format.dprintf + Fmt.dprintf "The functor was expected to be applicative at this position" | Named _ | Anonymous -> - Format.dprintf + Fmt.dprintf "The functor was expected to be generative at this position" | Empty_struct -> (* an empty structure can be used in both applicative and generative @@ -534,18 +604,18 @@ module Functor_suberror = struct let subcase sub ~expansion_token env (pos, diff) = Location.msg "%a%a%a%a@[%t@]%a" - Format.pp_print_tab () - Format.pp_open_tbox () + Fmt.pp_print_tab () + Fmt.pp_open_tbox () Diffing.prefix (pos, Diffing.classify diff) - Format.pp_set_tab () + Fmt.pp_set_tab () (Printtyp.wrap_printing_env env ~error:true (fun () -> sub ~expansion_token env diff) ) - Format.pp_close_tbox () + Fmt.pp_close_tbox () let onlycase sub ~expansion_token env (_, diff) = Location.msg "%a@[%t@]" - Format.pp_print_tab () + Fmt.pp_print_tab () (Printtyp.wrap_printing_env env ~error:true (fun () -> sub ~expansion_token env diff) ) @@ -592,122 +662,113 @@ let coalesce msgs = | [] -> ignore | before -> let ctx ppf = - Format.pp_print_list ~pp_sep:space - (fun ppf x -> x.Location.txt ppf) + Fmt.pp_print_list ~pp_sep:space + (fun ppf x -> Fmt.pp_doc ppf x.Location.txt) ppf before in ctx let subcase_list l ppf = match l with | [] -> () | _ :: _ -> - Format.fprintf ppf "@;<1 -2>@[%a@]" - (Format.pp_print_list ~pp_sep:space - (fun ppf f -> f.Location.txt ppf) - ) + let pp_msg ppf lmsg = Fmt.pp_doc ppf lmsg.Location.txt in + Fmt.fprintf ppf "@;<1 -2>@[%a@]" + (Fmt.pp_print_list ~pp_sep:space pp_msg) (List.rev l) (* Printers for leaves *) let core env id x = match x with | Err.Value_descriptions diff -> - Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" "Values do not match" !Oprint.out_sig_item - (Printtyp.tree_of_value_description id diff.got) + (Out_type.tree_of_value_description id diff.got) "is not included in" !Oprint.out_sig_item - (Printtyp.tree_of_value_description id diff.expected) + (Out_type.tree_of_value_description id diff.expected) (Includecore.report_value_mismatch "the first" "the second" env) diff.symptom show_locs (diff.got.val_loc, diff.expected.val_loc) - Printtyp.Conflicts.print_explanations | Err.Type_declarations diff -> - Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" "Type declarations do not match" !Oprint.out_sig_item - (Printtyp.tree_of_type_declaration id diff.got Trec_first) + (Out_type.tree_of_type_declaration id diff.got Trec_first) "is not included in" !Oprint.out_sig_item - (Printtyp.tree_of_type_declaration id diff.expected Trec_first) + (Out_type.tree_of_type_declaration id diff.expected Trec_first) (Includecore.report_type_mismatch "the first" "the second" "declaration" env) diff.symptom show_locs (diff.got.type_loc, diff.expected.type_loc) - Printtyp.Conflicts.print_explanations | Err.Extension_constructors diff -> - Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a%t@]" + Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]" "Extension declarations do not match" !Oprint.out_sig_item - (Printtyp.tree_of_extension_constructor id diff.got Text_first) + (Out_type.tree_of_extension_constructor id diff.got Text_first) "is not included in" !Oprint.out_sig_item - (Printtyp.tree_of_extension_constructor id diff.expected Text_first) + (Out_type.tree_of_extension_constructor id diff.expected Text_first) (Includecore.report_extension_constructor_mismatch "the first" "the second" "declaration" env) diff.symptom show_locs (diff.got.ext_loc, diff.expected.ext_loc) - Printtyp.Conflicts.print_explanations | Err.Class_type_declarations diff -> - Format.dprintf + Fmt.dprintf "@[Class type declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]@ %a%t" + %a@;<1 -2>does not match@ %a@]@ %a" !Oprint.out_sig_item - (Printtyp.tree_of_cltype_declaration id diff.got Trec_first) + (Out_type.tree_of_cltype_declaration id diff.got Trec_first) !Oprint.out_sig_item - (Printtyp.tree_of_cltype_declaration id diff.expected Trec_first) - (Includeclass.report_error Type_scheme) diff.symptom - Printtyp.Conflicts.print_explanations + (Out_type.tree_of_cltype_declaration id diff.expected Trec_first) + (Includeclass.report_error_doc Type_scheme) diff.symptom | Err.Class_declarations {got;expected;symptom} -> - let t1 = Printtyp.tree_of_class_declaration id got Trec_first in - let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in - Format.dprintf + let t1 = Out_type.tree_of_class_declaration id got Trec_first in + let t2 = Out_type.tree_of_class_declaration id expected Trec_first in + Fmt.dprintf "@[Class declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]@ %a%t" + %a@;<1 -2>does not match@ %a@]@ %a" !Oprint.out_sig_item t1 !Oprint.out_sig_item t2 - (Includeclass.report_error Type_scheme) symptom - Printtyp.Conflicts.print_explanations + (Includeclass.report_error_doc Type_scheme) symptom let missing_field ppf item = let id, loc, kind = Includemod.item_ident_name item in - Format.fprintf ppf "The %s %a is required but not provided%a" + Fmt.fprintf ppf "The %s %a is required but not provided%a" (Includemod.kind_of_field_desc kind) (Style.as_inline_code Printtyp.ident) id (show_loc "Expected declaration") loc let module_types {Err.got=mty1; expected=mty2} = - Format.dprintf + Fmt.dprintf "@[Modules do not match:@ \ %a@;<1 -2>is not included in@ %a@]" - !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) - !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) + !Oprint.out_module_type (Out_type.tree_of_modtype mty1) + !Oprint.out_module_type (Out_type.tree_of_modtype mty2) let eq_module_types {Err.got=mty1; expected=mty2} = - Format.dprintf + Fmt.dprintf "@[Module types do not match:@ \ %a@;<1 -2>is not equal to@ %a@]" - !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) - !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) + !Oprint.out_module_type (Out_type.tree_of_modtype mty1) + !Oprint.out_module_type (Out_type.tree_of_modtype mty2) let module_type_declarations id {Err.got=d1 ; expected=d2} = - Format.dprintf + Fmt.dprintf "@[Module type declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]" - !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1) - !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2) + !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration id d1) + !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration id d2) let interface_mismatch ppf (diff: _ Err.diff) = - Format.fprintf ppf + Fmt.fprintf ppf "The implementation %a@ does not match the interface %a:@ " Style.inline_code diff.got Style.inline_code diff.expected let core_module_type_symptom (x:Err.core_module_type_symptom) = match x with | Not_an_alias | Not_an_identifier | Abstract_module_type - | Incompatible_aliases -> - if Printtyp.Conflicts.exists () then - Some Printtyp.Conflicts.print_explanations - else None + | Incompatible_aliases -> None | Unbound_module_path path -> - Some(Format.dprintf "Unbound module %a" + Some(Fmt.dprintf "Unbound module %a" (Style.as_inline_code Printtyp.path) path ) @@ -749,7 +810,7 @@ and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function module_type ~eqmode ~expansion_token ~env ~before ~ctx diff | Invalid_module_alias path -> let printer = - Format.dprintf "Module %a cannot be aliased" + Fmt.dprintf "Module %a cannot be aliased" (Style.as_inline_code Printtyp.path) path in dwith_context ctx printer :: before @@ -759,10 +820,10 @@ and functor_params ~expansion_token ~env ~before ~ctx {got;expected;_} = let actual = Functor_suberror.Inclusion.got d in let expected = Functor_suberror.expected d in let main = - Format.dprintf + Fmt.dprintf "@[Modules do not match:@ \ - @[functor@ %t@ -> ...@]@;<1 -2>is not included in@ \ - @[functor@ %t@ -> ...@]@]" + @[%t@ -> ...@]@;<1 -2>is not included in@ \ + @[%t@ -> ...@]@]" actual expected in let msgs = dwith_context ctx main :: before in @@ -785,8 +846,8 @@ and signature ~expansion_token ~env:_ ~before ~ctx sgs = if expansion_token then let init_missings, last_missing = Misc.split_last missings in List.map (Location.msg "%a" missing_field) init_missings - @ [ with_context ctx missing_field last_missing ] - @ before + @ with_context ctx missing_field last_missing + :: before else before | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a @@ -826,7 +887,7 @@ and module_type_decl ~expansion_token ~env ~before ~ctx id diff = | None -> assert false | Some mty -> with_context (Modtype id::ctx) - (Illegal_permutation.pp Context.alt_pp env) (mty,c) + (Runtime_coercion.illegal_permutation Context.alt_pp env) (mty,c) :: before end @@ -875,7 +936,7 @@ let module_type_subst ~env id diff = let mty = diff.got in let main = with_context [Modtype id] - (Illegal_permutation.pp Context.alt_pp env) (mty,c) in + (Runtime_coercion.illegal_permutation Context.alt_pp env) (mty,c) in [main] let all env = function @@ -898,29 +959,32 @@ let all env = function (* General error reporting *) -let err_msgs (env, err) = - Printtyp.Conflicts.reset(); +let err_msgs ppf (env, err) = Printtyp.wrap_printing_env ~error:true env - (fun () -> coalesce @@ all env err) + (fun () -> (coalesce @@ all env err) ppf) -let report_error err = - let main = err_msgs err in - Location.errorf ~loc:Location.(in_file !input_name) "%t" main +let report_error_doc err = + Location.errorf + ~loc:Location.(in_file !input_name) + ~footnote:Out_type.Ident_conflicts.err_msg + "%a" err_msgs err -let report_apply_error ~loc env (app_name, mty_f, args) = +let report_apply_error_doc ~loc env (app_name, mty_f, args) = + let footnote = Out_type.Ident_conflicts.err_msg in let d = Functor_suberror.App.patch env ~f:mty_f ~args in match d with (* We specialize the one change and one argument case to remove the presentation of the functor arguments *) | [ _, Change (_, _, Err.Incompatible_params (i,_)) ] -> - Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i) + Location.errorf ~loc ~footnote "%t" (Functor_suberror.App.incompatible i) | [ _, Change (g, e, Err.Mismatch mty_diff) ] -> let more () = subcase_list @@ module_type_symptom ~eqmode:false ~expansion_token:true ~env ~before:[] ~ctx:[] mty_diff.symptom in - Location.errorf ~loc "%t" (Functor_suberror.App.single_diff g e more) + Location.errorf ~loc ~footnote "%t" + (Functor_suberror.App.single_diff g e more) | _ -> let not_functor = List.for_all (function _, Diffing.Delete _ -> true | _ -> false) d @@ -944,12 +1008,12 @@ let report_apply_error ~loc env (app_name, mty_f, args) = let intro ppf = match app_name with | Includemod.Anonymous_functor -> - Format.fprintf ppf "This functor application is ill-typed." + Fmt.fprintf ppf "This functor application is ill-typed." | Includemod.Full_application_path lid -> - Format.fprintf ppf "The functor application %a is ill-typed." + Fmt.fprintf ppf "The functor application %a is ill-typed." (Style.as_inline_code Printtyp.longident) lid | Includemod.Named_leftmost_functor lid -> - Format.fprintf ppf + Fmt.fprintf ppf "This application of the functor %a is ill-typed." (Style.as_inline_code Printtyp.longident) lid in @@ -959,20 +1023,24 @@ let report_apply_error ~loc env (app_name, mty_f, args) = List.rev @@ Functor_suberror.params functor_app_diff env ~expansion_token:true d in - Location.errorf ~loc ~sub + Location.errorf ~loc ~sub ~footnote "@[%t@ \ These arguments:@;<1 2>@[%t@]@ \ - do not match these parameters:@;<1 2>@[functor@ %t@ -> ...@]@]" + do not match these parameters:@;<1 2>@[%t@ -> ...@]@]" intro actual expected +let coercion_in_package_subtype env mty c = + Format_doc.doc_printf "%t" @@ + Runtime_coercion.in_package_subtype Context.alt_pp env mty c + let register () = Location.register_error_of_exn (function - | Includemod.Error err -> Some (report_error err) + | Includemod.Error err -> Some (report_error_doc err) | Includemod.Apply_error {loc; env; app_name; mty_f; args} -> Some (Printtyp.wrap_printing_env env ~error:true (fun () -> - report_apply_error ~loc env (app_name, mty_f, args)) + report_apply_error_doc ~loc env (app_name, mty_f, args)) ) | _ -> None ) diff --git a/src/ocaml/typing/includemod_errorprinter.mli b/src/ocaml/typing/includemod_errorprinter.mli index 12ea2169b..0c7dda4e5 100644 --- a/src/ocaml/typing/includemod_errorprinter.mli +++ b/src/ocaml/typing/includemod_errorprinter.mli @@ -13,5 +13,7 @@ (* *) (**************************************************************************) -val err_msgs: Includemod.explanation -> Format.formatter -> unit +val err_msgs: Includemod.explanation Format_doc.printer +val coercion_in_package_subtype: + Env.t -> Types.module_type -> Typedtree.module_coercion -> Format_doc.doc val register: unit -> unit diff --git a/src/ocaml/typing/mtype.ml b/src/ocaml/typing/mtype.ml index b12dfde8c..e563d2671 100644 --- a/src/ocaml/typing/mtype.ml +++ b/src/ocaml/typing/mtype.ml @@ -460,9 +460,11 @@ let collect_arg_paths mty = and bindings = ref Ident.empty in (* let rt = Ident.create "Root" in and prefix = ref (Path.Pident rt) in *) + with_type_mark begin fun mark -> + let super = type_iterators mark in let it_path p = paths := Path.Set.union (get_arg_paths p) !paths and it_signature_item it si = - type_iterators.it_signature_item it si; + super.it_signature_item it si; match si with | Sig_module (id, _, {md_type=Mty_alias p}, _, _) -> bindings := Ident.add id p !bindings @@ -475,11 +477,11 @@ let collect_arg_paths mty = sg | _ -> () in - let it = {type_iterators with it_path; it_signature_item} in + let it = {super with it_path; it_signature_item} in it.it_module_type it mty; - it.it_module_type unmark_iterators mty; Path.Set.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p)) !paths Ident.Set.empty + end type remove_alias_args = { mutable modified: bool; @@ -556,14 +558,16 @@ let scrape_for_type_of ~remove_aliases env mty = let lower_nongen nglev mty = let open Btype in - let it_type_expr it ty = + with_type_mark begin fun mark -> + let super = type_iterators mark in + let it_do_type_expr it ty = match get_desc ty with Tvar _ -> let level = get_level ty in if level < generic_level && level > nglev then set_level ty nglev | _ -> - type_iterators.it_type_expr it ty + super.it_do_type_expr it ty in - let it = {type_iterators with it_type_expr} in - it.it_module_type it mty; - it.it_module_type unmark_iterators mty + let it = {super with it_do_type_expr} in + it.it_module_type it mty + end diff --git a/src/ocaml/typing/oprint.ml b/src/ocaml/typing/oprint.ml index 57897a19f..c1555148c 100644 --- a/src/ocaml/typing/oprint.ml +++ b/src/ocaml/typing/oprint.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -open Format +open Format_doc open Outcometree exception Ellipsis @@ -37,28 +37,9 @@ let rec print_ident ppf = let out_ident = ref print_ident -(* Check a character matches the [identchar_latin1] class from the lexer *) -let is_ident_char c = - match c with - | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' - | '\248'..'\255' | '\'' | '0'..'9' -> true - | _ -> false - -let all_ident_chars s = - let rec loop s len i = - if i < len then begin - if is_ident_char s.[i] then loop s len (i+1) - else false - end else begin - true - end - in - let len = String.length s in - loop s len 0 - let parenthesized_ident name = (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) - || not (all_ident_chars name) + || not (Misc.Utf8_lexeme.is_valid_identifier name) let value_ident ppf name = if parenthesized_ident name then @@ -249,7 +230,7 @@ let print_out_value ppf tree = in cautious print_tree_1 ppf tree -let out_value = ref print_out_value +let out_value = ref (compat print_out_value) (* Types *) @@ -267,7 +248,7 @@ let rec print_list pr sep ppf = let pr_present = print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") -let pr_var = Pprintast.tyvar +let pr_var = Pprintast.Doc.tyvar let ty_var ~non_gen ppf s = pr_var ppf (if non_gen then "_" ^ s else s) @@ -404,10 +385,13 @@ and print_typargs ppf = pp_print_char ppf ')'; pp_close_box ppf (); pp_print_space ppf () -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%a :@ %a@];" (if mut then "mutable " else "") - print_lident name - print_out_type arg +and print_out_label ppf {olab_name; olab_mut; olab_type} = + fprintf ppf "@[<2>%s%a :@ %a@];" + (match olab_mut with + | Mutable -> "mutable " + | Immutable -> "") + print_lident olab_name + print_out_type olab_type let out_label = ref print_out_label @@ -555,7 +539,7 @@ and print_out_functor_parameters ppf l = print_args l | _ :: _ as non_anonymous_functor -> let args, anons = split_anon_functor_arguments non_anonymous_functor in - fprintf ppf "@[<2>functor@ %a@]@ ->@ %a" + fprintf ppf "@[%a@]@ ->@ %a" (pp_print_list ~pp_sep:pp_print_space print_nonanon_arg) args print_args anons in @@ -814,6 +798,8 @@ let _ = out_functor_parameters := print_out_functor_parameters (* Phrases *) +open Format + let print_out_exception ppf exn outv = match exn with Sys.Break -> fprintf ppf "Interrupted.@." @@ -848,23 +834,26 @@ let rec print_items ppf = otyext_constructors = exts; otyext_private = ext.oext_private } in - fprintf ppf "@[%a@]" !out_type_extension te; + fprintf ppf "@[%a@]" (Format_doc.compat !out_type_extension) te; if items <> [] then fprintf ppf "@ %a" print_items items | (tree, valopt) :: items -> begin match valopt with Some v -> - fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree + fprintf ppf "@[<2>%a =@ %a@]" (Format_doc.compat !out_sig_item) tree !out_value v - | None -> fprintf ppf "@[%a@]" !out_sig_item tree + | None -> fprintf ppf "@[%a@]" (Format_doc.compat !out_sig_item) tree end; if items <> [] then fprintf ppf "@ %a" print_items items let print_out_phrase ppf = function Ophr_eval (outv, ty) -> - fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv + fprintf ppf "@[- : %a@ =@ %a@]@." (compat !out_type) ty !out_value outv | Ophr_signature [] -> () | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv let out_phrase = ref print_out_phrase + +type 'a printer = 'a Format_doc.printer ref +type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref diff --git a/src/ocaml/typing/oprint.mli b/src/ocaml/typing/oprint.mli index 31dad9a90..8ce44f37e 100644 --- a/src/ocaml/typing/oprint.mli +++ b/src/ocaml/typing/oprint.mli @@ -13,24 +13,24 @@ (* *) (**************************************************************************) -open Format open Outcometree -val out_ident : (formatter -> out_ident -> unit) ref -val out_value : (formatter -> out_value -> unit) ref -val out_label : (formatter -> string * bool * out_type -> unit) ref -val out_type : (formatter -> out_type -> unit) ref -val out_type_args : (formatter -> out_type list -> unit) ref -val out_constr : (formatter -> out_constructor -> unit) ref -val out_class_type : (formatter -> out_class_type -> unit) ref -val out_module_type : (formatter -> out_module_type -> unit) ref -val out_sig_item : (formatter -> out_sig_item -> unit) ref -val out_signature : (formatter -> out_sig_item list -> unit) ref +type 'a printer = 'a Format_doc.printer ref +type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref + +val out_ident: out_ident printer +val out_value : out_value toplevel_printer +val out_label : out_label printer +val out_type : out_type printer +val out_type_args : out_type list printer +val out_constr : out_constructor printer +val out_class_type : out_class_type printer +val out_module_type : out_module_type printer +val out_sig_item : out_sig_item printer +val out_signature :out_sig_item list printer val out_functor_parameters : - (formatter -> - (string option * Outcometree.out_module_type) option list -> unit) - ref -val out_type_extension : (formatter -> out_type_extension -> unit) ref -val out_phrase : (formatter -> out_phrase -> unit) ref + (string option * Outcometree.out_module_type) option list printer +val out_type_extension : out_type_extension printer +val out_phrase : out_phrase toplevel_printer val parenthesized_ident : string -> bool diff --git a/src/ocaml/typing/outcometree.mli b/src/ocaml/typing/outcometree.mli index ed2b61599..da508b0d2 100644 --- a/src/ocaml/typing/outcometree.mli +++ b/src/ocaml/typing/outcometree.mli @@ -49,7 +49,7 @@ type out_value = | Oval_int64 of int64 | Oval_nativeint of nativeint | Oval_list of out_value list - | Oval_printer of (Format.formatter -> unit) + | Oval_printer of (Format_doc.formatter -> unit) | Oval_record of (out_ident * out_value) list | Oval_string of string * int * out_string (* string, size-to-print, kind *) | Oval_stuff of string @@ -72,7 +72,7 @@ type out_type = | Otyp_constr of out_ident * out_type list | Otyp_manifest of out_type * out_type | Otyp_object of { fields: (string * out_type) list; open_row:bool} - | Otyp_record of (string * bool * out_type) list + | Otyp_record of out_label list | Otyp_stuff of string | Otyp_sum of out_constructor list | Otyp_tuple of out_type list @@ -82,6 +82,12 @@ type out_type = | Otyp_module of out_ident * (string * out_type) list | Otyp_attribute of out_type * out_attribute +and out_label = { + olab_name: string; + olab_mut: Asttypes.mutable_flag; + olab_type: out_type; +} + and out_constructor = { ocstr_name: string; ocstr_args: out_type list; diff --git a/src/ocaml/typing/parmatch.ml b/src/ocaml/typing/parmatch.ml index e10ec777b..44f0dfef2 100644 --- a/src/ocaml/typing/parmatch.ml +++ b/src/ocaml/typing/parmatch.ml @@ -504,26 +504,15 @@ let rec read_args xs r = match xs,r with | _,_ -> fatal_error "Parmatch.read_args" -let do_set_args ~erase_mutable q r = match q with +let set_args q r = match q with | {pat_desc = Tpat_tuple omegas} -> let args,rest = read_args omegas r in make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest | {pat_desc = Tpat_record (omegas,closed)} -> let args,rest = read_args omegas r in - make_pat - (Tpat_record - (List.map2 (fun (lid, lbl,_) arg -> - if - erase_mutable && - (match lbl.lbl_mut with - | Mutable -> true | Immutable -> false) - then - lid, lbl, omega - else - lid, lbl, arg) - omegas args, closed)) - q.pat_type q.pat_env:: - rest + let args = + List.map2 (fun (lid, lbl, _) arg -> (lid, lbl, arg)) omegas args in + make_pat (Tpat_record (args, closed)) q.pat_type q.pat_env :: rest | {pat_desc = Tpat_construct (lid, c, omegas, _)} -> let args,rest = read_args omegas r in make_pat @@ -548,7 +537,6 @@ let do_set_args ~erase_mutable q r = match q with end | {pat_desc = Tpat_array omegas} -> let args,rest = read_args omegas r in - let args = if erase_mutable then omegas else args in make_pat (Tpat_array args) q.pat_type q.pat_env:: rest @@ -557,9 +545,6 @@ let do_set_args ~erase_mutable q r = match q with | {pat_desc = (Tpat_var _ | Tpat_alias _ | Tpat_or _); _} -> fatal_error "Parmatch.set_args" -let set_args q r = do_set_args ~erase_mutable:false q r -and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r - (* Given a matrix of non-empty rows p1 :: r1... p2 :: r2... @@ -1899,22 +1884,20 @@ let do_check_partial ~pred loc casel pss = match pss with | Seq.Cons (v, _rest) -> if Warnings.is_active (Warnings.Partial_match "") then begin let errmsg = - try - let buf = Buffer.create 16 in - let fmt = Format.formatter_of_buffer buf in - Format.fprintf fmt "%a@?" Printpat.pretty_pat v; - if do_match (initial_only_guarded casel) [v] then - Buffer.add_string buf - "\n(However, some guarded clause may match this value.)"; - if contains_extension v then - Buffer.add_string buf - "\nMatching over values of extensible variant types \ - (the *extension* above)\n\ - must include a wild card pattern in order to be exhaustive." - ; - Buffer.contents buf - with _ -> - "" + let doc = ref Format_doc.Doc.empty in + let fmt = Format_doc.formatter doc in + Format_doc.fprintf fmt "@[%a" Printpat.top_pretty v; + if do_match (initial_only_guarded casel) [v] then + Format_doc.fprintf fmt + "@,(However, some guarded clause may match this value.)"; + if contains_extension v then + Format_doc.fprintf fmt + "@,@[Matching over values of extensible variant types \ + (the *extension* above)@,\ + must include a wild card pattern@ in order to be exhaustive.@]" + ; + Format_doc.fprintf fmt "@]"; + Format_doc.(asprintf "%a" pp_doc) !doc in Location.prerr_warning loc (Warnings.Partial_match errmsg) end; diff --git a/src/ocaml/typing/parmatch.mli b/src/ocaml/typing/parmatch.mli index 246ca209e..de7a4ad19 100644 --- a/src/ocaml/typing/parmatch.mli +++ b/src/ocaml/typing/parmatch.mli @@ -75,13 +75,11 @@ val lubs : pattern list -> pattern list -> pattern list val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list -(** Those two functions recombine one pattern and its arguments: +(** This function recombines one pattern and its arguments: For instance: (_,_)::p1::p2::rem -> (p1, p2)::rem - The second one will replace mutable arguments by '_' *) val set_args : pattern -> pattern list -> pattern list -val set_args_erase_mutable : pattern -> pattern list -> pattern list val pat_of_constr : pattern -> constructor_description -> pattern val complete_constrs : diff --git a/src/ocaml/typing/path.ml b/src/ocaml/typing/path.ml index 4b44b0b2f..038ae48f8 100644 --- a/src/ocaml/typing/path.ml +++ b/src/ocaml/typing/path.ml @@ -104,8 +104,8 @@ let rec name ?(paren=kfalse) = function let rec print ppf = function | Pident id -> Ident.print_with_scope ppf id | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> - Format.fprintf ppf "%a.%s" print p s - | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2 + Format_doc.fprintf ppf "%a.%s" print p s + | Papply(p1, p2) -> Format_doc.fprintf ppf "%a(%a)" print p1 print p2 | Pextra_ty (p, Pext_ty) -> print ppf p let rec head = function diff --git a/src/ocaml/typing/path.mli b/src/ocaml/typing/path.mli index 39e76a372..034be0042 100644 --- a/src/ocaml/typing/path.mli +++ b/src/ocaml/typing/path.mli @@ -68,7 +68,7 @@ val name: ?paren:(string -> bool) -> t -> string (* [paren] tells whether a path suffix needs parentheses *) val head: t -> Ident.t -val print: Format.formatter -> t -> unit +val print: t Format_doc.printer val heads: t -> Ident.t list diff --git a/src/ocaml/typing/persistent_env.ml b/src/ocaml/typing/persistent_env.ml index a75b4f3e1..596922c58 100644 --- a/src/ocaml/typing/persistent_env.ml +++ b/src/ocaml/typing/persistent_env.ml @@ -279,26 +279,33 @@ let check_pers_struct ~allow_hidden penv f1 f2 ~loc name = | Not_found -> let warn = Warnings.No_cmi_file(name, None) in Location.prerr_warning loc warn +<<<<<<< | Magic_numbers.Cmi.Error err -> let msg = Format.asprintf "%a" Magic_numbers.Cmi.report_error err in +======= + | Cmi_format.Error err -> + let msg = Format.asprintf "%a" + Cmi_format.report_error err in +>>>>>>> let warn = Warnings.No_cmi_file(name, Some msg) in Location.prerr_warning loc warn | Error err -> let msg = match err with | Illegal_renaming(name, ps_name, filename) -> - Format.asprintf + Format_doc.doc_printf " %a@ contains the compiled interface for @ \ %a when %a was expected" - (Style.as_inline_code Location.print_filename) filename + Location.Doc.quoted_filename filename Style.inline_code ps_name Style.inline_code name | Inconsistent_import _ -> assert false | Need_recursive_types name -> - Format.asprintf + Format_doc.doc_printf "%a uses recursive types" Style.inline_code name in + let msg = Format_doc.(asprintf "%a" pp_doc) msg in let warn = Warnings.No_cmi_file(name, Some msg) in Location.prerr_warning loc warn @@ -386,20 +393,20 @@ let save_cmi penv psig pm = ) ~exceptionally:(fun () -> remove_file filename) -let report_error ppf = - let open Format in +let report_error_doc ppf = + let open Format_doc in function | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf "Wrong file naming: %a@ contains the compiled interface for@ \ %a when %a was expected" - (Style.as_inline_code Location.print_filename) filename + Location.Doc.quoted_filename filename Style.inline_code ps_name Style.inline_code modname | Inconsistent_import(name, source1, source2) -> fprintf ppf "@[The files %a@ and %a@ \ make inconsistent assumptions@ over interface %a@]" - (Style.as_inline_code Location.print_filename) source1 - (Style.as_inline_code Location.print_filename) source2 + Location.Doc.quoted_filename source1 + Location.Doc.quoted_filename source2 Style.inline_code name | Need_recursive_types(import) -> fprintf ppf @@ -423,9 +430,19 @@ let with_cmis penv f x = [R (penv.can_load_cmis, Can_load_cmis)] (fun () -> f x)) +<<<<<<< let forall ~found ~missing t = Std.Hashtbl.forall t.persistent_structures (fun name -> function | Missing -> missing name | Found (pers_struct, a) -> found name pers_struct.ps_filename pers_struct.ps_name a +======= + Location.register_error_of_exn + (function + | Error err -> + Some (Location.error_of_printer_file report_error_doc err) + | _ -> None +>>>>>>> ) + +let report_error = Format_doc.compat report_error_doc diff --git a/src/ocaml/typing/persistent_env.mli b/src/ocaml/typing/persistent_env.mli index 1acb5b3d6..a622cd02e 100644 --- a/src/ocaml/typing/persistent_env.mli +++ b/src/ocaml/typing/persistent_env.mli @@ -27,7 +27,8 @@ type error = exception Error of error -val report_error: Format.formatter -> error -> unit +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer module Persistent_signature : sig type t = diff --git a/src/ocaml/typing/predef.ml b/src/ocaml/typing/predef.ml index 7344be15f..e7b24bd8f 100644 --- a/src/ocaml/typing/predef.ml +++ b/src/ocaml/typing/predef.ml @@ -35,6 +35,8 @@ and ident_float = ident_create "float" and ident_bool = ident_create "bool" and ident_unit = ident_create "unit" and ident_exn = ident_create "exn" +and ident_eff = ident_create "eff" +and ident_continuation = ident_create "continuation" and ident_array = ident_create "array" and ident_list = ident_create "list" and ident_option = ident_create "option" @@ -53,6 +55,8 @@ and path_float = Pident ident_float and path_bool = Pident ident_bool and path_unit = Pident ident_unit and path_exn = Pident ident_exn +and path_eff = Pident ident_eff +and path_continuation = Pident ident_continuation and path_array = Pident ident_array and path_list = Pident ident_list and path_option = Pident ident_option @@ -71,6 +75,9 @@ and type_float = newgenty (Tconstr(path_float, [], ref Mnil)) and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil)) and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil)) and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) +and type_eff t = newgenty (Tconstr(path_eff, [t], ref Mnil)) +and type_continuation t1 t2 = + newgenty (Tconstr(path_continuation, [t1; t2], ref Mnil)) and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) @@ -96,6 +103,8 @@ and ident_sys_blocked_io = ident_create "Sys_blocked_io" and ident_assert_failure = ident_create "Assert_failure" and ident_undefined_recursive_module = ident_create "Undefined_recursive_module" +and ident_continuation_already_taken = ident_create "Continuation_already_taken" + let all_predef_exns = [ ident_match_failure; @@ -110,6 +119,7 @@ let all_predef_exns = [ ident_sys_blocked_io; ident_assert_failure; ident_undefined_recursive_module; + ident_continuation_already_taken; ] let path_match_failure = Pident ident_match_failure @@ -178,6 +188,28 @@ let build_initial_env add_type add_extension empty_env = } in add_type type_ident decl env + and add_continuation type_ident env = + let tvar1 = newgenvar() in + let tvar2 = newgenvar() in + let arity = 2 in + let decl = + {type_params = [tvar1; tvar2]; + type_arity = arity; + type_kind = Type_abstract Definition; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = [Variance.contravariant; Variance.covariant]; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env in let add_extension id l = add_extension id @@ -204,6 +236,11 @@ let build_initial_env add_type add_extension empty_env = ~kind:(variant [cstr ident_false []; cstr ident_true []]) |> add_type ident_char ~immediate:Always |> add_type ident_exn ~kind:Type_open + |> add_type1 ident_eff + ~variance:Variance.full + ~separability:Separability.Ind + ~kind:(fun _ -> Type_open) + |> add_continuation ident_continuation |> add_type ident_extension_constructor |> add_type ident_float |> add_type ident_floatarray @@ -245,6 +282,7 @@ let build_initial_env add_type add_extension empty_env = |> add_extension ident_sys_error [type_string] |> add_extension ident_undefined_recursive_module [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_continuation_already_taken [] let builtin_values = List.map (fun id -> (Ident.name id, id)) all_predef_exns diff --git a/src/ocaml/typing/predef.mli b/src/ocaml/typing/predef.mli index ff67206f6..f2c75be0d 100644 --- a/src/ocaml/typing/predef.mli +++ b/src/ocaml/typing/predef.mli @@ -27,6 +27,8 @@ val type_float: type_expr val type_bool: type_expr val type_unit: type_expr val type_exn: type_expr +val type_eff: type_expr -> type_expr +val type_continuation: type_expr -> type_expr -> type_expr val type_array: type_expr -> type_expr val type_list: type_expr -> type_expr val type_option: type_expr -> type_expr @@ -45,6 +47,7 @@ val path_float: Path.t val path_bool: Path.t val path_unit: Path.t val path_exn: Path.t +val path_eff: Path.t val path_array: Path.t val path_list: Path.t val path_option: Path.t @@ -54,6 +57,7 @@ val path_int64: Path.t val path_lazy_t: Path.t val path_extension_constructor: Path.t val path_floatarray: Path.t +val path_continuation: Path.t val path_match_failure: Path.t val path_assert_failure : Path.t diff --git a/src/ocaml/typing/primitive.ml b/src/ocaml/typing/primitive.ml index f8e964cce..a0cb5d712 100644 --- a/src/ocaml/typing/primitive.ml +++ b/src/ocaml/typing/primitive.ml @@ -232,16 +232,16 @@ module Style = Misc.Style let report_error ppf err = match err with | Old_style_float_with_native_repr_attribute -> - Format.fprintf ppf "Cannot use %a in conjunction with %a/%a." + Format_doc.fprintf ppf "Cannot use %a in conjunction with %a/%a." Style.inline_code "float" Style.inline_code "[@unboxed]" Style.inline_code "[@untagged]" | Old_style_noalloc_with_noalloc_attribute -> - Format.fprintf ppf "Cannot use %a in conjunction with %a." + Format_doc.fprintf ppf "Cannot use %a in conjunction with %a." Style.inline_code "noalloc" Style.inline_code "[@@noalloc]" | No_native_primitive_with_repr_attribute -> - Format.fprintf ppf + Format_doc.fprintf ppf "@[The native code version of the primitive is mandatory@ \ when attributes %a or %a are present.@]" Style.inline_code "[@untagged]" diff --git a/src/ocaml/typing/printpat.ml b/src/ocaml/typing/printpat.ml index bc3578ce4..d4897294d 100644 --- a/src/ocaml/typing/printpat.ml +++ b/src/ocaml/typing/printpat.ml @@ -18,7 +18,7 @@ open Asttypes open Typedtree open Types -open Format +open Format_doc let is_cons = function | {cstr_name = "::"} -> true @@ -99,7 +99,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | Tpat_lazy v -> fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v | Tpat_alias (v, x,_,_) -> - fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x + fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.doc_print x | Tpat_value v -> fprintf ppf "%a" pretty_val (v :> pattern) | Tpat_exception v -> @@ -144,20 +144,30 @@ and pretty_lvals ppf = function fprintf ppf "%s=%a;@ %a" lbl.lbl_name pretty_val v pretty_lvals rest +let top_pretty ppf v = + fprintf ppf "@[%a@]" pretty_val v + let pretty_pat ppf p = - fprintf ppf "@[%a@]" pretty_val p + top_pretty ppf p ; + pp_print_flush ppf () type 'k matrix = 'k general_pattern list list let pretty_line ppf line = - Format.fprintf ppf "@["; + fprintf ppf "@["; List.iter (fun p -> - Format.fprintf ppf "<%a>@ " - pretty_val p - ) line; - Format.fprintf ppf "@]" + fprintf ppf "<%a>@ " + pretty_val p + ) line; + fprintf ppf "@]" let pretty_matrix ppf (pss : 'k matrix) = - Format.fprintf ppf "@[ %a@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_cut pretty_line) + fprintf ppf "@[ %a@]" + (pp_print_list ~pp_sep:pp_print_cut pretty_line) pss + +module Compat = struct + let pretty_pat ppf x = compat pretty_pat ppf x + let pretty_line ppf x = compat pretty_line ppf x + let pretty_matrix ppf x = compat pretty_matrix ppf x +end diff --git a/src/ocaml/typing/printpat.mli b/src/ocaml/typing/printpat.mli index 1f03508c2..2d9a93ce6 100644 --- a/src/ocaml/typing/printpat.mli +++ b/src/ocaml/typing/printpat.mli @@ -17,11 +17,12 @@ val pretty_const : Asttypes.constant -> string -val pretty_val : Format.formatter -> 'k Typedtree.general_pattern -> unit -val pretty_pat - : Format.formatter -> 'k Typedtree.general_pattern -> unit -val pretty_line - : Format.formatter -> 'k Typedtree.general_pattern list -> unit -val pretty_matrix - : Format.formatter -> 'k Typedtree.general_pattern list list -> unit +val top_pretty: 'k Typedtree.general_pattern Format_doc.printer + +module Compat: sig + val pretty_pat: Format.formatter -> 'k Typedtree.general_pattern -> unit + val pretty_line: Format.formatter -> 'k Typedtree.general_pattern list -> unit + val pretty_matrix: + Format.formatter -> 'k Typedtree.general_pattern list list -> unit +end diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index 833db2360..4b5e75451 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -2,14 +2,179 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* Florian Angeletti, projet Cambium, INRIA Paris *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) +<<<<<<< +======= +(* *) +(**************************************************************************) + +open Out_type +module Fmt = Format_doc + +let namespaced_ident namespace id = + Out_name.print (ident_name (Some namespace) id) + +module Doc = struct + let wrap_printing_env = wrap_printing_env + + let longident = Pprintast.Doc.longident + + let ident ppf id = Fmt.pp_print_string ppf + (Out_name.print (ident_name None id)) + + + + let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + + let type_expansion k ppf e = + pp_type_expansion ppf (trees_of_type_expansion k e) + + let type_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) + + let type_expr ppf ty = + (* [type_expr] is used directly by error message printers, + we mark eventual loops ourself to avoid any misuse and stack overflow *) + prepare_for_printing [ty]; + prepared_type_expr ppf ty + + let shared_type_scheme ppf ty = + add_type_to_preparation ty; + typexp Type_scheme ppf ty + + let type_scheme ppf ty = + prepare_for_printing [ty]; + prepared_type_scheme ppf ty + + let path ppf p = + !Oprint.out_ident ppf (tree_of_path ~disambiguation:false p) + + let () = Env.print_path := path + + let type_path ppf p = !Oprint.out_ident ppf (tree_of_type_path p) + + let value_description id ppf decl = + !Oprint.out_sig_item ppf (tree_of_value_description id decl) + + let class_type ppf cty = + reset (); + prepare_class_type cty; + !Oprint.out_class_type ppf (tree_of_class_type Type cty) + + let class_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) + + let cltype_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) + + let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) + let modtype_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) + + let constructor ppf c = + reset_except_conflicts (); + add_constructor_to_preparation c; + prepared_constructor ppf c + + let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) + + let label ppf l = + prepare_for_printing [l.Types.ld_type]; + !Oprint.out_label ppf (tree_of_label l) + + let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) + + (* Print an extension declaration *) + + + + let extension_only_constructor id ppf (ext:Types.extension_constructor) = + reset_except_conflicts (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter add_type_to_preparation ext.ext_ret_type; + let name = Ident.name id in + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type + in + Fmt.fprintf ppf "@[%a@]" + !Oprint.out_constr { + Outcometree.ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + + (* Print a signature body (used by -i when compiling a .ml) *) + + let print_signature ppf tree = + Fmt.fprintf ppf "@[%a@]" !Oprint.out_signature tree + + let signature ppf sg = + Fmt.fprintf ppf "%a" print_signature (tree_of_signature sg) + +end +open Doc +let string_of_path p = Fmt.asprintf "%a" path p + +let strings_of_paths namespace p = + let trees = List.map (namespaced_tree_of_path namespace) p in + List.map (Fmt.asprintf "%a" !Oprint.out_ident) trees + +let wrap_printing_env = wrap_printing_env +let ident = Fmt.compat ident +let longident = Fmt.compat longident +let path = Fmt.compat path +let type_path = Fmt.compat type_path +let type_expr = Fmt.compat type_expr +let type_scheme = Fmt.compat type_scheme +let shared_type_scheme = Fmt.compat shared_type_scheme + +let type_declaration = Fmt.compat1 type_declaration +let type_expansion = Fmt.compat1 type_expansion +let value_description = Fmt.compat1 value_description +let label = Fmt.compat label +let constructor = Fmt.compat constructor +let constructor_arguments = Fmt.compat constructor_arguments +let extension_constructor = Fmt.compat1 extension_constructor +let extension_only_constructor = Fmt.compat1 extension_only_constructor + +let modtype = Fmt.compat modtype +let modtype_declaration = Fmt.compat1 modtype_declaration +let signature = Fmt.compat signature + +let class_declaration = Fmt.compat1 class_declaration +let class_type = Fmt.compat class_type +let cltype_declaration = Fmt.compat1 cltype_declaration + + +(* Print a signature body (used by -i when compiling a .ml) *) +let printed_signature sourcefile ppf sg = + (* we are tracking any collision event for warning 63 *) + Ident_conflicts.reset (); + let t = tree_of_signature sg in + if Warnings.(is_active @@ Erroneous_printed_signature "") then + begin match Ident_conflicts.err_msg () with + | None -> () + | Some msg -> + let conflicts = Fmt.asprintf "%a" Fmt.pp_doc msg in + Location.prerr_warning (Location.in_file sourcefile) + (Warnings.Erroneous_printed_signature conflicts); + Warnings.check_fatal () + end; + Fmt.compat print_signature ppf t +>>>>>>> (* *) (**************************************************************************) diff --git a/src/ocaml/typing/printtyp.mli b/src/ocaml/typing/printtyp.mli index 2769fe032..dcb60c19b 100644 --- a/src/ocaml/typing/printtyp.mli +++ b/src/ocaml/typing/printtyp.mli @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Florian Angeletti, projet Cambium, INRIA Paris *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) @@ -13,37 +13,39 @@ (* *) (**************************************************************************) -(* Printing functions *) +(** Printing functions *) + -open Format open Types -open Outcometree -val longident: formatter -> Longident.t -> unit -val ident: formatter -> Ident.t -> unit -val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string -val tree_of_path: Path.t -> out_ident -val path: formatter -> Path.t -> unit +type namespace := Shape.Sig_component_kind.t + +val namespaced_ident: namespace -> Ident.t -> string val string_of_path: Path.t -> string +val strings_of_paths: namespace -> Path.t list -> string list +(** Print a list of paths, using the same naming context to + avoid name collisions *) -val type_path: formatter -> Path.t -> unit -(** Print a type path taking account of [-short-paths]. - Calls should be within [wrap_printing_env]. *) +(** [printed_signature sourcefile ppf sg] print the signature [sg] of + [sourcefile] with potential warnings for name collisions *) +val printed_signature: string -> Format.formatter -> signature -> unit -module Out_name: sig - val create: string -> out_name - val print: out_name -> string -end +module type Printers := sig -type namespace := Shape.Sig_component_kind.t option + val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a + (** Call the function using the environment for type path shortening This + affects all the printing functions below Also, if [~error:true], then + disable the loading of cmis *) -val strings_of_paths: namespace -> Path.t list -> string list - (** Print a list of paths, using the same naming context to - avoid name collisions *) - -val raw_type_expr: formatter -> type_expr -> unit -val string_of_label: Asttypes.arg_label -> string + type 'a printer + val longident: Longident.t printer + val ident: Ident.t printer + val path: Path.t printer + val type_path: Path.t printer + (** Print a type path taking account of [-short-paths]. + Calls should be within [wrap_printing_env]. *) +<<<<<<< val wrap_printing_env: ?error:bool -> Env.t -> (unit -> 'a) -> 'a (* Call the function using the environment for type path shortening *) (* This affects all the printing functions below *) @@ -248,7 +250,61 @@ val print_items: (Env.t -> signature_item -> 'a option) -> (* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias for Foo__bar. This pattern is used by the stdlib. *) val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t +======= +>>>>>>> -(** [printed_signature sourcefile ppf sg] print the signature [sg] of - [sourcefile] with potential warnings for name collisions *) -val printed_signature: string -> formatter -> signature -> unit + (** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want + multiple types to use common names for type variables, see + {!Out_type.prepare_for_printing} and {!Out_type.prepared_type_expr}. *) + val type_expr: type_expr printer + + val type_scheme: type_expr printer + + val shared_type_scheme: type_expr printer + (** [shared_type_scheme] is very similar to [type_scheme], but does not + reset the printing context first. This is intended to be used in cases + where the printing should have a particularly wide context, such as + documentation generators; most use cases, such as error messages, have + narrower contexts for which [type_scheme] is better suited. *) + + val type_expansion: + Out_type.type_or_scheme -> Errortrace.expanded_type printer + + val label : label_declaration printer + + val constructor : constructor_declaration printer + val constructor_arguments: constructor_arguments printer + + val extension_constructor: + Ident.t -> extension_constructor printer + (** Prints extension constructor with the type signature: + type ('a, 'b) bar += A of float + *) + + val extension_only_constructor: + Ident.t -> extension_constructor printer + (** Prints only extension constructor without type signature: + A of float + *) + + + val value_description: Ident.t -> value_description printer + val type_declaration: Ident.t -> type_declaration printer + val modtype_declaration: Ident.t -> modtype_declaration printer + val class_declaration: Ident.t -> class_declaration printer + val cltype_declaration: Ident.t -> class_type_declaration printer + + + val modtype: module_type printer + val signature: signature printer + val class_type: class_type printer + + end + +module Doc : Printers with type 'a printer := 'a Format_doc.printer + +(** For compatibility with Format printers *) +include Printers with type 'a printer := 'a Format_doc.format_printer diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index 28b973942..b60920e97 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -358,15 +358,16 @@ and expression i ppf x = line i ppf "Texp_apply\n"; expression i ppf e; list i label_x_expression ppf l; - | Texp_match (e, l, partial) -> - line i ppf "Texp_match%a\n" - fmt_partiality partial; + | Texp_match (e, l1, l2, partial) -> + line i ppf "Texp_match%a\n" fmt_partiality partial; expression i ppf e; - list i case ppf l; - | Texp_try (e, l) -> + list i case ppf l1; + list i case ppf l2; + | Texp_try (e, l1, l2) -> line i ppf "Texp_try\n"; expression i ppf e; - list i case ppf l; + list i case ppf l1; + list i case ppf l2; | Texp_tuple (l) -> line i ppf "Texp_tuple\n"; list i expression ppf l; diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml index 1d588c647..41c2b65a4 100644 --- a/src/ocaml/typing/shape.ml +++ b/src/ocaml/typing/shape.ml @@ -16,7 +16,7 @@ module Uid = struct type t = | Compilation_unit of string - | Item of { comp_unit: string; id: int } + | Item of { comp_unit: string; id: int; from: Unit_info.intf_or_impl } | Internal | Predef of string @@ -27,11 +27,16 @@ module Uid = struct let compare (x : t) y = compare x y let hash (x : t) = Hashtbl.hash x + let pp_intf_or_impl fmt = function + | Unit_info.Intf -> Format.pp_print_string fmt "[intf]" + | Unit_info.Impl -> () + let print fmt = function | Internal -> Format.pp_print_string fmt "" | Predef name -> Format.fprintf fmt "" name | Compilation_unit s -> Format.pp_print_string fmt s - | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id + | Item { comp_unit; id; from } -> + Format.fprintf fmt "%a%s.%d" pp_intf_or_impl from comp_unit id let output oc t = let fmt = Format.formatter_of_out_channel oc in @@ -50,8 +55,14 @@ module Uid = struct | _ -> None let mk ~current_unit = + let comp_unit, from = + let open Unit_info in + match current_unit with + | None -> "", Impl + | Some ui -> modname ui, kind ui + in incr id; - Item { comp_unit = current_unit; id = !id } + Item { comp_unit; id = !id; from } let of_compilation_unit_id id = if not (Ident.persistent id) then diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli index 115cce459..83300d8ef 100644 --- a/src/ocaml/typing/shape.mli +++ b/src/ocaml/typing/shape.mli @@ -43,9 +43,9 @@ [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit. See: - - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling } + - {{:https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling} the design document} - - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf } + - {{:https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf} a talk about the reduction strategy *) @@ -57,7 +57,7 @@ module Uid : sig type t = private | Compilation_unit of string - | Item of { comp_unit: string; id: int } + | Item of { comp_unit: string; id: int; from: Unit_info.intf_or_impl } | Internal | Predef of string @@ -66,7 +66,7 @@ module Uid : sig val restore_stamp : int -> unit val stamp_of_uid : t -> int option - val mk : current_unit:string -> t + val mk : current_unit:(Unit_info.t option) -> t val of_compilation_unit_id : Ident.t -> t val of_predef_id : Ident.t -> t val internal_not_actually_unique : t diff --git a/src/ocaml/typing/stypes.ml b/src/ocaml/typing/stypes.ml index 9d4a2ff70..79bd94512 100644 --- a/src/ocaml/typing/stypes.ml +++ b/src/ocaml/typing/stypes.ml @@ -103,7 +103,7 @@ let sort_filter_phrases () = let rec printtyp_reset_maybe loc = match !phrases with | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> - Printtyp.reset (); + Out_type.reset (); phrases := t; printtyp_reset_maybe loc; | _ -> () @@ -148,8 +148,14 @@ let print_info pp prev_loc ti = printtyp_reset_maybe loc; Format.pp_print_string Format.str_formatter " "; Printtyp.wrap_printing_env ~error:false env +<<<<<<< (fun () -> Printtyp.shared_type_scheme Format.str_formatter typ); (* (fun () -> Printtyp.shared_type_scheme Format.str_formatter typ); *) +======= + (fun () -> + Printtyp.shared_type_scheme Format.str_formatter typ + ); +>>>>>>> Format.pp_print_newline Format.str_formatter (); let s = Format.flush_str_formatter () in output_string pp s; diff --git a/src/ocaml/typing/tast_iterator.ml b/src/ocaml/typing/tast_iterator.ml index 408454ad3..a77402de0 100644 --- a/src/ocaml/typing/tast_iterator.ml +++ b/src/ocaml/typing/tast_iterator.ml @@ -317,12 +317,14 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Texp_apply (exp, list) -> sub.expr sub exp; List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list - | Texp_match (exp, cases, _) -> + | Texp_match (exp, cases, effs, _) -> sub.expr sub exp; - List.iter (sub.case sub) cases - | Texp_try (exp, cases) -> + List.iter (sub.case sub) cases; + List.iter (sub.case sub) effs + | Texp_try (exp, cases, effs) -> sub.expr sub exp; - List.iter (sub.case sub) cases + List.iter (sub.case sub) cases; + List.iter (sub.case sub) effs | Texp_tuple list -> List.iter (sub.expr sub) list | Texp_construct (lid, _, args) -> iter_loc sub lid; diff --git a/src/ocaml/typing/tast_mapper.ml b/src/ocaml/typing/tast_mapper.ml index bcb046174..ea8af17a5 100644 --- a/src/ocaml/typing/tast_mapper.ml +++ b/src/ocaml/typing/tast_mapper.ml @@ -362,16 +362,18 @@ let expr sub x = sub.expr sub exp, List.map (tuple2 id (Option.map (sub.expr sub))) list ) - | Texp_match (exp, cases, p) -> + | Texp_match (exp, cases, eff_cases, p) -> Texp_match ( sub.expr sub exp, List.map (sub.case sub) cases, + List.map (sub.case sub) eff_cases, p ) - | Texp_try (exp, cases) -> + | Texp_try (exp, exn_cases, eff_cases) -> Texp_try ( sub.expr sub exp, - List.map (sub.case sub) cases + List.map (sub.case sub) exn_cases, + List.map (sub.case sub) eff_cases ) | Texp_tuple list -> Texp_tuple (List.map (sub.expr sub) list) @@ -846,11 +848,12 @@ let value_bindings sub (rec_flag, list) = let case : type k . mapper -> k case -> k case - = fun sub {c_lhs; c_guard; c_rhs} -> + = fun sub {c_lhs; c_guard; c_rhs; c_cont} -> { c_lhs = sub.pat sub c_lhs; c_guard = Option.map (sub.expr sub) c_guard; c_rhs = sub.expr sub c_rhs; + c_cont } let value_binding sub x = diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml index 0c14185f4..c8ac1ec75 100644 --- a/src/ocaml/typing/typeclass.ml +++ b/src/ocaml/typing/typeclass.ml @@ -19,7 +19,6 @@ open Path open Types open Typecore open Typetexp -open Format type 'a class_info = { @@ -48,7 +47,7 @@ type class_type_info = { type 'a full_class = { id : Ident.t; - id_loc : tag loc; + id_loc : string loc; clty: class_declaration; ty_id: Ident.t; cltydef: class_type_declaration; @@ -94,7 +93,7 @@ type error = | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list | Class_match_failure of Ctype.class_match_failure list | Unbound_val of string - | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure + | Unbound_type_var of Format_doc.t * Ctype.closed_class_failure | Non_generalizable_class of { id : Ident.t ; clty : Types.class_declaration @@ -465,7 +464,7 @@ let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = { val_type = ty; val_kind = kind; val_attributes = attrs; Types.val_loc = loc; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } in Env.enter_value ~check name desc met_env @@ -480,7 +479,7 @@ let add_self_met loc id sign self_var_kind vars cl_num { val_type = ty; val_kind = kind; val_attributes = attrs; Types.val_loc = loc; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } in Env.add_value ~check id desc met_env @@ -495,7 +494,7 @@ let add_instance_var_met loc label id sign cl_num attrs met_env = { val_type = ty; val_kind = kind; val_attributes = attrs; Types.val_loc = loc; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } in Env.add_value id desc met_env @@ -654,10 +653,9 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = with_attrs (fun () -> let cty = - Ctype.with_local_level_if_principal + Ctype.with_local_level_generalize_structure_if_principal (fun () -> Typetexp.transl_simple_type val_env ~closed:false styp) - ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) in add_instance_variable ~strict:true loc val_env label.txt mut Virtual cty.ctyp_type sign; @@ -694,8 +692,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = No_overriding ("instance variable", label.txt))) end; let definition = - Ctype.with_local_level_if_principal - ~post:Typecore.generalize_structure_exp + Ctype.with_local_level_generalize_structure_if_principal (fun () -> type_exp val_env sdefinition) in add_instance_variable ~strict:true loc val_env @@ -1028,7 +1025,7 @@ and class_structure cl_num virt self_scope final val_env met_env loc raise(Error(loc, val_env, Closing_self_type sign)); end; (* Typing of method bodies *) - Ctype.generalize_class_signature_spine val_env sign; + Ctype.generalize_class_signature_spine sign; let self_var_kind = match virt with | Virtual -> Self_virtual(ref meths) @@ -1036,9 +1033,9 @@ and class_structure cl_num virt self_scope final val_env met_env loc in let met_env = List.fold_right - (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> + (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes} met_env -> add_self_met pv_loc pv_id sign self_var_kind vars - cl_num pv_as_var pv_type pv_attributes met_env) + cl_num (pv_kind=As_var) pv_type pv_attributes met_env) self_pat_vars met_env in let fields = @@ -1151,13 +1148,9 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = class_expr cl_num val_env met_env virt self_scope sfun | Pcl_fun (l, None, spat, scl') -> let (pat, pv, val_env', met_env) = - Ctype.with_local_level_if_principal + Ctype.with_local_level_generalize_structure_if_principal (fun () -> Typecore.type_class_arg_pattern cl_num val_env met_env l spat) - ~post: begin fun (pat, _, _, _) -> - let gen {pat_type = ty} = Ctype.generalize_structure ty in - iter_pattern gen pat - end in let pv = List.map @@ -1183,7 +1176,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let partial = let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in Typecore.check_partial val_env pat.pat_type pat.pat_loc - [{c_lhs = pat; c_guard = None; c_rhs = dummy}] + [{c_lhs = pat; c_cont = None; c_guard = None; c_rhs = dummy}] in let cl = Ctype.with_raised_nongen_level @@ -1201,9 +1194,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = | Pcl_apply (scl', sargs) -> assert (sargs <> []); let cl = - Ctype.with_local_level_if_principal + Ctype.with_local_level_generalize_structure_if_principal (fun () -> class_expr cl_num val_env met_env virt self_scope scl') - ~post:(fun cl -> Ctype.generalize_class_type_structure cl.cl_type) in let rec nonopt_labels ls ty_fun = match ty_fun with @@ -1222,7 +1214,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = Location.prerr_warning cl.cl_loc (Warnings.Labels_omitted - (List.map Printtyp.string_of_label + (List.map Asttypes.string_of_label (List.filter ((<>) Nolabel) labels))); true end @@ -1270,7 +1262,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = if not optional && Btype.is_optional l' then Location.prerr_warning sarg.pexp_loc (Warnings.Nonoptional_label - (Printtyp.string_of_label l)); + (Asttypes.string_of_label l)); remaining_sargs, use_arg sarg l' | None -> sargs, @@ -1314,7 +1306,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = (* do not mark the value as used *) let vd = Env.find_value path val_env in let ty = - Ctype.with_local_level ~post:Ctype.generalize + Ctype.with_local_level_generalize (fun () -> Ctype.instance vd.val_type) in let expr = @@ -1372,8 +1364,10 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = cl, clty end ~post: begin fun ({cl_type=cl}, {cltyp_type=clty}) -> - Ctype.limited_generalize_class_type (Btype.self_type_row cl) cl; - Ctype.limited_generalize_class_type (Btype.self_type_row clty) clty; + Ctype.limited_generalize_class_type + (Btype.self_type_row cl) ~inside:cl; + Ctype.limited_generalize_class_type + (Btype.self_type_row clty) ~inside:clty; end in begin match @@ -1474,8 +1468,8 @@ let initial_env define_class approx (* Temporary type for the class constructor *) let constr_type = - Ctype.with_local_level_if_principal (fun () -> approx cl.pci_expr) - ~post:Ctype.generalize_structure + Ctype.with_local_level_generalize_structure_if_principal + (fun () -> approx cl.pci_expr) in let dummy_cty = Cty_signature (Ctype.new_class_signature ()) in let dummy_class = @@ -1560,8 +1554,10 @@ let class_infos define_class kind end ~post: begin fun (_, params, _, _, typ, sign) -> (* Generalize the row variable *) - List.iter (Ctype.limited_generalize sign.csig_self_row) params; - Ctype.limited_generalize_class_type sign.csig_self_row typ; + List.iter + (fun inside -> Ctype.limited_generalize sign.csig_self_row ~inside) + params; + Ctype.limited_generalize_class_type sign.csig_self_row ~inside:typ; end in (* Check the abbreviation for the object type *) @@ -1710,31 +1706,20 @@ let class_infos define_class kind arity, pub_meths, List.rev !coercion_locs, expr) :: res, env) -let final_decl env define_class - (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, - arity, pub_meths, coe, expr) = - let cl_abbr = cltydef.clty_hash_type in - - begin try Ctype.collapse_conj_params env clty.cty_params +let collapse_conj_class_params env (cl, id, clty, _, _, _, _, _, _, _, _, _) = + try Ctype.collapse_conj_params env clty.cty_params with Ctype.Unify err -> raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err))) - end; - - List.iter Ctype.generalize clty.cty_params; - Ctype.generalize_class_type clty.cty_type; - Option.iter Ctype.generalize clty.cty_new; - List.iter Ctype.generalize obj_abbr.type_params; - Option.iter Ctype.generalize obj_abbr.type_manifest; - List.iter Ctype.generalize cl_abbr.type_params; - Option.iter Ctype.generalize cl_abbr.type_manifest; +let final_decl env define_class + (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, + arity, pub_meths, coe, expr) = Ctype.nongen_vars_in_class_declaration clty |> Option.iter (fun vars -> let nongen_vars = Btype.TypeSet.elements vars in raise(Error(cl.pci_loc, env , Non_generalizable_class { id; clty; nongen_vars })); ); - begin match Ctype.closed_class clty.cty_params (Btype.signature_of_class_type clty.cty_type) @@ -1743,8 +1728,11 @@ let final_decl env define_class | Some reason -> let printer = if define_class - then function ppf -> Printtyp.class_declaration id ppf clty - else function ppf -> Printtyp.cltype_declaration id ppf cltydef + then + Format_doc.doc_printf "%a" (Printtyp.Doc.class_declaration id) clty + else + Format_doc.doc_printf "%a" + (Printtyp.Doc.cltype_declaration id) cltydef in raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) end; @@ -1848,18 +1836,24 @@ let type_classes define_class approx kind env cls = Ident.create_scoped ~scope cl.pci_name.txt, Ident.create_scoped ~scope cl.pci_name.txt, Ident.create_scoped ~scope cl.pci_name.txt, - Uid.mk ~current_unit:(Env.get_unit_name ()) + Uid.mk ~current_unit:(Env.get_current_unit ()) )) cls in +<<<<<<< let res, newenv = Ctype.with_local_level_for_class begin fun () -> +======= + let res, env = + Ctype.with_local_level_generalize_for_class begin fun () -> +>>>>>>> let (res, env) = List.fold_left (initial_env define_class approx) ([], env) cls in let (res, env) = List.fold_right (class_infos define_class kind) res ([], env) in + List.iter (collapse_conj_class_params env) res; res, env end in @@ -1980,7 +1974,7 @@ let approx_class_declarations env sdecls = (* Error report *) -open Format +open Format_doc let non_virtual_string_of_kind : kind -> string = function | Object -> "object" @@ -1988,32 +1982,36 @@ let non_virtual_string_of_kind : kind -> string = function | Class_type -> "non-virtual class type" module Style=Misc.Style +module Printtyp = Printtyp.Doc + +let out_type ppf t = Style.as_inline_code !Oprint.out_type ppf t +let quoted_type ppf t = Style.as_inline_code Printtyp.type_expr ppf t -let report_error env ppf = +let report_error_doc env ppf = let pp_args ppf args = - let args = List.map (Printtyp.tree_of_typexp Type) args in + let args = List.map (Out_type.tree_of_typexp Type) args in Style.as_inline_code !Oprint.out_type_args ppf args in function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" | Unconsistent_constraint err -> + let msg = Format_doc.Doc.msg in fprintf ppf "@[The class constraints are not consistent.@ "; - Printtyp.report_unification_error ppf env err - (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type"); + Errortrace_report.unification ppf env err + (msg "Type") + (msg "is not compatible with type"); fprintf ppf "@]" | Field_type_mismatch (k, m, err) -> - Printtyp.report_unification_error ppf env err - (function ppf -> - fprintf ppf "The %s %a@ has type" k Style.inline_code m) - (function ppf -> - fprintf ppf "but is expected to have type") + let msg = Format_doc.doc_printf in + Errortrace_report.unification ppf env err + (msg "The %s %a@ has type" k Style.inline_code m) + (msg "but is expected to have type") | Unexpected_field (ty, lab) -> fprintf ppf "@[@[<2>This object is expected to have type :@ %a@]\ @ This type does not have a method %a." - (Style.as_inline_code Printtyp.type_expr) ty + quoted_type ty Style.inline_code lab | Structure_expected clty -> fprintf ppf @@ -2034,7 +2032,7 @@ let report_error env ppf = (* XXX Revoir message d'erreur | Improve error message *) fprintf ppf "@[%s@ %a@]" "This pattern cannot match self: it only matches values of type" - (Style.as_inline_code Printtyp.type_expr) ty + quoted_type ty | Unbound_class_2 cl -> fprintf ppf "@[The class@ %a@ is not yet completely defined@]" (Style.as_inline_code Printtyp.longident) cl @@ -2043,23 +2041,19 @@ let report_error env ppf = (Style.as_inline_code Printtyp.longident) cl | Abbrev_type_clash (abbrev, actual, expected) -> (* XXX Afficher une trace ? | Print a trace? *) - Printtyp.prepare_for_printing [abbrev; actual; expected]; + Out_type.prepare_for_printing [abbrev; actual; expected]; fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ but is used with type@ %a@]" - (Style.as_inline_code !Oprint.out_type) - (Printtyp.tree_of_typexp Type abbrev) - (Style.as_inline_code !Oprint.out_type) - (Printtyp.tree_of_typexp Type actual) - (Style.as_inline_code !Oprint.out_type) - (Printtyp.tree_of_typexp Type expected) + out_type (Out_type.tree_of_typexp Type abbrev) + out_type (Out_type.tree_of_typexp Type actual) + out_type (Out_type.tree_of_typexp Type expected) | Constructor_type_mismatch (c, err) -> - Printtyp.report_unification_error ppf env err - (function ppf -> - fprintf ppf "The expression %a has type" + let msg = Format_doc.doc_printf in + Errortrace_report.unification ppf env err + (msg "The expression %a has type" Style.inline_code ("new " ^ c) ) - (function ppf -> - fprintf ppf "but is used with type") + (msg "but is used with type") | Virtual_class (kind, mets, vals) -> let kind = non_virtual_string_of_kind kind in let missings = @@ -2085,13 +2079,12 @@ let report_error env ppf = but is here applied to %i type argument(s)@]" (Style.as_inline_code Printtyp.longident) lid expected provided | Parameter_mismatch err -> - Printtyp.report_unification_error ppf env err - (function ppf -> - fprintf ppf "The type parameter") - (function ppf -> - fprintf ppf "does not meet its constraint: it should be") + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf env err + (msg "The type parameter") + (msg "does not meet its constraint: it should be") | Bad_parameters (id, params, cstrs) -> - Printtyp.prepare_for_printing (params @ cstrs); + Out_type.prepare_for_printing (params @ cstrs); fprintf ppf "@[The abbreviation %a@ is used with parameter(s)@ %a@ \ which are incompatible with constraint(s)@ %a@]" @@ -2100,7 +2093,7 @@ let report_error env ppf = pp_args cstrs | Bad_class_type_parameters (id, params, cstrs) -> let pp_hash ppf id = fprintf ppf "#%a" Printtyp.ident id in - Printtyp.prepare_for_printing (params @ cstrs); + Out_type.prepare_for_printing (params @ cstrs); fprintf ppf "@[The class type %a@ is used with parameter(s)@ %a,@ \ whereas the class type definition@ constrains@ \ @@ -2109,10 +2102,10 @@ let report_error env ppf = pp_args params pp_args cstrs | Class_match_failure error -> - Includeclass.report_error Type ppf error + Includeclass.report_error_doc Type ppf error | Unbound_val lab -> fprintf ppf "Unbound instance variable %a" Style.inline_code lab - | Unbound_type_var (printer, reason) -> + | Unbound_type_var (msg, reason) -> let print_reason ppf { Ctype.free_variable; meth; meth_ty; } = let (ty0, kind) = free_variable in let ty1 = @@ -2120,28 +2113,27 @@ let report_error env ppf = | Type_variable -> ty0 | Row_variable -> Btype.newgenty(Tobject(ty0, ref None)) in - Printtyp.add_type_to_preparation meth_ty; - Printtyp.add_type_to_preparation ty1; - let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in + Out_type.add_type_to_preparation meth_ty; + Out_type.add_type_to_preparation ty1; fprintf ppf "The method %a@ has type@;<1 2>%a@ where@ %a@ is unbound" Style.inline_code meth - pp_type (Printtyp.tree_of_typexp Type meth_ty) - pp_type (Printtyp.tree_of_typexp Type ty0) + out_type (Out_type.tree_of_typexp Type meth_ty) + out_type (Out_type.tree_of_typexp Type ty0) in fprintf ppf - "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ + "@[@[Some type variables are unbound in this type:@;<1 2>%a@]@ \ @[%a@]@]" - printer print_reason reason + pp_doc msg print_reason reason | Non_generalizable_class {id; clty; nongen_vars } -> let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in - Printtyp.prepare_for_printing nongen_vars; + Out_type.prepare_for_printing nongen_vars; fprintf ppf "@[The type of this class,@ %a,@ \ contains the non-generalizable type variable(s): %a.@ %a@]" (Style.as_inline_code @@ Printtyp.class_declaration id) clty (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") - (Style.as_inline_code Printtyp.prepared_type_scheme) + (Style.as_inline_code Out_type.prepared_type_scheme) ) nongen_vars Misc.print_see_manual manual_ref @@ -2152,20 +2144,20 @@ let report_error env ppf = Some occurrences are contravariant@]" (Style.as_inline_code Printtyp.type_scheme) ty | Non_collapsable_conjunction (id, clty, err) -> + let msg = Format_doc.Doc.msg in fprintf ppf "@[The type of this class,@ %a,@ \ contains non-collapsible conjunctive types in constraints.@ %t@]" (Style.as_inline_code @@ Printtyp.class_declaration id) clty - (fun ppf -> Printtyp.report_unification_error ppf env err - (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type") + (fun ppf -> Errortrace_report.unification ppf env err + (msg "Type") + (msg "is not compatible with type") ) | Self_clash err -> - Printtyp.report_unification_error ppf env err - (function ppf -> - fprintf ppf "This object is expected to have type") - (function ppf -> - fprintf ppf "but actually has type") + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf env err + (msg "This object is expected to have type") + (msg "but actually has type") | Mutability_mismatch (_lab, mut) -> let mut1, mut2 = if mut = Immutable then "mutable", "immutable" @@ -2192,17 +2184,19 @@ let report_error env ppf = completely defined.@]" (Style.as_inline_code Printtyp.type_scheme) sign.csig_self -let report_error env ppf err = +let report_error_doc env ppf err = Printtyp.wrap_printing_env ~error:true - env (fun () -> report_error env ppf err) + env (fun () -> report_error_doc env ppf err) let () = Location.register_error_of_exn (function | Error (loc, env, err) -> - Some (Location.error_of_printer ~loc (report_error env) err) + Some (Location.error_of_printer ~loc (report_error_doc env) err) | Error_forward err -> Some err | _ -> None ) + +let report_error = Format_doc.compat1 report_error_doc diff --git a/src/ocaml/typing/typeclass.mli b/src/ocaml/typing/typeclass.mli index cdecc8dfb..89e230d14 100644 --- a/src/ocaml/typing/typeclass.mli +++ b/src/ocaml/typing/typeclass.mli @@ -15,8 +15,6 @@ open Asttypes open Types -open Format - type 'a class_info = { cls_id : Ident.t; cls_id_loc : string loc; @@ -111,7 +109,7 @@ type error = | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list | Class_match_failure of Ctype.class_match_failure list | Unbound_val of string - | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure + | Unbound_type_var of Format_doc.t * Ctype.closed_class_failure | Non_generalizable_class of { id : Ident.t ; clty : Types.class_declaration @@ -129,7 +127,8 @@ type error = exception Error of Location.t * Env.t * error exception Error_forward of Location.error -val report_error : Env.t -> formatter -> error -> unit +val report_error : Env.t -> Format.formatter -> error -> unit +val report_error_doc : Env.t -> error Format_doc.printer (* Forward decl filled in by Typemod.type_open_descr *) val type_open_descr : diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index 605b6823b..a442ba616 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -98,6 +98,11 @@ type existential_restriction = | In_class_def (** or in [class c = let ... in ...] *) | In_self_pattern (** or in self pattern *) +type existential_binding = + | Bind_already_bound + | Bind_not_in_scope + | Bind_non_locally_abstract + type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * Errortrace.unification_error @@ -108,7 +113,7 @@ type error = | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of Errortrace.unification_error * type_forcing_context option - * Parsetree.expression_desc option + * Parsetree.expression option | Function_arity_type_clash of { syntactic_arity : int; type_constraint : type_expr; @@ -177,6 +182,8 @@ type error = | No_value_clauses | Exception_pattern_disallowed | Mixed_value_and_exception_patterns_under_guard + | Effect_pattern_below_toplevel + | Invalid_continuation_pattern | Inlined_record_escape | Inlined_record_expected | Unrefuted_pattern of pattern @@ -191,10 +198,15 @@ type error = | Andop_type_clash of string * Errortrace.unification_error | Bindings_type_clash of Errortrace.unification_error | Unbound_existential of Ident.t list * type_expr + | Bind_existential of existential_binding * Ident.t * type_expr | Missing_type_constraint | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr | Expr_not_a_record_type of type_expr + +let not_principal fmt = + Format_doc.Doc.kmsg (fun x -> Warnings.Not_principal x) fmt + exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -357,7 +369,7 @@ type recarg = let mk_expected ?explanation ty = { ty; explanation; } let case lhs rhs = - {c_lhs = lhs; c_guard = None; c_rhs = rhs} + {c_lhs = lhs; c_cont = None; c_guard = None; c_rhs = rhs} (* Typing of constants *) @@ -370,7 +382,8 @@ let type_constant = function | Const_int64 _ -> instance Predef.type_int64 | Const_nativeint _ -> instance Predef.type_nativeint -let constant : Parsetree.constant -> (Asttypes.constant, error) result = +let constant_desc + : Parsetree.constant_desc -> (Asttypes.constant, error) result = function | Pconst_integer (i,None) -> begin @@ -398,6 +411,8 @@ let constant : Parsetree.constant -> (Asttypes.constant, error) result = | Pconst_float (f,None)-> Ok (Const_float f) | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c)) +let constant const = constant_desc const.pconst_desc + let constant_or_raise env loc cst = match constant cst with | Ok c -> c @@ -469,6 +484,23 @@ let is_principal ty = (* Typing of patterns *) +(* Simplified patterns for effect continuations *) +let type_continuation_pat env expected_ty sp = + let loc = sp.ppat_loc in + match sp.ppat_desc with + | Ppat_any -> None + | Ppat_var name -> + let id = Ident.create_local name.txt in + let desc = + { val_type = expected_ty; val_kind = Val_reg; + Types.val_loc = loc; val_attributes = []; + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } + in + Some (id, desc) + | Ppat_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | _ -> raise (Error (loc, env, Invalid_continuation_pattern)) + (* unification inside type_exp and type_expect *) let unify_exp_types loc env ty expected_ty = (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type @@ -564,12 +596,17 @@ let finalize_variants p = (* [type_pat_state] and related types for pattern environment; these should not be confused with Pattern_env.t, which is a part of the interface to unification functions in [Ctype] *) +type pattern_variable_kind = + | Std_var + | As_var + | Continuation_var + type pattern_variable = { pv_id: Ident.t; pv_type: type_expr; pv_loc: Location.t; - pv_as_var: bool; + pv_kind: pattern_variable_kind; pv_attributes: attributes; pv_uid : Uid.t; } @@ -619,7 +656,17 @@ type type_pat_state = *) } -let create_type_pat_state allow_modules = +let continuation_variable = function + | None -> [] + | Some (id, (desc:Types.value_description)) -> + [{pv_id = id; + pv_type = desc.val_type; + pv_loc = desc.val_loc; + pv_kind = Continuation_var; + pv_attributes = desc.val_attributes; + pv_uid= desc.val_uid}] + +let create_type_pat_state ?cont allow_modules = let tps_module_variables = match allow_modules with | Modules_allowed { scope } -> @@ -627,7 +674,7 @@ let create_type_pat_state allow_modules = | Modules_ignored -> Modvars_ignored | Modules_rejected -> Modvars_rejected in - { tps_pattern_variables = []; + { tps_pattern_variables = continuation_variable cont; tps_module_variables; tps_pattern_force = []; } @@ -682,7 +729,7 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name ty { mv_id = id; mv_name = name; mv_loc = loc; - mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + mv_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } :: module_variables in tps.tps_module_variables <- @@ -691,12 +738,12 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name ty end else Ident.create_local name.txt in - let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let pv_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in tps.tps_pattern_variables <- {pv_id = id; pv_type = ty; pv_loc = loc; - pv_as_var = is_as_variable; + pv_kind = if is_as_variable then As_var else Std_var; pv_attributes = attrs; pv_uid} :: tps.tps_pattern_variables; id, pv_uid @@ -761,7 +808,7 @@ and build_as_type_extra env p = function If we used [generic_instance] we would lose the sharing between [instance ty] and [ty]. *) let ty = - with_local_level ~post:generalize_structure (fun () -> instance ty) + with_local_level_generalize_structure (fun () -> instance ty) in (* This call to unify may only fail due to missing GADT equations *) unify_pat_types p.pat_loc env (instance as_ty) (instance ty); @@ -841,7 +888,7 @@ let solve_Ppat_poly_constraint tps env loc sty expected_ty = | _ -> assert false let solve_Ppat_alias env pat = - with_local_level ~post:generalize (fun () -> build_as_type env pat) + with_local_level_generalize (fun () -> build_as_type env pat) let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty = let vars = List.map (fun _ -> newgenvar ()) args in @@ -851,23 +898,31 @@ let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty = vars let solve_constructor_annotation - tps (penv : Pattern_env.t) name_list sty ty_args ty_ex = + tps (penv : Pattern_env.t) name_list sty ty_args ty_ex unify_res = let expansion_scope = penv.equations_scope in - let ids = + (* Introduce fresh type names that expand to type variables. + They should eventually be bound to ground types. *) + let ids_decls = List.map (fun name -> - let decl = new_local_type ~loc:name.loc Definition in + let tv = newvar () in + let decl = + new_local_type ~loc:name.loc Definition + ~manifest_and_scope:(tv, Ident.lowest_scope) in let (id, new_env) = Env.enter_type ~scope:expansion_scope name.txt decl !!penv in Pattern_env.set_env penv new_env; - {name with txt = id}) + ({name with txt = id}, (decl, tv))) name_list in + (* Translate the type annotation using these type names. *) let cty, ty, force = - with_local_level ~post:(fun (_,ty,_) -> generalize_structure ty) + with_local_level_generalize_structure (fun () -> Typetexp.transl_simple_type_delayed !!penv sty) in tps.tps_pattern_force <- force :: tps.tps_pattern_force; + (* Only unify the return type after generating the ids *) + unify_res (); let ty_args = let ty1 = instance ty and ty2 = instance ty in match ty_args with @@ -881,24 +936,62 @@ let solve_constructor_annotation Ttuple tyl -> tyl | _ -> assert false in - if ids <> [] then ignore begin - let ids = List.map (fun x -> x.txt) ids in + if ids_decls <> [] then begin + let ids_decls = List.map (fun (x,dm) -> (x.txt,dm)) ids_decls in + let ids = List.map fst ids_decls in let rem = + (* First process the existentials introduced by this constructor. + Just need to make their definitions abstract. *) List.fold_left (fun rem tv -> match get_desc tv with - Tconstr(Path.Pident id, [], _) when List.mem id rem -> - list_remove id rem + Tconstr(Path.Pident id, [], _) when List.mem_assoc id rem -> + let decl, tv' = List.assoc id ids_decls in + let env = + Env.add_type ~check:false id + {decl with type_manifest = None} !!penv + in + Pattern_env.set_env penv env; + (* We have changed the definition, so clean up *) + Btype.cleanup_abbrev (); + (* Since id is now abstract, this does not create a cycle *) + unify_pat_types cty.ctyp_loc env tv tv'; + List.remove_assoc id rem | _ -> raise (Error (cty.ctyp_loc, !!penv, Unbound_existential (ids, ty)))) - ids ty_ex + ids_decls ty_ex in - if rem <> [] then - raise (Error (cty.ctyp_loc, !!penv, - Unbound_existential (ids, ty))) + (* The other type names should be bound to newly introduced existentials. *) + let bound_ids = ref ids in + List.iter + (fun (id, (decl, tv')) -> + let tv' = expand_head !!penv tv' in + begin match get_desc tv' with + | Tconstr (Path.Pident id', [], _) -> + if List.exists (Ident.same id') !bound_ids then + raise (Error (cty.ctyp_loc, !!penv, + Bind_existential (Bind_already_bound, id, tv'))); + (* Both id and id' are Scoped identifiers, so their stamps grow *) + if Ident.scope id' <> penv.equations_scope + || Ident.compare_stamp id id' > 0 then + raise (Error (cty.ctyp_loc, !!penv, + Bind_existential (Bind_not_in_scope, id, tv'))); + bound_ids := id' :: !bound_ids + | _ -> + raise (Error (cty.ctyp_loc, !!penv, + Bind_existential + (Bind_non_locally_abstract, id, tv'))); + end; + let env = + Env.add_type ~check:false id + {decl with type_manifest = Some (duplicate_type tv')} !!penv + in + Pattern_env.set_env penv env) + rem; + if rem <> [] then Btype.cleanup_abbrev (); end; - ty_args, Some (ids, cty) + ty_args, Some (List.map fst ids_decls, cty) let solve_Ppat_construct ~refine tps penv loc constr no_existentials existential_styp expected_ty = @@ -915,7 +1008,7 @@ let solve_Ppat_construct ~refine tps penv loc constr no_existentials in let ty_args, equated_types, existential_ctyp = - with_local_level_iter ~post: generalize_structure begin fun () -> + with_local_level_generalize_structure begin fun () -> let expected_ty = instance expected_ty in let ty_args, ty_res, equated_types, existential_ctyp = match existential_styp with @@ -936,16 +1029,16 @@ let solve_Ppat_construct ~refine tps penv loc constr no_existentials let ty_args, ty_res, ty_ex = instance_constructor existential_treatment constr in - let equated_types = unify_res ty_res expected_ty in + let equated_types = lazy (unify_res ty_res expected_ty) in let ty_args, existential_ctyp = solve_constructor_annotation tps penv name_list sty ty_args ty_ex + (fun () -> ignore (Lazy.force equated_types)) in - ty_args, ty_res, equated_types, existential_ctyp + ty_args, ty_res, Lazy.force equated_types, existential_ctyp in if constr.cstr_existentials <> [] then lower_variables_only !!penv penv.Pattern_env.equations_scope ty_res; - ((ty_args, equated_types, existential_ctyp), - expected_ty :: ty_res :: ty_args) + (ty_args, equated_types, existential_ctyp) end in if !Clflags.principal && not refine then begin @@ -954,16 +1047,14 @@ let solve_Ppat_construct ~refine tps penv loc constr no_existentials try TypePairs.iter (fun (t1, t2) -> - generalize_structure t1; - generalize_structure t2; if not (fully_generic t1 && fully_generic t2) then let msg = - Format.asprintf + Format_doc.doc_printf "typing this pattern requires considering@ %a@ and@ %a@ as \ equal.@,\ But the knowledge of these types" - Printtyp.type_expr t1 - Printtyp.type_expr t2 + Printtyp.Doc.type_expr t1 + Printtyp.Doc.type_expr t2 in Location.prerr_warning loc (Warnings.Not_principal msg); raise Warn_only_once) @@ -973,7 +1064,7 @@ let solve_Ppat_construct ~refine tps penv loc constr no_existentials (ty_args, existential_ctyp) let solve_Ppat_record_field ~refine loc penv label label_lid record_ty = - with_local_level_iter ~post:generalize_structure begin fun () -> + with_local_level_generalize_structure begin fun () -> let (_, ty_arg, ty_res) = instance_label ~fixed:false label in begin try unify_pat_types_refine ~refine loc penv ty_res (instance record_ty) @@ -981,7 +1072,7 @@ let solve_Ppat_record_field ~refine loc penv label label_lid record_ty = raise(error(label_lid.loc, !!penv, Label_mismatch(label_lid.txt, err))) end; - (ty_arg, [ty_res; ty_arg]) + ty_arg end let solve_Ppat_array ~refine loc env expected_ty = @@ -999,7 +1090,7 @@ let solve_Ppat_lazy ~refine loc env expected_ty = let solve_Ppat_constraint tps loc env sty expected_ty = let cty, ty, force = - with_local_level ~post:(fun (_, ty, _) -> generalize_structure ty) + with_local_level_generalize_structure (fun () -> Typetexp.transl_simple_type_delayed env sty) in tps.tps_pattern_force <- force :: tps.tps_pattern_force; @@ -1156,7 +1247,7 @@ end) = struct [_] -> [] | _ -> let open Printtyp in wrap_printing_env ~error:true env (fun () -> - reset(); strings_of_paths (Some Type) tpaths) + Out_type.reset(); strings_of_paths Type tpaths) let disambiguate_by_type env tpath lbls = match lbls with @@ -1171,10 +1262,12 @@ end) = struct (* warn if there are several distinct candidates in scope *) let warn_if_ambiguous warn lid env lbl rest = if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin - Printtyp.Conflicts.reset (); + Out_type.Ident_conflicts.reset (); let paths = ambiguous_types env lbl rest in - let expansion = - Format.asprintf "%t" Printtyp.Conflicts.print_explanations in + let expansion = match Out_type.Ident_conflicts.err_msg () with + | None -> "" + | Some msg -> Format_doc.(asprintf "%a" pp_doc) msg + in if paths <> [] then warn lid.loc (Warnings.Ambiguous_name ([Longident.last lid.txt], @@ -1185,15 +1278,15 @@ end) = struct let warn_non_principal warn lid = let name = Datatype_kind.label_name kind in warn lid.loc - (Warnings.Not_principal - ("this type-based " ^ name ^ " disambiguation")) + (not_principal "this type-based %s disambiguation" name) (* we selected a name out of the lexical scope *) let warn_out_of_scope warn lid env tpath = if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin let path_s = Printtyp.wrap_printing_env ~error:true env - (fun () -> Printtyp.string_of_path tpath) in + (fun () -> Format_doc.asprintf "%a" Printtyp.Doc.type_path tpath) + in warn lid.loc (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) end @@ -1433,7 +1526,7 @@ let disambiguate_lid_a_list loc closed env usage expected_type lid_a_list = in if !w_pr then Location.prerr_warning loc - (Warnings.Not_principal "this type-based record disambiguation") + (not_principal "this type-based record disambiguation") else begin match List.rev !w_amb with (_,types,ex)::_ as amb -> @@ -1586,6 +1679,7 @@ let rec has_literal_pattern p = match p.ppat_desc with List.exists has_literal_pattern ps | Ppat_record (ps, _) -> List.exists (fun (_,p) -> has_literal_pattern p) ps + | Ppat_effect (p, q) | Ppat_or (p, q) -> has_literal_pattern p || has_literal_pattern q @@ -1782,22 +1876,32 @@ and type_pat_aux pat_type = type_constant cst; pat_attributes = sp.ppat_attributes; pat_env = !!penv } - | Ppat_interval (Pconst_char c1, Pconst_char c2) -> - let open Ast_helper.Pat in + | Ppat_interval (c1, c2) -> + let open Ast_helper in + let get_bound = function + | {pconst_desc = Pconst_char c; _} -> c + | {pconst_loc = loc; _} -> + raise (Error (loc, !!penv, Invalid_interval)) + in + let c1 = get_bound c1 in + let c2 = get_bound c2 in let gloc = {loc with Location.loc_ghost=true} in let rec loop c1 c2 = - if c1 = c2 then constant ~loc:gloc (Pconst_char c1) + if c1 = c2 then Pat.constant ~loc:gloc (Const.char ~loc:gloc c1) else - or_ ~loc:gloc - (constant ~loc:gloc (Pconst_char c1)) + Pat.or_ ~loc:gloc + (Pat.constant ~loc:gloc (Const.char ~loc:gloc c1)) (loop (Char.chr(Char.code c1 + 1)) c2) in let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in let p = {p with ppat_loc=loc} in type_pat tps category p expected_ty (* TODO: record 'extra' to remember about interval *) +<<<<<<< | Ppat_interval _ -> raise (error (loc, !!penv, Invalid_interval)) +======= +>>>>>>> | Ppat_tuple spl -> assert (List.length spl >= 2); let expected_tys = @@ -1967,6 +2071,8 @@ and type_pat_aux forces. *) let tps1 = copy_type_pat_state tps in let tps2 = {(copy_type_pat_state tps) with tps_pattern_force = []} in + (* Introduce a new level to avoid keeping nodes at intermediate levels *) + let pat_desc = with_local_level_generalize begin fun () -> (* Introduce a new scope using with_local_level without generalizations *) let env1, p1, env2, p2 = with_local_level begin fun () -> @@ -2009,7 +2115,10 @@ and type_pat_aux } ~dst:tps; let p2 = alpha_pat alpha_env p2 in - rp { pat_desc = Tpat_or (p1, p2, None); + Tpat_or (p1, p2, None) + end + in + rp { pat_desc = pat_desc; pat_loc = loc; pat_extra = []; pat_type = instance expected_ty; pat_attributes = sp.ppat_attributes; @@ -2072,6 +2181,8 @@ and type_pat_aux pat_env = !!penv; pat_attributes = sp.ppat_attributes; } + | Ppat_effect _ -> + raise (Error (loc, !!penv, Effect_pattern_below_toplevel)) | Ppat_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -2080,8 +2191,8 @@ let iter_pattern_variables_type f : pattern_variable list -> unit = let add_pattern_variables ?check ?check_as env pv = List.fold_right - (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} env -> - let check = if pv_as_var then check_as else check in + (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes; pv_uid} env -> + let check = if pv_kind=As_var then check_as else check in Env.add_value ?check pv_id {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; val_attributes = pv_attributes; @@ -2130,8 +2241,8 @@ let add_module_variables env module_variables = let type_pat tps category ?no_existentials penv = type_pat tps category ~no_existentials ~penv -let type_pattern category ~lev env spat expected_ty allow_modules = - let tps = create_type_pat_state allow_modules in +let type_pattern category ~lev env spat expected_ty ?cont allow_modules = + let tps = create_type_pat_state ?cont allow_modules in let new_penv = Pattern_env.make env ~equations_scope:lev ~allow_recursive_equations:false in let pat = type_pat tps category new_penv spat expected_ty in @@ -2177,13 +2288,13 @@ let type_class_arg_pattern cl_num val_env met_env l spat = if is_optional l then unify_pat val_env pat (type_option (newvar ())); let (pv, val_env, met_env) = List.fold_right - (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} + (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes} (pv, val_env, met_env) -> let check s = - if pv_as_var then Warnings.Unused_var s + if pv_kind = As_var then Warnings.Unused_var s else Warnings.Unused_var_strict s in let id' = Ident.rename pv_id in - let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let val_env = Env.add_value pv_id { val_type = pv_type @@ -2590,9 +2701,9 @@ let rec final_subexpression exp = match exp.exp_desc with Texp_let (_, _, e) | Texp_sequence (_, e) - | Texp_try (e, _) + | Texp_try (e, _, _) | Texp_ifthenelse (_, e, _) - | Texp_match (_, {c_rhs=e} :: _, _) + | Texp_match (_, {c_rhs=e} :: _, _, _) | Texp_letmodule (_, _, _, _, e) | Texp_letexception (_, e) | Texp_open (_, e) @@ -2614,7 +2725,7 @@ let rec is_nonexpansive exp = is_nonexpansive body | Texp_apply(e, (_,None)::el) -> is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) - | Texp_match(e, cases, _) -> + | Texp_match(e, cases, _, _) -> (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't care if there are exception patterns. But the previous version enforced that there be none, so... *) @@ -2880,14 +2991,19 @@ let rec list_labels_aux env visited ls ty_fun = List.rev ls, is_Tvar ty let list_labels env ty = - wrap_trace_gadt_instances env (list_labels_aux env TypeSet.empty []) ty + let snap = Btype.snapshot () in + let result = + wrap_trace_gadt_instances env (list_labels_aux env TypeSet.empty []) ty + in + Btype.backtrack snap; + result (* Check that all univars are safe in a type. Both exp.exp_type and ty_expected should already be generalized. *) let check_univars env kind exp ty_expected vars = let pty = instance ty_expected in let exp_ty, vars = - with_local_level_iter ~post:generalize begin fun () -> + with_local_level_generalize begin fun () -> match get_desc pty with Tpoly (body, tl) -> (* Enforce scoping for type_let: @@ -2896,7 +3012,7 @@ let check_univars env kind exp ty_expected vars = let _, ty' = instance_poly ~fixed:true tl body in let vars, exp_ty = instance_parameterized_type vars exp.exp_type in unify_exp_types exp.exp_loc env exp_ty ty'; - ((exp_ty, vars), exp_ty::vars) + (exp_ty, vars) | _ -> assert false end in @@ -2910,12 +3026,6 @@ let check_univars env kind exp ty_expected vars = ~trace:[Ctype.expanded_diff env ~got:ty ~expected:ty_expected]))) -let generalize_and_check_univars env kind exp ty_expected vars = - generalize exp.exp_type; - generalize ty_expected; - List.iter generalize vars; - check_univars env kind exp ty_expected vars - (* [check_statement] implements the [non-unit-statement] check. This check is called in contexts where the value of the expression is known @@ -2990,10 +3100,13 @@ let check_partial_application ~statement exp = | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None) | Texp_function _ -> check_statement () - | Texp_match (_, cases, _) -> - List.iter (fun {c_rhs; _} -> check c_rhs) cases - | Texp_try (e, cases) -> - check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases + | Texp_match (_, cases, eff_cases, _) -> + List.iter (fun {c_rhs; _} -> check c_rhs) cases; + List.iter (fun {c_rhs; _} -> check c_rhs) eff_cases + | Texp_try (e, cases, eff_cases) -> + check e; + List.iter (fun {c_rhs; _} -> check c_rhs) cases; + List.iter (fun {c_rhs; _} -> check c_rhs) eff_cases | Texp_ifthenelse (_, e1, Some e2) -> check e1; check e2 | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e) @@ -3034,13 +3147,13 @@ let pattern_needs_partial_application_check p = (* Check that a type is generalizable at some level *) let generalizable level ty = - let rec check ty = - if not_marked_node ty then - if get_level ty <= level then raise Exit else - (flip_mark_node ty; iter_type_expr check ty) - in - try check ty; unmark_type ty; true - with Exit -> unmark_type ty; false + with_type_mark begin fun mark -> + let rec check ty = + if try_mark_node mark ty then + if get_level ty <= level then raise Exit else iter_type_expr check ty + in + try check ty; true with Exit -> false + end (* Hack to allow coercion of self. Will clean-up later. *) let self_coercion = ref ([] : (Path.t * Location.t list ref) list) @@ -3048,8 +3161,9 @@ let self_coercion = ref ([] : (Path.t * Location.t list ref) list) (* Helpers for type_cases *) let contains_variant_either ty = + with_type_mark begin fun mark -> let rec loop ty = - if try_mark_node ty then + if try_mark_node mark ty then begin match get_desc ty with Tvariant row -> if not (is_fixed row) then @@ -3062,8 +3176,8 @@ let contains_variant_either ty = iter_type_expr loop ty end in - try loop ty; unmark_type ty; false - with Exit -> unmark_type ty; true + try loop ty; false with Exit -> true + end let shallow_iter_ppat f p = match p.ppat_desc with @@ -3072,7 +3186,8 @@ let shallow_iter_ppat f p = | Ppat_extension _ | Ppat_type _ | Ppat_unpack _ -> () | Ppat_array pats -> List.iter f pats - | Ppat_or (p1,p2) -> f p1; f p2 + | Ppat_or (p1,p2) + | Ppat_effect(p1, p2) -> f p1; f p2 | Ppat_variant (_, arg) -> Option.iter f arg | Ppat_tuple lst -> List.iter f lst | Ppat_construct (_, Some (_, p)) @@ -3141,14 +3256,14 @@ let check_absent_variant env = || not (is_fixed row) && not (static_row row) (* same as Ctype.poly *) then () else let ty_arg = - match arg with None -> [] | Some p -> [correct_levels p.pat_type] in + match arg with None -> [] | Some p -> [duplicate_type p.pat_type] in let fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in let row' = create_row ~fields ~more:(newvar ()) ~closed:false ~fixed:None ~name:None in (* Should fail *) unify_pat env {pat with pat_type = newty (Tvariant row')} - (correct_levels pat.pat_type) + (duplicate_type pat.pat_type) | _ -> () } (* Getting proper location of already typed expressions. @@ -3187,14 +3302,18 @@ let name_cases default lst = (* Typing of expressions *) -(** [sdesc_for_hint] is used by error messages to report literals in their +(** [sexp_for_hint] is used by error messages to report literals in their original formatting *) -let unify_exp ?sdesc_for_hint env exp expected_ty = +let unify_exp ~sexp env exp expected_ty = let loc = proper_exp_loc exp in try unify_exp_types loc env exp.exp_type expected_ty with Error(loc, env, Expr_type_clash(err, tfc, None)) -> +<<<<<<< raise (error(loc, env, Expr_type_clash(err, tfc, sdesc_for_hint))) +======= + raise (Error(loc, env, Expr_type_clash(err, tfc, Some sexp))) +>>>>>>> (* If [is_inferred e] is true, [e] will be typechecked without using the "expected type" provided by the context. *) @@ -3246,10 +3365,8 @@ let with_explanation explanation f = raise (error (loc', env', err)) (* Generalize expressions *) -let generalize_structure_exp exp = generalize_structure exp.exp_type -let may_lower_contravariant_then_generalize env exp = - if maybe_expansive exp then lower_contravariant env exp.exp_type; - generalize exp.exp_type +let may_lower_contravariant env exp = + if maybe_expansive exp then lower_contravariant env exp.exp_type (* value binding elaboration *) @@ -3359,16 +3476,15 @@ and type_expect_ env sexp ty_expected_explained = let { ty = ty_expected; explanation } = ty_expected_explained in let loc = sexp.pexp_loc in - let desc = sexp.pexp_desc in (* Record the expression type before unifying it with the expected type *) let with_explanation = with_explanation explanation in (* Unify the result with [ty_expected], enforcing the current level *) let rue exp = with_explanation (fun () -> - unify_exp ~sdesc_for_hint:desc env (re exp) (instance ty_expected)); + unify_exp ~sexp env (re exp) (instance ty_expected)); exp in - match desc with + match sexp.pexp_desc with | Pexp_ident lid -> let path, desc = type_ident env ~recarg lid in let exp_desc = @@ -3395,7 +3511,7 @@ and type_expect_ exp_type = instance desc.val_type; exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_constant(Pconst_string (str, _, _) as cst) -> ( + | Pexp_constant({pconst_desc = Pconst_string (str, _, _); _} as cst) -> ( let cst = constant_or_raise env loc cst in (* Terrible hack for format strings *) let ty_exp = expand_head env (protect_expansion env ty_expected) in @@ -3407,7 +3523,7 @@ and type_expect_ | Tconstr(path, _, _) when Path.same path fmt6_path -> if !Clflags.principal && get_level ty_exp <> generic_level then Location.prerr_warning loc - (Warnings.Not_principal "this coercion to format6"); + (not_principal "this coercion to format6"); true | _ -> false in @@ -3455,7 +3571,7 @@ and type_expect_ introduced by those unpacks. The below code checks for scope escape via both of these pathways (body, bound expressions). *) - with_local_level_if may_contain_modules begin fun () -> + with_local_level_generalize_if may_contain_modules begin fun () -> let allow_modules = if may_contain_modules then @@ -3486,7 +3602,6 @@ and type_expect_ types added to [new_env]. *) let bound_exp = vb.vb_expr in - generalize_structure_exp bound_exp; let bound_exp_type = Ctype.instance bound_exp.exp_type in let loc = proper_exp_loc bound_exp in let outer_var = newvar2 outer_level in @@ -3500,9 +3615,9 @@ and type_expect_ end; (pat_exp_list, body, new_env) end - ~post:(fun (_pat_exp_list, body, new_env) -> + ~before_generalize:(fun (_pat_exp_list, body, new_env) -> (* The "body" component of the scope escape check. *) - unify_exp new_env body (newvar ())) + unify_exp ~sexp new_env body (newvar ())) in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); @@ -3566,28 +3681,27 @@ and type_expect_ } | Pexp_apply(sfunct, sargs) -> assert (sargs <> []); + let outer_level = get_current_level () in let rec lower_args seen ty_fun = let ty = expand_head env ty_fun in if TypeSet.mem ty seen then () else match get_desc ty with Tarrow (_l, ty_arg, ty_fun, _com) -> - (try enforce_current_level env ty_arg + (try Ctype.unify_var env (newvar2 outer_level) ty_arg with Unify _ -> assert false); lower_args (TypeSet.add ty seen) ty_fun | _ -> () in + (* one more level for warning on non-returning functions *) + with_local_level_generalize begin fun () -> let type_sfunct sfunct = - (* one more level for warning on non-returning functions *) - with_local_level_iter - begin fun () -> - let funct = - with_local_level_if_principal (fun () -> type_exp env sfunct) - ~post: generalize_structure_exp - in - let ty = instance funct.exp_type in - (funct, [ty]) - end - ~post:(wrap_trace_gadt_instances env (lower_args TypeSet.empty)) + let funct = + with_local_level_generalize_structure_if_principal + (fun () -> type_exp env sfunct) + in + let ty = instance funct.exp_type in + wrap_trace_gadt_instances env (lower_args TypeSet.empty) ty; + funct in let funct, sargs = let funct = type_sfunct sfunct in @@ -3613,33 +3727,72 @@ and type_expect_ exp_type = ty_res; exp_attributes = sexp.pexp_attributes; exp_env = env } + end | Pexp_match(sarg, caselist) -> let arg = - with_local_level (fun () -> type_exp env sarg) - ~post:(may_lower_contravariant_then_generalize env) + with_local_level_generalize (fun () -> type_exp env sarg) + ~before_generalize:(may_lower_contravariant env) + in + let rec split_cases valc effc conts = function + | [] -> List.rev valc, List.rev effc, List.rev conts + | {pc_lhs = {ppat_desc=Ppat_effect(p1, p2)}} as c :: rest -> + split_cases valc + (({c with pc_lhs = p1}) :: effc) (p2 :: conts) rest + | c :: rest -> + split_cases (c :: valc) effc conts rest + in + let val_caselist, eff_caselist, eff_conts = + split_cases [] [] [] caselist + in + if val_caselist = [] && eff_caselist <> [] then + raise (Error (loc, env, No_value_clauses)); + let val_cases, partial = + type_cases Computation env arg.exp_type ty_expected_explained + ~check_if_total:true loc val_caselist + in + let eff_cases = + match eff_caselist with + | [] -> [] + | eff_caselist -> + type_effect_cases Value env ty_expected_explained loc eff_caselist + eff_conts in - let cases, partial = - type_cases Computation env - arg.exp_type ty_expected_explained - ~check_if_total:true loc caselist in if List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs) - cases + val_cases then check_partial_application ~statement:false arg; re { - exp_desc = Texp_match(arg, cases, partial); + exp_desc = Texp_match(arg, val_cases, eff_cases, partial); exp_loc = loc; exp_extra = []; exp_type = instance ty_expected; exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_try(sbody, caselist) -> let body = type_expect env sbody ty_expected_explained in - let cases, _ = - type_cases Value env - Predef.type_exn ty_expected_explained - ~check_if_total:false loc caselist in + let rec split_cases exnc effc conts = function + | [] -> List.rev exnc, List.rev effc, List.rev conts + | {pc_lhs = {ppat_desc=Ppat_effect(p1, p2)}} as c :: rest -> + split_cases exnc + (({c with pc_lhs = p1}) :: effc) (p2 :: conts) rest + | c :: rest -> + split_cases (c :: exnc) effc conts rest + in + let exn_caselist, eff_caselist, eff_conts = + split_cases [] [] [] caselist + in + let exn_cases, _ = + type_cases Value env Predef.type_exn ty_expected_explained + ~check_if_total:false loc exn_caselist + in + let eff_cases = + match eff_caselist with + | [] -> [] + | eff_caselist -> + type_effect_cases Value env ty_expected_explained loc eff_caselist + eff_conts + in re { - exp_desc = Texp_try(body, cases); + exp_desc = Texp_try(body, exn_cases, eff_cases); exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_attributes = sexp.pexp_attributes; @@ -3662,7 +3815,7 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_construct(lid, sarg) -> - type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes + type_construct env ~sexp lid sarg ty_expected_explained | Pexp_variant(l, sarg) -> (* Keep sharing *) let ty_expected1 = protect_expansion env ty_expected in @@ -3713,9 +3866,8 @@ and type_expect_ None -> None | Some sexp -> let exp = - with_local_level_if_principal + with_local_level_generalize_structure_if_principal (fun () -> type_exp ~recarg env sexp) - ~post: generalize_structure_exp in Some exp in @@ -3748,7 +3900,7 @@ and type_expect_ | (None | Some (_, _, false)), Some (_, p', _) -> let decl = Env.find_type p' env in let ty = - with_local_level ~post:generalize_structure + with_local_level_generalize_structure (fun () -> newconstr p' (instance_list decl.type_params)) in ty, opt_exp_opath @@ -3867,7 +4019,7 @@ and type_expect_ type_label_access env srecord Env.Projection lid in let (_, ty_arg, ty_res) = instance_label ~fixed:false label in - unify_exp env record ty_res; + unify_exp ~sexp env record ty_res; rue { exp_desc = Texp_field(record, lid, label); exp_loc = loc; exp_extra = []; @@ -3881,7 +4033,7 @@ and type_expect_ if expected_type = None then newvar () else record.exp_type in let (label_loc, label, newval) = type_label_exp false env loc ty_record (lid, label, snewval) in - unify_exp env record ty_record; + unify_exp ~sexp env record ty_record; if label.lbl_mut = Immutable then raise(error(loc, env, Label_not_mutable lid.txt)); rue { @@ -3920,7 +4072,7 @@ and type_expect_ let ifso = type_expect env sifso ty_expected_explained in let ifnot = type_expect env sifnot ty_expected_explained in (* Keep sharing *) - unify_exp env ifnot ifso.exp_type; + unify_exp ~sexp env ifnot ifso.exp_type; re { exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); exp_loc = loc; exp_extra = []; @@ -3967,7 +4119,7 @@ and type_expect_ val_attributes = []; val_kind = Val_reg; val_loc = loc; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } env ~check:(fun s -> Warnings.Unused_for_index s) | _ -> @@ -4008,9 +4160,15 @@ and type_expect_ let obj = type_exp env e in begin try let (obj,meth,typ) = - with_local_level_if_principal + with_local_level_generalize_structure_if_principal (fun () -> type_send env loc explanation e met) +<<<<<<< ~post:(fun (_,_,typ) -> generalize_structure typ) +======= + in + let typ = + match get_desc typ with +>>>>>>> in let typ = match get_desc typ with @@ -4281,18 +4439,50 @@ and type_expect_ generalize_and_check_univars env "method" exp ty_expected vars end in +<<<<<<< { exp with exp_type = instance ty } +======= + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc + (not_principal "this use of a polymorphic method"); + snd (instance_poly ~fixed:false tl ty) +>>>>>>> | Tvar _ -> +<<<<<<< +======= + { exp with exp_type = instance ty } + | Tpoly (ty', tl) -> + (* One more level to generalize locally *) + let (exp, vars) = + with_local_level_generalize begin fun () -> + let vars, ty'' = + with_local_level_generalize_structure_if_principal + (fun () -> instance_poly ~fixed:true tl ty') + in + let exp = type_expect env sbody (mk_expected ty'') in + (exp, vars) + end + in + check_univars env "method" exp ty_expected vars; + { exp with exp_type = instance ty } + | Tvar _ -> +>>>>>>> let exp = type_exp env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in - unify_exp env exp ty; + unify_exp ~sexp env exp ty; exp | _ -> assert false in re { exp with exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } +<<<<<<< | Pexp_newtype({txt=name} as label_loc, sbody) -> let body, ety, id, uid = type_newtype loc env name (fun env -> +======= + | Pexp_newtype(name, sbody) -> + let body, ety = type_newtype env name (fun env -> +>>>>>>> let expr = type_exp env sbody in expr, expr.exp_type) in @@ -4300,7 +4490,12 @@ and type_expect_ any new extra node in the typed AST. *) rue { body with exp_loc = loc; exp_type = ety; exp_extra = +<<<<<<< (Texp_newtype' (id, label_loc, uid), loc, sexp.pexp_attributes) :: body.exp_extra } +======= + (Texp_newtype name.txt, loc, sexp.pexp_attributes) :: body.exp_extra + } +>>>>>>> | Pexp_pack m -> let (p, fl) = match get_desc (Ctype.expand_head env (instance ty_expected)) with @@ -4311,7 +4506,7 @@ and type_expect_ < Btype.generic_level then Location.prerr_warning loc - (Warnings.Not_principal "this module packing"); + (not_principal "this module packing"); (p, fl) | Tvar _ -> raise (error (loc, env, Cannot_infer_signature)) @@ -4362,8 +4557,7 @@ and type_expect_ in let op_path, op_desc, op_type, spat_params, ty_params, ty_func_result, ty_result, ty_andops = - with_local_level_iter_if_principal - ~post:generalize_structure begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let let_loc = slet.pbop_op.loc in let op_path, op_desc = type_binding_op_ident env slet.pbop_op in let op_type = instance op_desc.val_type in @@ -4382,9 +4576,8 @@ and type_expect_ with Unify err -> raise(error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) end; - ((op_path, op_desc, op_type, spat_params, ty_params, - ty_func_result, ty_result, ty_andops), - [ty_andops; ty_params; ty_func_result; ty_result]) + (op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops) end in let exp, ands = type_andops env slet.pbop_exp sands ty_andops in @@ -4495,11 +4688,12 @@ and type_coerce in let arg, arg_type, gen = let lv = get_current_level () in - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let arg, arg_type = type_without_constraint env in arg, arg_type, generalizable lv arg_type end - ~post:(fun (_, arg_type, _) -> enforce_current_level env arg_type) + ~before_generalize: + (fun (_, arg_type, _) -> enforce_current_level env arg_type) in begin match !self_coercion, get_desc ty' with | ((path, r) :: _, Tconstr (path', _, _)) @@ -4522,7 +4716,7 @@ and type_coerce force (); force' (); if not gen && !Clflags.principal then Location.prerr_warning loc - (Warnings.Not_principal "this ground coercion"); + (not_principal "this ground coercion"); with Subtype err -> (* prerr_endline "coercion failed"; *) raise (Error (loc, env, Not_subtype err)) @@ -4539,14 +4733,13 @@ and type_coerce (arg, ty', Texp_coerce (None, cty')) | Some sty -> let cty, ty, force, cty', ty', force' = - with_local_level_iter ~post:generalize_structure begin fun () -> + with_local_level_generalize_structure begin fun () -> let (cty, ty, force) = Typetexp.transl_simple_type_delayed env sty and (cty', ty', force') = Typetexp.transl_simple_type_delayed env sty' in - ((cty, ty, force, cty', ty', force'), - [ ty; ty' ]) + (cty, ty, force, cty', ty', force') end in begin try @@ -4561,10 +4754,9 @@ and type_coerce and type_constraint env sty = (* Pretend separate = true, 1% slowdown for lablgtk *) let cty = - with_local_level begin fun () -> + with_local_level_generalize_structure begin fun () -> Typetexp.transl_simple_type env ~closed:false sty end - ~post:(fun cty -> generalize_structure cty.ctyp_type) in cty.ctyp_type, Texp_constraint cty @@ -4599,18 +4791,23 @@ and type_constraint_expect nodes for the newtype properly linked. *) and type_newtype +<<<<<<< : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr * Ident.t * Uid.t = fun loc env name type_body -> +======= + : type a. _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr = + fun env { txt = name; loc = name_loc } type_body -> +>>>>>>> let ty = if Typetexp.valid_tyvar_name name then newvar ~name () else newvar () in - (* Use [with_local_level] just for scoping *) - with_local_level begin fun () -> + (* Use [with_local_level_generalize] just for scoping *) + with_local_level_generalize begin fun () -> (* Create a fake abstract type declaration for [name]. *) - let decl = new_local_type ~loc Definition in + let decl = new_local_type ~loc:name_loc Definition in let scope = create_scope () in let (id, new_env) = Env.enter_type ~scope name decl env in @@ -4632,6 +4829,7 @@ and type_newtype let uid = decl.type_uid in (result, ety, id, uid) end + ~before_generalize:(fun (_,ety) -> enforce_current_level env ety) and type_ident env ?(recarg=Rejected) lid = let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in @@ -4680,7 +4878,7 @@ and type_binding_op_ident env s = and split_function_ty env ty_expected ~arg_label ~first ~in_function = let { ty = ty_fun; explanation }, loc = in_function in let separate = !Clflags.principal || Env.has_local_constraints env in - with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + with_local_level_generalize_structure_if separate begin fun () -> let ty_arg, ty_res = try filter_arrow env (instance ty_expected) arg_label with Filter_arrow_failed err -> @@ -4709,7 +4907,7 @@ and split_function_ty env ty_expected ~arg_label ~first ~in_function = type_option tv else ty_arg in - (ty_arg, ty_res), [ ty_arg; ty_res ] + (ty_arg, ty_res) end (* Typecheck parameters one at a time followed by the body. Later parameters @@ -4751,8 +4949,13 @@ and type_function match params_suffix with | { pparam_desc = Pparam_newtype newtype; pparam_loc = _ } :: rest -> (* Check everything else in the scope of (type a). *) +<<<<<<< let (params, body, newtypes, contains_gadt), exp_type, nt_id, nt_uid = type_newtype loc env newtype.txt (fun env -> +======= + let (params, body, newtypes, contains_gadt), exp_type = + type_newtype env newtype (fun env -> +>>>>>>> let exp_type, params, body, newtypes, contains_gadt = (* mimic the typing of Pexp_newtype by minting a new type var, like [type_exp]. @@ -4808,7 +5011,7 @@ and type_function (* We don't make use of [case_data] here so we pass unit. *) [ { pattern = pat; has_guard = false; needs_refute = false }, () ] ~type_body:begin - fun () pat ~ext_env ~ty_expected ~ty_infer:_ + fun () pat ~when_env:_ ~ext_env ~cont:_ ~ty_expected ~ty_infer:_ ~contains_gadt:param_contains_gadt -> let _, params, body, newtypes, suffix_contains_gadt = type_function ext_env rest body_constraint body @@ -4905,7 +5108,7 @@ and type_function [type_argument] on the cases, and discard the cases' inferred type in favor of the constrained type. (Function cases aren't inferred, so [type_argument] would just call - [type_expect] straightaway, so we do the same here.) + [type_expect] straight away, so we do the same here.) - [type_without_constraint]: If there is just a coercion and no constraint, call [type_exp] on the cases and surface the cases' inferred type to [type_constraint_expect]. *) @@ -4944,7 +5147,7 @@ and type_function and type_label_access env srecord usage lid = let record = - with_local_level_if_principal ~post:generalize_structure_exp + with_local_level_generalize_structure_if_principal (fun () -> type_exp ~recarg:Allowed env srecord) in let ty_exp = record.exp_type in @@ -5004,7 +5207,9 @@ and type_format loc str env = | [ e ] -> Some e | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in - let mk_cst cst = mk_exp_loc (Pexp_constant cst) in + let mk_cst cst = + mk_exp_loc (Pexp_constant {pconst_desc = cst; pconst_loc = loc}) + in let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None)) and mk_string str = mk_cst (Pconst_string (str, loc, None)) and mk_char chr = mk_cst (Pconst_char chr) in @@ -5230,22 +5435,15 @@ and type_label_exp create env loc ty_expected (lid, label, sarg) = (* Here also ty_expected may be at generic_level *) let separate = !Clflags.principal || Env.has_local_constraints env in - (* #4682: we try two type-checking approaches for [arg] using backtracking: - - first try: we try with [ty_arg] as expected type; - - second try; if that fails, we backtrack and try without - *) - let (vars, ty_arg, snap, arg) = - (* try the first approach *) - with_local_level begin fun () -> + let is_poly = label_is_poly label in + let (vars, arg) = + (* raise level to check univars *) + with_local_level_generalize_if is_poly begin fun () -> let (vars, ty_arg) = - with_local_level_iter_if separate begin fun () -> + with_local_level_generalize_structure_if separate begin fun () -> let (vars, ty_arg, ty_res) = - with_local_level_iter_if separate ~post:generalize_structure - begin fun () -> - let ((_, ty_arg, ty_res) as r) = - instance_label ~fixed:true label in - (r, [ty_arg; ty_res]) - end + with_local_level_generalize_structure_if separate + (fun () -> instance_label ~fixed:true label) in begin try unify env (instance ty_res) (instance ty_expected) @@ -5254,55 +5452,28 @@ and type_label_exp create env loc ty_expected end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance ty_arg in - ((vars, ty_arg), [ty_arg]) + (vars, ty_arg) end - ~post:generalize_structure in if label.lbl_private = Private then if create then raise (error(loc, env, Private_type ty_expected)) else +<<<<<<< raise (error(lid.loc, env, Private_label(lid.txt, ty_expected))); let snap = if vars = [] then None else Some (Btype.snapshot ()) in let arg = type_argument env sarg ty_arg (instance ty_arg) in (vars, ty_arg, snap, arg) +======= + raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); + (vars, type_argument env sarg ty_arg (instance ty_arg)) +>>>>>>> end - (* Note: there is no generalization logic here as could be expected, - because it is part of the backtracking logic below. *) + ~before_generalize:(fun (_,arg) -> may_lower_contravariant env arg) in - let arg = - try - if (vars = []) then arg - else begin - (* We detect if the first try failed here, - during generalization. *) - if maybe_expansive arg then - lower_contravariant env arg.exp_type; - generalize_and_check_univars env "field value" arg label.lbl_arg vars; - {arg with exp_type = instance arg.exp_type} - end - with first_try_exn when maybe_expansive arg -> try - (* backtrack and try the second approach *) - Option.iter Btype.backtrack snap; - let arg = with_local_level (fun () -> type_exp env sarg) - ~post:(fun arg -> lower_contravariant env arg.exp_type) - in - let arg = - with_local_level begin fun () -> - let arg = {arg with exp_type = instance arg.exp_type} in - unify_exp env arg (instance ty_arg); - arg - end - ~post: begin fun arg -> - generalize_and_check_univars env "field value" arg label.lbl_arg vars - end - in - {arg with exp_type = instance arg.exp_type} - with Error (_, _, Less_general _) as e -> raise e - | _ -> raise first_try_exn - in - (lid, label, arg) + if is_poly then check_univars env "field value" arg label.lbl_arg vars; + (lid, label, {arg with exp_type = instance arg.exp_type}) and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) @@ -5330,7 +5501,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = (* apply optional arguments when expected type is "" *) (* we must be very careful about not breaking the semantics *) let texp = - with_local_level_if_principal ~post:generalize_structure_exp + with_local_level_generalize_structure_if_principal (fun () -> type_exp env sarg) in let rec make_args args ty_fun = @@ -5346,7 +5517,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = let args, ty_fun', simple_res = make_args [] texp.exp_type and texp = {texp with exp_type = instance texp.exp_type} in if not (simple_res || safe_expect) then begin - unify_exp env texp ty_expected; + unify_exp ~sexp:sarg env texp ty_expected; texp end else begin let warn = !Clflags.principal && @@ -5357,7 +5528,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = Tarrow(Nolabel,ty_arg,ty_res,_) -> ty_arg, ty_res | _ -> assert false in - unify_exp env {texp with exp_type = ty_fun} ty_expected; + unify_exp ~sexp:sarg env {texp with exp_type = ty_fun} ty_expected; if args = [] then texp else (* eta-expand to avoid side effects *) let var_pair name ty = @@ -5366,7 +5537,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = { val_type = ty; val_kind = Val_reg; val_attributes = []; val_loc = Location.none; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in let exp_env = Env.add_value id desc env in @@ -5402,7 +5573,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = in Location.prerr_warning texp.exp_loc (Warnings.Eliminated_optional_arguments - (List.map (fun (l, _) -> Printtyp.string_of_label l) args)); + (List.map (fun (l, _) -> Asttypes.string_of_label l) args)); if warn then Location.prerr_warning texp.exp_loc (Warnings.Non_principal_labels "eliminated optional argument"); (* let-expand to have side effects *) @@ -5417,7 +5588,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = | None -> let texp = type_expect ?recarg env sarg (mk_expected ?explanation ty_expected') in - unify_exp env texp ty_expected; + unify_exp ~sexp:sarg env texp ty_expected; texp and type_application env funct sargs = @@ -5489,7 +5660,7 @@ and type_application env funct sargs = let arg () = let arg = type_expect env sarg (mk_expected ty_arg) in if is_optional lbl then - unify_exp env arg (type_option(newvar())); + unify_exp ~sexp:sarg env arg (type_option(newvar())); arg in (ty_res, (lbl, Some (arg, Some sarg.pexp_loc)) :: typed_args) @@ -5506,7 +5677,7 @@ and type_application env funct sargs = (Location.prerr_warning funct.exp_loc (Warnings.Labels_omitted - (List.map Printtyp.string_of_label + (List.map Asttypes.string_of_label (List.filter ((<>) Nolabel) labels))); true) end @@ -5553,7 +5724,7 @@ and type_application env funct sargs = (fun () -> type_argument env sarg ty ty0) else begin may_warn sarg.pexp_loc - (Warnings.Not_principal "using an optional argument here"); + (not_principal "using an optional argument here"); (fun () -> option_some env (type_argument env sarg (extract_option_type env ty) (extract_option_type env ty0))) @@ -5592,11 +5763,11 @@ and type_application env funct sargs = | Some (l', sarg, commuted, remaining_sargs) -> if commuted then begin may_warn sarg.pexp_loc - (Warnings.Not_principal "commuting this argument") + (not_principal "commuting this argument") end; if not optional && is_optional l' then Location.prerr_warning sarg.pexp_loc - (Warnings.Nonoptional_label (Printtyp.string_of_label l)); + (Warnings.Nonoptional_label (Asttypes.string_of_label l)); remaining_sargs, Some (use_arg sarg l', Some sarg.pexp_loc) | None -> sargs, @@ -5620,22 +5791,19 @@ and type_application env funct sargs = (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true with Filter_arrow_failed _ -> false) in - (* Extra scope to check for non-returning functions *) - with_local_level begin fun () -> - match sargs with - | (* Special case for ignore: avoid discarding warning *) - [Nolabel, sarg] when is_ignore funct -> - let ty_arg, ty_res = - filter_arrow env (instance funct.exp_type) Nolabel in - let exp = type_expect env sarg (mk_expected ty_arg) in - check_partial_application ~statement:false exp; - ([Nolabel, Some exp], ty_res) - | _ -> - let ty = funct.exp_type in - type_args [] ty (instance ty) sargs - end + match sargs with + | (* Special case for ignore: avoid discarding warning *) + [Nolabel, sarg] when is_ignore funct -> + let ty_arg, ty_res = + filter_arrow env (instance funct.exp_type) Nolabel in + let exp = type_expect env sarg (mk_expected ty_arg) in + check_partial_application ~statement:false exp; + ([Nolabel, Some exp], ty_res) + | _ -> + let ty = funct.exp_type in + type_args [] ty (instance ty) sargs -and type_construct env loc lid sarg ty_expected_explained attrs = +and type_construct env ~sexp lid sarg ty_expected_explained = let { ty = ty_expected; explanation } = ty_expected_explained in let expected_type = match extract_concrete_variant env ty_expected with @@ -5645,8 +5813,13 @@ and type_construct env loc lid sarg ty_expected_explained attrs = | Not_a_variant_type -> let srt = wrong_kind_sort_of_constructor lid.txt in let ctx = Expression explanation in +<<<<<<< let err = Wrong_expected_kind(srt, ctx, ty_expected) in raise (error (loc, env, err)) +======= + let error = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (Error (sexp.pexp_loc, env, error)) +>>>>>>> in let constrs = Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env @@ -5660,37 +5833,41 @@ and type_construct env loc lid sarg ty_expected_explained attrs = match sarg with None -> [] | Some {pexp_desc = Pexp_tuple sel} when - constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs + constr.cstr_arity > 1 + || Builtin_attributes.explicit_arity sexp.pexp_attributes -> sel | Some se -> [se] in if List.length sargs <> constr.cstr_arity then +<<<<<<< raise(error(loc, env, Constructor_arity_mismatch (lid.txt, constr.cstr_arity, List.length sargs))); +======= + raise(Error(sexp.pexp_loc, env, + Constructor_arity_mismatch + (lid.txt, constr.cstr_arity, List.length sargs))); +>>>>>>> let separate = !Clflags.principal || Env.has_local_constraints env in let ty_args, ty_res, texp = - with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + with_local_level_generalize_structure_if separate begin fun () -> let ty_args, ty_res, texp = - with_local_level_if separate begin fun () -> + with_local_level_generalize_structure_if separate begin fun () -> let (ty_args, ty_res, _) = instance_constructor Keep_existentials_flexible constr in let texp = re { exp_desc = Texp_construct(lid, constr, []); - exp_loc = loc; exp_extra = []; + exp_loc = sexp.pexp_loc; exp_extra = []; exp_type = ty_res; - exp_attributes = attrs; + exp_attributes = sexp.pexp_attributes; exp_env = env } in (ty_args, ty_res, texp) end - ~post: begin fun (_, ty_res, texp) -> - generalize_structure ty_res; - with_explanation explanation (fun () -> - unify_exp env {texp with exp_type = instance ty_res} - (instance ty_expected)); - end in - ((ty_args, ty_res, texp), ty_res::ty_args) + with_explanation explanation (fun () -> + unify_exp ~sexp env {texp with exp_type = instance ty_res} + (instance ty_expected)); + (ty_args, ty_res, texp) end in let ty_args0, ty_res = @@ -5699,7 +5876,7 @@ and type_construct env loc lid sarg ty_expected_explained attrs = | _ -> assert false in let texp = {texp with exp_type = ty_res} in - if not separate then unify_exp env texp (instance ty_expected); + if not separate then unify_exp ~sexp env texp (instance ty_expected); let recarg = match constr.cstr_inlined with | None -> Rejected @@ -5712,7 +5889,11 @@ and type_construct env loc lid sarg ty_expected_explained attrs = Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> Required | _ -> +<<<<<<< raise (error(loc, env, Inlined_record_expected)) +======= + raise (Error(sexp.pexp_loc, env, Inlined_record_expected)) +>>>>>>> end in let args = @@ -5721,9 +5902,17 @@ and type_construct env loc lid sarg ty_expected_explained attrs = if constr.cstr_private = Private then begin match constr.cstr_tag with | Cstr_extension _ -> +<<<<<<< raise_error (error(loc, env, Private_constructor (constr, ty_res))) +======= + raise(Error(sexp.pexp_loc, env, Private_constructor (constr, ty_res))) +>>>>>>> | Cstr_constant _ | Cstr_block _ | Cstr_unboxed -> +<<<<<<< raise_error (error(loc, env, Private_type ty_res)); +======= + raise (Error(sexp.pexp_loc, env, Private_type ty_res)); +>>>>>>> end; (* NOTE: shouldn't we call "re" on this final expression? -- AF *) { texp with @@ -5748,6 +5937,7 @@ and type_statement ?explanation env sexp = | _ -> false in (* Raise the current level to detect non-returning functions *) +<<<<<<< let exp = with_local_level (fun () -> type_exp env sexp) in let subexp = final_subexpression exp in let ty = expand_head env exp.exp_type in @@ -5766,6 +5956,26 @@ and type_statement ?explanation env sexp = if not !has_errors then check_partial_application ~statement:true exp; enforce_current_level env ty; exp +======= + with_local_level_generalize (fun () -> type_exp env sexp) + ~before_generalize: begin fun exp -> + let subexp = final_subexpression exp in + let ty = expand_head env exp.exp_type in + if is_Tvar ty + && get_level ty > get_current_level () + && not (allow_polymorphic subexp) then + Location.prerr_warning + subexp.exp_loc + Warnings.Nonreturning_statement; + if !Clflags.strict_sequence then + let expected_ty = instance Predef.type_unit in + with_explanation explanation (fun () -> + unify_exp ~sexp env exp expected_ty) + else begin + check_partial_application ~statement:true exp; + enforce_current_level env ty + end +>>>>>>> end (* Most of the arguments are the same as [type_cases]. @@ -5782,20 +5992,22 @@ and type_statement ?explanation env sexp = *) and map_half_typed_cases : type k ret case_data. - ?additional_checks_for_split_cases:((_ * ret) list -> unit) + ?additional_checks_for_split_cases:((_ * ret) list -> unit) -> ?conts:_ -> k pattern_category -> _ -> _ -> _ -> _ -> (untyped_case * case_data) list -> type_body:( case_data -> k general_pattern (* the typed pattern *) - -> ext_env:_ (* environment with module variables / pattern variables *) + -> when_env:_ (* environment with module/pattern variables *) + -> ext_env:_ (* when_env + continuation var*) + -> cont:_ -> ty_expected:_ (* type to check body in scope of *) -> ty_infer:_ (* type to infer for body *) -> contains_gadt:_ (* whether the pattern contains a GADT *) -> ret) -> check_if_total:bool (* if false, assume Partial right away *) -> ret list * partial - = fun ?additional_checks_for_split_cases + = fun ?additional_checks_for_split_cases ?conts category env ty_arg ty_res loc caselist ~type_body ~check_if_total -> let has_errors = Msupport.monitor_errors () in (* ty_arg is _fully_ generalized *) @@ -5807,7 +6019,7 @@ and map_half_typed_cases let create_inner_level = may_contain_gadts || may_contain_modules in let ty_arg = if (may_contain_gadts || erase_either) && not !Clflags.principal - then correct_levels ty_arg else ty_arg + then duplicate_type ty_arg else ty_arg in let rec is_var spat = match spat.ppat_desc with @@ -5837,24 +6049,29 @@ and map_half_typed_cases if erase_either then Some false else None in + let map_conts f conts caselist = match conts with + | None -> List.map (fun c -> f c None) caselist + | Some conts -> List.map2 f caselist conts + in let half_typed_cases, ty_res, do_copy_types, ty_arg' = (* propagation of the argument *) - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let pattern_force = ref [] in (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) Printtyp.raw_type_expr ty_arg; *) let half_typed_cases = - List.map - (fun ({ Parmatch.pattern; _ } as untyped_case, case_data) -> + map_conts + (fun ({ Parmatch.pattern; _ } as untyped_case, case_data) cont -> let htc = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let ty_arg = (* propagation of pattern *) - with_local_level ~post:generalize_structure + with_local_level_generalize_structure (fun () -> instance ?partial:take_partial_instance ty_arg) in let (pat, ext_env, force, pvs, mvs) = - type_pattern category ~lev env pattern ty_arg allow_modules + type_pattern ?cont category ~lev env pattern ty_arg + allow_modules in pattern_force := force @ !pattern_force; { typed_pat = pat; @@ -5867,9 +6084,6 @@ and map_half_typed_cases contains_gadt = contains_gadt (as_comp_pattern category pat); } end - ~post: begin fun htc -> - iter_pattern_variables_type generalize_structure htc.pat_vars; - end in (* Ensure that no ambivalent pattern type escapes its branch *) check_scope_escape htc.typed_pat.pat_loc env outer_level @@ -5877,7 +6091,7 @@ and map_half_typed_cases let pat = htc.typed_pat in {htc with typed_pat = { pat with pat_type = instance pat.pat_type }} ) - caselist in + conts caselist in let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in let does_contain_gadt = @@ -5885,7 +6099,7 @@ and map_half_typed_cases in let ty_res, do_copy_types = if does_contain_gadt && not !Clflags.principal then - correct_levels ty_res, Env.make_copy_of_types env + duplicate_type ty_res, Env.make_copy_of_types env else ty_res, (fun env -> env) in (* Unify all cases (delayed to keep it order-free) *) @@ -5911,20 +6125,15 @@ and map_half_typed_cases ) half_typed_cases; (half_typed_cases, ty_res, do_copy_types, ty_arg') end - ~post: begin fun (half_typed_cases, _, _, ty_arg') -> - generalize ty_arg'; - List.iter (fun { pat_vars; _ } -> - iter_pattern_variables_type generalize pat_vars - ) half_typed_cases - end in (* type bodies *) let ty_res' = instance ty_res in + (* Why is it needed to keep the level of result raised ? *) let result = with_local_level_if_principal ~post:ignore begin fun () -> - List.map + map_conts (fun { typed_pat = pat; branch_env = ext_env; - pat_vars = pvs; module_vars = mvs; - case_data; contains_gadt; _ } + pat_vars = pvs; module_vars = mvs; + case_data; contains_gadt; _ } cont -> let ext_env = if contains_gadt then @@ -5936,21 +6145,24 @@ and map_half_typed_cases branch environments by adding the variables (and module variables) from the patterns. *) - let ext_env = - add_pattern_variables ext_env pvs + let cont_vars, pvs = + List.partition (fun pv -> pv.pv_kind = Continuation_var) pvs in + let add_pattern_vars = add_pattern_variables ~check:(fun s -> Warnings.Unused_var_strict s) ~check_as:(fun s -> Warnings.Unused_var s) in - let ext_env = add_module_variables ext_env mvs in + let when_env = add_pattern_vars ext_env pvs in + let when_env = add_module_variables when_env mvs in + let ext_env = add_pattern_vars when_env cont_vars in let ty_expected = if contains_gadt && not !Clflags.principal then (* Take a generic copy of [ty_res] again to allow propagation of type information from preceding branches *) - correct_levels ty_res + duplicate_type ty_res else ty_res in - type_body case_data pat ~ext_env ~ty_expected ~ty_infer:ty_res' - ~contains_gadt) - half_typed_cases + type_body case_data pat ~when_env ~ext_env ~cont ~ty_expected + ~ty_infer:ty_res' ~contains_gadt) + conts half_typed_cases end in let do_init = may_contain_gadts || needs_exhaust_check in let ty_arg_check = @@ -6023,11 +6235,11 @@ and map_half_typed_cases (* Typing of match cases *) and type_cases - : type k . k pattern_category -> - _ -> _ -> _ -> check_if_total:bool -> _ -> Parsetree.case list -> - k case list * partial + : type k . k pattern_category -> _ -> _ -> _ -> ?conts:_ -> + check_if_total:bool -> _ -> Parsetree.case list -> + k case list * partial = fun category env - ty_arg ty_res_explained ~check_if_total loc caselist -> + ty_arg ty_res_explained ?conts ~check_if_total loc caselist -> let { ty = ty_res; explanation } = ty_res_explained in let caselist = List.map (fun case -> Parmatch.untyped_case case, case) caselist @@ -6036,16 +6248,24 @@ and type_cases is to typecheck the guards and the cases, and then to check for some warnings that can fire in the presence of guards. *) - map_half_typed_cases category env ty_arg ty_res loc caselist ~check_if_total + map_half_typed_cases ?conts category env ty_arg ty_res loc caselist + ~check_if_total ~type_body:begin - fun { pc_guard; pc_rhs } pat ~ext_env ~ty_expected ~ty_infer - ~contains_gadt:_ -> + fun { pc_guard; pc_rhs } pat ~when_env ~ext_env ~cont ~ty_expected + ~ty_infer ~contains_gadt:_ -> + let cont = Option.map (fun (id,_) -> id) cont in let guard = match pc_guard with | None -> None | Some scond -> + (* It is crucial that the continuation is not used in the + `when' expression as the extent of the continuation is + yet to be determined. We make the continuation + inaccessible by typing the `when' expression using the + environment `ext_env' which does not bind the + continuation variable. *) Some - (type_expect ext_env scond + (type_expect when_env scond (mk_expected ~explanation:When_guard Predef.type_bool)) in let exp = @@ -6053,6 +6273,7 @@ and type_cases in { c_lhs = pat; + c_cont = cont; c_guard = guard; c_rhs = {exp with exp_type = ty_infer} } @@ -6091,6 +6312,33 @@ and type_function_cases_expect cases, partial, ty_fun end +and type_effect_cases + : type k . k pattern_category -> _ -> _ -> _ -> Parsetree.case list -> _ + -> k case list + = fun category env ty_res_explained loc caselist conts -> + let { ty = ty_res; explanation = _ } = ty_res_explained in + let _ = newvar () in + (* remember original level *) + with_local_level begin fun () -> + (* Create a locally type abstract type for effect type. *) + let new_env, ty_arg, ty_cont = + let decl = Ctype.new_local_type ~loc Definition in + let scope = create_scope () in + let name = Ctype.get_new_abstract_name env "%eff" in + let id = Ident.create_scoped ~scope name in + let new_env = Env.add_type ~check:false id decl env in + let ty_eff = newgenty (Tconstr (Path.Pident id,[],ref Mnil)) in + new_env, + Predef.type_eff ty_eff, + Predef.type_continuation ty_eff ty_res + in + let conts = List.map (type_continuation_pat env ty_cont) conts in + let cases, _ = type_cases category new_env ty_arg + ty_res_explained ~conts ~check_if_total:false loc caselist + in + cases + end + (* Typing of let bindings *) and type_let ?check ?check_strict @@ -6099,11 +6347,11 @@ and type_let ?check ?check_strict let attrs_list = List.map fst spatl in let is_recursive = (rec_flag = Recursive) in - let (pat_list, exp_list, new_env, mvs, _pvs) = - with_local_level begin fun () -> + let (pat_list, exp_list, new_env, mvs) = + with_local_level_generalize begin fun () -> if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); let (pat_list, new_env, force, pvs, mvs) = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let nvs = List.map (fun _ -> newvar ()) spatl in let (pat_list, _new_env, _force, _pvs, _mvs as res) = type_pattern_list @@ -6133,11 +6381,6 @@ and type_let ?check ?check_strict pat_list; res end - ~post: begin fun (pat_list, _, _, pvs, _) -> - (* Generalize the structure *) - iter_pattern_variables_type generalize_structure pvs; - List.iter (fun pat -> generalize_structure pat.pat_type) pat_list - end in (* Note [add_module_variables after checking expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -6174,8 +6417,7 @@ and type_let ?check ?check_strict match get_desc pat.pat_type with | Tpoly (ty, tl) -> let vars, ty' = - with_local_level_if_principal - ~post:(fun (_,ty') -> generalize_structure ty') + with_local_level_generalize_structure_if_principal (fun () -> instance_poly ~keep_names:true ~fixed:true tl ty) in let exp = @@ -6201,37 +6443,21 @@ and type_let ?check ?check_strict ) pat_list (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list); - (pat_list, exp_list, new_env, mvs, - List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs) + (pat_list, exp_list, new_env, mvs) end - ~post: begin fun (pat_list, exp_list, _, _, pvs) -> - List.iter2 - (fun pat (exp, _) -> - if maybe_expansive exp then lower_contravariant env pat.pat_type) - pat_list exp_list; - iter_pattern_variables_type generalize pvs; - List.iter2 - (fun pat (exp, vars) -> - match vars with - | None -> - (* We generalize expressions even if they are not bound to a variable - and do not have an expliclit polymorphic type annotation. This is - not needed in general, however those types may be shown by the - interactive toplevel, for example: - {[ - let _ = Array.get;; - - : 'a array -> int -> 'a = - ]} - so we do it anyway. *) - generalize exp.exp_type - | Some vars -> - if maybe_expansive exp then - lower_contravariant env exp.exp_type; - generalize_and_check_univars env "definition" - exp pat.pat_type vars) + ~before_generalize: begin fun (pat_list, exp_list, _, _) -> + List.iter2 (fun pat (exp, vars) -> + if maybe_expansive exp then begin + lower_contravariant env pat.pat_type; + if vars <> None then lower_contravariant env exp.exp_type + end) pat_list exp_list end in + List.iter2 + (fun pat (exp, vars) -> + Option.iter (check_univars env "definition" exp pat.pat_type) vars) + pat_list exp_list; let l = List.combine pat_list exp_list in let l = List.map2 @@ -6386,7 +6612,7 @@ and type_andops env sarg sands expected_ty = | [] -> type_expect env let_sarg (mk_expected expected_ty), [] | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest -> let op_path, op_desc, op_type, ty_arg, ty_rest, ty_result = - with_local_level_iter_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let op_path, op_desc = type_binding_op_ident env sop in let op_type = instance op_desc.val_type in let ty_arg = newvar () in @@ -6401,10 +6627,8 @@ and type_andops env sarg sands expected_ty = with Unify err -> raise(error(sop.loc, env, Andop_type_clash(sop.txt, err))) end; - ((op_path, op_desc, op_type, ty_arg, ty_rest, ty_result), - [ty_rest; ty_arg; ty_result]) + (op_path, op_desc, op_type, ty_arg, ty_rest, ty_result) end - ~post:generalize_structure in let let_arg, rest = loop env let_sarg rest ty_rest in let exp = type_expect env sexp (mk_expected ty_arg) in @@ -6530,11 +6754,11 @@ let type_let existential_ctx env rec_flag spat_sexp_list = let type_expression env sexp = let exp = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> Typetexp.TyVarEnv.reset(); type_exp env sexp end - ~post:(may_lower_contravariant_then_generalize env) + ~before_generalize:(may_lower_contravariant env) in match sexp.pexp_desc with Pexp_ident lid -> @@ -6554,7 +6778,9 @@ let spellcheck ppf unbound_name valid_names = let spellcheck_idents ppf unbound valid_idents = spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) -open Format +open Format_doc +module Fmt = Format_doc +module Printtyp = Printtyp.Doc let longident = Printtyp.longident @@ -6565,11 +6791,49 @@ let type_clash_of_trace trace = | _ -> None )) +(** More precise denomination for type errors. Used by messages: + + - [This ...] + - [The "foo" ...] *) +let pp_exp_denom ppf pexp = + let d = pp_print_string ppf in + let d_expression = fprintf ppf "%a expression" Style.inline_code in + match pexp.pexp_desc with + | Pexp_constant _ -> d "constant" + | Pexp_ident _ -> d "value" + | Pexp_construct _ | Pexp_variant _ -> d "constructor" + | Pexp_field _ -> d "field access" + | Pexp_send _ -> d "method call" + | Pexp_while _ -> d_expression "while" + | Pexp_for _ -> d_expression "for" + | Pexp_ifthenelse _ -> d_expression "if-then-else" + | Pexp_match _ -> d_expression "match" + | Pexp_try _ -> d_expression "try-with" + | _ -> d "expression" + +(** Implements the "This expression" message, printing the expression if it + should be according to {!Parsetree.Doc.nominal_exp}. *) +let report_this_pexp_has_type denom ppf exp = + let denom ppf = + match denom, exp with + | Some d, _ -> fprintf ppf "%s" d + | None, Some exp -> pp_exp_denom ppf exp + | None, None -> fprintf ppf "expression" + in + let nexp = Option.bind exp Pprintast.Doc.nominal_exp in + match nexp with + | Some nexp -> + fprintf ppf "The %t %a has type" denom (Style.as_inline_code pp_doc) nexp + | _ -> fprintf ppf "This %t has type" denom + +let report_this_texp_has_type denom ppf texp = + report_this_pexp_has_type denom ppf (Some (Untypeast.untype_expression texp)) + (* Hint on type error on integer literals To avoid confusion, it is disabled on float literals and when the expected type is `int` *) let report_literal_type_constraint expected_type const = - let const_str = match const with + let const_str = match const.pconst_desc with | Pconst_integer (s, _) -> Some s | _ -> None in @@ -6584,7 +6848,7 @@ let report_literal_type_constraint expected_type const = Some '.' else None in - let pp_const ppf (c,s) = Format.fprintf ppf "%s%c" c s in + let pp_const ppf (c,s) = Fmt.fprintf ppf "%s%c" c s in match const_str, suffix with | Some c, Some s -> [ Location.msg @@ -6615,17 +6879,21 @@ let report_partial_application = function let report_expr_type_clash_hints exp diff = match exp with - | Some (Pexp_constant const) -> report_literal_type_constraint const diff - | Some (Pexp_apply _) -> report_partial_application diff - | _ -> [] + | Some exp -> begin + match exp.pexp_desc with + | Pexp_constant const -> report_literal_type_constraint const diff + | Pexp_apply _ -> report_partial_application diff + | _ -> [] + end + | None -> [] let report_pattern_type_clash_hints pat diff = match pat with | Some (Ppat_constant const) -> report_literal_type_constraint const diff | _ -> [] -let report_type_expected_explanation expl ppf = - let because expl_str = fprintf ppf "@ because it is in %s" expl_str in +let report_type_expected_explanation expl = + let because expl_str = doc_printf "@ because it is in %s" expl_str in match expl with | If_conditional -> because "the condition of an if-statement" @@ -6648,25 +6916,18 @@ let report_type_expected_explanation expl ppf = | When_guard -> because "a when-guard" -let report_type_expected_explanation_opt expl ppf = +let report_type_expected_explanation_opt expl = match expl with - | None -> () - | Some expl -> report_type_expected_explanation expl ppf + | None -> Format_doc.Doc.empty + | Some expl -> report_type_expected_explanation expl let report_unification_error ~loc ?sub env err ?type_expected_explanation txt1 txt2 = Location.error_of_printer ~loc ?sub (fun ppf () -> - Printtyp.report_unification_error ppf env err + Errortrace_report.unification ppf env err ?type_expected_explanation txt1 txt2 ) () -let report_this_function ppf funct = - if Typedtree.exp_is_nominal funct then - let pexp = Untypeast.untype_expression funct in - Format.fprintf ppf "The function %a" - (Style.as_inline_code Pprintast.expression) pexp - else Format.fprintf ppf "This function" - let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc ~extra_arg_loc ~returns_unit loc = let open Location in @@ -6693,9 +6954,12 @@ let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc msg ~loc:extra_arg_loc "This extra argument is not expected."; ] in errorf ~loc:app_loc ~sub - "@[@[<2>%a has type@ %a@]\ + "@[@[<2>%a@ %a@]\ @ It is applied to too many arguments@]" - report_this_function funct Printtyp.type_expr func_ty + (report_this_texp_has_type (Some "function")) funct + Printtyp.type_expr func_ty + +let msg = Fmt.doc_printf let report_error ~loc env = function | Constructor_arity_mismatch(lid, expected, provided) -> @@ -6705,27 +6969,20 @@ let report_error ~loc env = function (Style.as_inline_code longident) lid expected provided | Label_mismatch(lid, err) -> report_unification_error ~loc env err - (function ppf -> - fprintf ppf "The record field %a@ belongs to the type" + (msg "The record field %a@ belongs to the type" (Style.as_inline_code longident) lid) - (function ppf -> - fprintf ppf "but is mixed here with fields of type") + (msg "but is mixed here with fields of type") | Pattern_type_clash (err, pat) -> let diff = type_clash_of_trace err.trace in let sub = report_pattern_type_clash_hints pat diff in report_unification_error ~loc ~sub env err - (function ppf -> - fprintf ppf "This pattern matches values of type") - (function ppf -> - fprintf ppf "but a pattern was expected which matches values of \ - type"); + (msg "This pattern matches values of type") + (msg "but a pattern was expected which matches values of type"); | Or_pattern_type_clash (id, err) -> report_unification_error ~loc env err - (function ppf -> - fprintf ppf "The variable %a on the left-hand side of this \ + (msg "The variable %a on the left-hand side of this \ or-pattern has type" Style.inline_code (Ident.name id)) - (function ppf -> - fprintf ppf "but on the right-hand side it has type") + (msg "but on the right-hand side it has type") | Multiply_bound_variable name -> Location.errorf ~loc "Variable %a is bound several times in this matching" @@ -6745,10 +7002,8 @@ let report_error ~loc env = function report_unification_error ~loc ~sub env err ~type_expected_explanation: (report_type_expected_explanation_opt explanation) - (function ppf -> - fprintf ppf "This expression has type") - (function ppf -> - fprintf ppf "but an expression was expected of type"); + (msg "%a" (report_this_pexp_has_type None) exp) + (msg "but an expression was expected of type"); | Function_arity_type_clash { syntactic_arity; type_constraint; trace = { trace }; } -> @@ -6847,10 +7102,10 @@ let report_error ~loc env = function (Style.as_inline_code Printtyp.type_path) type_path; end else begin fprintf ppf - "@[@[<2>%s type@ %a%t@]@ \ + "@[@[<2>%s type@ %a%a@]@ \ There is no %s %a within type %a@]" eorp (Style.as_inline_code Printtyp.type_expr) ty - (report_type_expected_explanation_opt explanation) + pp_doc (report_type_expected_explanation_opt explanation) (Datatype_kind.label_name kind) Style.inline_code name.txt (Style.as_inline_code Printtyp.type_path) type_path; @@ -6861,18 +7116,15 @@ let report_error ~loc env = function let type_name = Datatype_kind.type_name kind in let name = Datatype_kind.label_name kind in Location.error_of_printer ~loc (fun ppf () -> - Printtyp.report_ambiguous_type_error ppf env tp tpl - (function ppf -> - fprintf ppf "The %s %a@ belongs to the %s type" + Errortrace_report.ambiguous_type ppf env tp tpl + (msg "The %s %a@ belongs to the %s type" name (Style.as_inline_code longident) lid type_name) - (function ppf -> - fprintf ppf "The %s %a@ belongs to one of the following %s types:" + (msg "The %s %a@ belongs to one of the following %s types:" name (Style.as_inline_code longident) lid type_name) - (function ppf -> - fprintf ppf "but a %s was expected belonging to the %s type" + (msg "but a %s was expected belonging to the %s type" name type_name) - ) () + ) () | Invalid_format msg -> Location.errorf ~loc "%s" msg | Not_an_object (ty, explanation) -> @@ -6880,7 +7132,7 @@ let report_error ~loc env = function fprintf ppf "This expression is not an object;@ \ it has type %a" (Style.as_inline_code Printtyp.type_expr) ty; - report_type_expected_explanation_opt explanation ppf + pp_doc ppf @@ report_type_expected_explanation_opt explanation ) () | Undefined_method (ty, me, valid_methods) -> Location.error_of_printer ~loc (fun ppf () -> @@ -6913,7 +7165,7 @@ let report_error ~loc env = function Style.inline_code v | Not_subtype err -> Location.error_of_printer ~loc (fun ppf () -> - Printtyp.Subtype.report_error ppf env err "is not a subtype of" + Errortrace_report.subtype ppf env err "is not a subtype of" ) () | Outside_class -> Location.errorf ~loc @@ -6924,14 +7176,15 @@ let report_error ~loc env = function Style.inline_code v | Coercion_failure (ty_exp, err, b) -> Location.error_of_printer ~loc (fun ppf () -> - Printtyp.report_unification_error ppf env err - (function ppf -> - let ty_exp = Printtyp.prepare_expansion ty_exp in - fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ - it has type" - (Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp) - (function ppf -> - fprintf ppf "but is here used with type"); + let intro = + let ty_exp = Out_type.prepare_expansion ty_exp in + doc_printf "This expression cannot be coerced to type@;<1 2>%a;@ \ + it has type" + (Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp + in + Errortrace_report.unification ppf env err + intro + (Fmt.doc_printf "but is here used with type"); if b then fprintf ppf ".@.@[This simple coercion was not fully general.@ \ @@ -6942,15 +7195,15 @@ let report_error ~loc env = function | Not_a_function (ty, explanation) -> Location.errorf ~loc "This expression should not be a function,@ \ - the expected type is@ %a%t" + the expected type is@ %a%a" (Style.as_inline_code Printtyp.type_expr) ty - (report_type_expected_explanation_opt explanation) + pp_doc (report_type_expected_explanation_opt explanation) | Too_many_arguments (ty, explanation) -> Location.errorf ~loc "This function expects too many arguments,@ \ - it should have type@ %a%t" + it should have type@ %a%a" (Style.as_inline_code Printtyp.type_expr) ty - (report_type_expected_explanation_opt explanation) + pp_doc (report_type_expected_explanation_opt explanation) | Abstract_wrong_label {got; expected; expected_type; explanation} -> let label ~long ppf = function | Nolabel -> fprintf ppf "unlabeled" @@ -6965,10 +7218,10 @@ let report_error ~loc env = function | _ -> false in Location.errorf ~loc - "@[@[<2>This function should have type@ %a%t@]@,\ + "@[@[<2>This function should have type@ %a%a@]@,\ @[but its first argument is %a@ instead of %s%a@]@]" (Style.as_inline_code Printtyp.type_expr) expected_type - (report_type_expected_explanation_opt explanation) + pp_doc (report_type_expected_explanation_opt explanation) (label ~long:true) got (if second_long then "being " else "") (label ~long:second_long) expected @@ -7001,8 +7254,8 @@ let report_error ~loc env = function This is only allowed when the real type is known." | Less_general (kind, err) -> report_unification_error ~loc env err - (fun ppf -> fprintf ppf "This %s has type" kind) - (fun ppf -> fprintf ppf "which is less general than") + (Fmt.doc_printf "This %s has type" kind) + (Fmt.doc_printf "which is less general than") | Modules_not_allowed -> Location.errorf ~loc "Modules are not allowed in this pattern." | Cannot_infer_signature -> @@ -7054,6 +7307,12 @@ let report_error ~loc env = function Location.errorf ~loc "@[Mixing value and exception patterns under when-guards is not \ supported.@]" + | Effect_pattern_below_toplevel -> + Location.errorf ~loc + "@[Effect patterns must be at the top level of a match case.@]" + | Invalid_continuation_pattern -> + Location.errorf ~loc + "@[Invalid continuation pattern: only variables and _ are allowed .@]" | Inlined_record_escape -> Location.errorf ~loc "@[This form is not allowed as the type of the inlined record could \ @@ -7066,7 +7325,7 @@ let report_error ~loc env = function "@[%s@ %s@ @[%a@]@]" "This match case could not be refuted." "Here is an example of a value that would reach it:" - (Style.as_inline_code Printpat.pretty_val) pat + (Style.as_inline_code Printpat.top_pretty) pat | Invalid_extension_constructor_payload -> Location.errorf ~loc "Invalid %a payload, a constructor is expected." @@ -7096,22 +7355,16 @@ let report_error ~loc env = function "This kind of recursive class expression is not allowed" | Letop_type_clash(name, err) -> report_unification_error ~loc env err - (function ppf -> - fprintf ppf "The operator %a has type" Style.inline_code name) - (function ppf -> - fprintf ppf "but it was expected to have type") + (msg "The operator %a has type" Style.inline_code name) + (msg "but it was expected to have type") | Andop_type_clash(name, err) -> report_unification_error ~loc env err - (function ppf -> - fprintf ppf "The operator %a has type" Style.inline_code name) - (function ppf -> - fprintf ppf "but it was expected to have type") + (msg "The operator %a has type" Style.inline_code name) + (msg "but it was expected to have type") | Bindings_type_clash(err) -> report_unification_error ~loc env err - (function ppf -> - fprintf ppf "These bindings have type") - (function ppf -> - fprintf ppf "but bindings were expected of type") + (Fmt.doc_printf "These bindings have type") + (Fmt.doc_printf "but bindings were expected of type") | Unbound_existential (ids, ty) -> let pp_ident ppf id = pp_print_string ppf (Ident.name id) in let pp_type ppf (ids,ty)= @@ -7123,6 +7376,20 @@ let report_error ~loc env = function "@[<2>%s:@ %a@]" "This type does not bind all existentials in the constructor" (Style.as_inline_code pp_type) (ids, ty) + | Bind_existential (reason, id, ty) -> + let reason1, reason2 = match reason with + | Bind_already_bound -> "the name", "that is already bound" + | Bind_not_in_scope -> "the name", "that was defined before" + | Bind_non_locally_abstract -> "the type", + "that is not a locally abstract type" + in + Location.errorf ~loc + "@[The local name@ %a@ %s@ %s.@ %s@ %s@ %a@ %s.@]" + (Style.as_inline_code Printtyp.ident) id + "can only be given to an existential variable" + "introduced by this GADT constructor" + "The type annotation tries to bind it to" + reason1 (Style.as_inline_code Printtyp.type_expr) ty reason2 | Missing_type_constraint -> Location.errorf ~loc "@[%s@ %s@]" @@ -7144,9 +7411,9 @@ let report_error ~loc env = function in Location.errorf ~loc "This %s should not be a %s,@ \ - the expected type is@ %a%t" + the expected type is@ %a%a" ctx sort (Style.as_inline_code Printtyp.type_expr) ty - (report_type_expected_explanation_opt explanation) + pp_doc (report_type_expected_explanation_opt explanation) | Expr_not_a_record_type ty -> Location.errorf ~loc "This expression has type %a@ \ diff --git a/src/ocaml/typing/typecore.mli b/src/ocaml/typing/typecore.mli index ae47ac4a8..caca733b4 100644 --- a/src/ocaml/typing/typecore.mli +++ b/src/ocaml/typing/typecore.mli @@ -49,12 +49,17 @@ type type_expected = private { } (* Variables in patterns *) +type pattern_variable_kind = + | Std_var + | As_var + | Continuation_var + type pattern_variable = { pv_id: Ident.t; pv_type: type_expr; pv_loc: Location.t; - pv_as_var: bool; + pv_kind: pattern_variable_kind; pv_attributes: Typedtree.attributes; pv_uid : Uid.t; } @@ -134,9 +139,12 @@ val option_some: Env.t -> Typedtree.expression -> Typedtree.expression val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression val extract_option_type: Env.t -> type_expr -> type_expr val generalizable: int -> type_expr -> bool +<<<<<<< val generalize_structure_exp: Typedtree.expression -> unit type delayed_check val delayed_checks: delayed_check list ref +======= +>>>>>>> val reset_delayed_checks: unit -> unit val force_delayed_checks: unit -> unit @@ -145,6 +153,11 @@ val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t val self_coercion : (Path.t * Location.t list ref) list ref +type existential_binding = + | Bind_already_bound + | Bind_not_in_scope + | Bind_non_locally_abstract + type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * Errortrace.unification_error @@ -156,7 +169,7 @@ type error = | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of Errortrace.unification_error * type_forcing_context option - * Parsetree.expression_desc option + * Parsetree.expression option | Function_arity_type_clash of { syntactic_arity : int; type_constraint : type_expr; @@ -212,6 +225,8 @@ type error = | No_value_clauses | Exception_pattern_disallowed | Mixed_value_and_exception_patterns_under_guard + | Effect_pattern_below_toplevel + | Invalid_continuation_pattern | Inlined_record_escape | Inlined_record_expected | Unrefuted_pattern of Typedtree.pattern @@ -226,6 +241,7 @@ type error = | Andop_type_clash of string * Errortrace.unification_error | Bindings_type_clash of Errortrace.unification_error | Unbound_existential of Ident.t list * type_expr + | Bind_existential of existential_binding * Ident.t * type_expr | Missing_type_constraint | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr | Expr_not_a_record_type of type_expr diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index 626cd35fb..1c9df8b95 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -234,7 +234,7 @@ let transl_labels env univars closed lbls = let cty = transl_simple_type env ?univars ~closed arg in {ld_id = Ident.create_local name.txt; ld_name = name; - ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + ld_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); ld_mutable = mut; ld_type = cty; ld_loc = loc; ld_attributes = attrs} ) @@ -279,8 +279,8 @@ let make_constructor env loc type_path type_params svars sargs sret_type = (* narrow and widen are now invoked through wrap_type_variable_scope *) TyVarEnv.with_local_scope begin fun () -> let closed = svars <> [] in - let targs, tret_type, args, ret_type, _univars = - Ctype.with_local_level_if closed begin fun () -> + let targs, tret_type, args, ret_type, univars = + Ctype.with_local_level_generalize_if closed begin fun () -> TyVarEnv.reset (); let univar_list = TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) svars) in @@ -309,15 +309,13 @@ let make_constructor env loc type_path type_params svars sargs sret_type = end; (targs, tret_type, args, ret_type, univar_list) end - ~post: begin fun (_, _, args, ret_type, univars) -> - Btype.iter_type_expr_cstr_args Ctype.generalize args; - Ctype.generalize ret_type; - let _vars = TyVarEnv.instance_poly_univars env loc univars in - let set_level t = Ctype.enforce_current_level env t in - Btype.iter_type_expr_cstr_args set_level args; - set_level ret_type; - end in + if closed then begin + ignore (TyVarEnv.instance_poly_univars env loc univars); + let set_level t = Ctype.enforce_current_level env t in + Btype.iter_type_expr_cstr_args set_level args; + set_level ret_type + end; targs, Some tret_type, args, Some ret_type end @@ -344,7 +342,6 @@ let shape_map_cstrs = let transl_declaration env sdecl (id, uid) = (* Bind type parameters *) - Ctype.with_local_level begin fun () -> TyVarEnv.reset(); let tparams = make_params env sdecl.ptype_params in let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in @@ -428,7 +425,7 @@ let transl_declaration env sdecl (id, uid) = let tcstr = { cd_id = name; cd_name = scstr.pcd_name; - cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + cd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); cd_vars = scstr.pcd_vars; cd_args = targs; cd_res = tret_type; @@ -463,6 +460,7 @@ let transl_declaration env sdecl (id, uid) = Ttype_record lbls, Type_record(lbls', rep) | Ptype_open -> Ttype_open, Type_open in + begin let (tman, man) = match sdecl.ptype_manifest with None -> None, None | Some sty -> @@ -529,16 +527,6 @@ let transl_declaration env sdecl (id, uid) = decl, typ_shape end -(* Generalize a type declaration *) - -let generalize_decl decl = - List.iter Ctype.generalize decl.type_params; - Btype.iter_type_expr_kind Ctype.generalize decl.type_kind; - begin match decl.type_manifest with - | None -> () - | Some ty -> Ctype.generalize ty - end - (* Check that all constraints are enforced *) module TypeSet = Btype.TypeSet @@ -906,11 +894,8 @@ let check_well_founded_decl ~abs_env env loc path decl to_check = let open Btype in (* We iterate on all subexpressions of the declaration to check "in depth" that no ill-founded type exists. *) - let it = - let checked = - (* [checked] remembers the types that the iterator already - checked, to avoid looping on cyclic types. *) - ref TypeSet.empty in + with_type_mark begin fun mark -> + let super = type_iterators mark in let visited = (* [visited] remembers the inner visits performed by [check_well_founded] on each type expression reachable from @@ -918,14 +903,14 @@ let check_well_founded_decl ~abs_env env loc path decl to_check = [check_well_founded] work when invoked on two parts of the type declaration that have common subexpressions. *) ref TypeMap.empty in - {type_iterators with it_type_expr = - (fun self ty -> - if TypeSet.mem ty !checked then () else begin - check_well_founded ~abs_env env loc path to_check visited ty; - checked := TypeSet.add ty !checked; - self.it_do_type_expr self ty - end)} in - it.it_type_declaration it (Ctype.generic_instance_declaration decl) + let it = + {super with it_do_type_expr = + (fun self ty -> + check_well_founded ~abs_env env loc path to_check visited ty; + super.it_do_type_expr self ty + )} in + it.it_type_declaration it (Ctype.generic_instance_declaration decl) + end (* Check for non-regular abbreviations; an abbreviation [type 'a t = ...] is non-regular if the expansion of [...] @@ -1046,10 +1031,10 @@ let name_recursion sdecl id decl = | { type_kind = Type_abstract _; type_manifest = Some ty; type_private = Private; } when is_fixed_type sdecl -> - let ty' = newty2 ~level:(get_level ty) (get_desc ty) in + let ty' = Btype.newty2 ~level:(get_level ty) (get_desc ty) in if Ctype.deep_occur ty ty' then let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in - link_type ty (newty2 ~level:(get_level ty) td); + link_type ty (Btype.newty2 ~level:(get_level ty) td); {decl with type_manifest = Some ty'} else decl | _ -> decl @@ -1104,14 +1089,14 @@ let transl_type_decl env rec_flag sdecl_list = let ids_list = List.map (fun sdecl -> Ident.create_scoped ~scope sdecl.ptype_name.txt, - Uid.mk ~current_unit:(Env.get_unit_name ()) + Uid.mk ~current_unit:(Env.get_current_unit ()) ) sdecl_list in (* Translate declarations, using a temporary environment where abbreviations expand to a generic type variable. After that, we check the coherence of the translated declarations in the resulting new environment. *) let tdecls, decls, shapes, new_env = - Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> + Ctype.with_local_level_generalize begin fun () -> (* Enter types. *) let temp_env = List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in @@ -1157,7 +1142,7 @@ let transl_type_decl env rec_flag sdecl_list = check_duplicates sdecl_list; (* Build the final env. *) let new_env = add_types_to_env decls shapes env in - ((tdecls, decls, shapes, new_env), List.map snd decls) + (tdecls, decls, shapes, new_env) end in (* Check for ill-formed abbrevs *) @@ -1335,7 +1320,7 @@ let transl_extension_constructor ~scope env type_path type_params ext_private = priv; Types.ext_loc = sext.pext_loc; Types.ext_attributes = sext.pext_attributes; - ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + ext_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in let ext_cstrs = @@ -1415,7 +1400,7 @@ let transl_type_extension extend env loc styext = (* Note: it would be incorrect to call [create_scope] *after* [TyVarEnv.reset] or after [with_local_level] (see #10010). *) let scope = Ctype.create_scope () in - Ctype.with_local_level begin fun () -> + Ctype.with_local_level_generalize begin fun () -> TyVarEnv.reset(); let ttype_params = make_params env styext.ptyext_params in let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in @@ -1429,15 +1414,6 @@ let transl_type_extension extend env loc styext = in (ttype_params, type_params, constructors) end - ~post: begin fun (_, type_params, constructors) -> - (* Generalize types *) - List.iter Ctype.generalize type_params; - List.iter - (fun (ext, _shape) -> - Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; - Option.iter Ctype.generalize ext.ext_type.ext_ret_type) - constructors; - end in (* Check that all type variables are closed *) List.iter @@ -1487,15 +1463,11 @@ let transl_type_extension extend env loc styext = let transl_exception env sext = let ext, shape = let scope = Ctype.create_scope () in - Ctype.with_local_level + Ctype.with_local_level_generalize (fun () -> TyVarEnv.reset(); transl_extension_constructor ~scope env Predef.path_exn [] [] Asttypes.Public sext) - ~post: begin fun (ext, _shape) -> - Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; - Option.iter Ctype.generalize ext.ext_type.ext_ret_type; - end in (* Check that all type variables are closed *) begin match Ctype.closed_extension_constructor ext.ext_type with @@ -1635,7 +1607,7 @@ let transl_value_decl env loc valdecl = [] when Env.is_in_signature env -> { val_type = ty; val_kind = Val_reg; Types.val_loc = loc; val_attributes = valdecl.pval_attributes; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } | [] -> raise (Error(valdecl.pval_loc, Val_in_structure)) @@ -1667,7 +1639,7 @@ let transl_value_decl env loc valdecl = check_unboxable env loc ty; { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc; val_attributes = valdecl.pval_attributes; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in let (id, newenv) = @@ -1705,7 +1677,7 @@ let transl_value_decl env loc valdecl = let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env sdecl = Env.mark_type_used sig_decl.type_uid; - Ctype.with_local_level begin fun () -> + Ctype.with_local_level_generalize begin fun () -> TyVarEnv.reset(); (* In the first part of this function, we typecheck the syntactic declaration [sdecl] in the outer environment [outer_env]. *) @@ -1783,7 +1755,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env type_attributes = sdecl.ptype_attributes; type_immediate = Unknown; type_unboxed_default; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in Option.iter (fun p -> set_private_row env sdecl.ptype_loc p new_sig_decl) @@ -1840,7 +1812,6 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env typ_attributes = sdecl.ptype_attributes; } end - ~post:(fun ttyp -> generalize_decl ttyp.typ_type) (* A simplified version of [transl_with_constraint], for the case of packages. Package constraints are much simpler than normal with type constraints (e.g., @@ -1860,7 +1831,7 @@ let transl_package_constraint ~loc env ty = type_attributes = []; type_immediate = Unknown; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } in let new_type_immediate = @@ -1874,7 +1845,7 @@ let transl_package_constraint ~loc env ty = let abstract_type_decl ~injective arity = let rec make_params n = if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in - Ctype.with_local_level ~post:generalize_decl begin fun () -> + Ctype.with_local_level_generalize begin fun () -> { type_params = make_params arity; type_arity = arity; type_kind = Type_abstract Definition; @@ -1917,26 +1888,31 @@ let check_recmod_typedecl env loc recmod_ids path decl = (**** Error report ****) -open Format +open Format_doc module Style = Misc.Style +module Printtyp = Printtyp.Doc let explain_unbound_gen ppf tv tl typ kwd pr = try let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in let ty0 = (* Hack to force aliasing when needed *) Btype.newgenty (Tobject(tv, ref None)) in - Printtyp.prepare_for_printing [typ ti; ty0]; + Out_type.prepare_for_printing [typ ti; ty0]; fprintf ppf ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" kwd (Style.as_inline_code pr) ti +<<<<<<< (Style.as_inline_code Printtyp.prepared_type_expr) tv (* kwd pr ti Printtyp.prepared_type_expr tv *) +======= + (Style.as_inline_code Out_type.prepared_type_expr) tv +>>>>>>> with Not_found -> () let explain_unbound ppf tv tl typ kwd lab = explain_unbound_gen ppf tv tl typ kwd (fun ppf ti -> - fprintf ppf "%s%a" (lab ti) Printtyp.prepared_type_expr (typ ti) + fprintf ppf "%s%a" (lab ti) Out_type.prepared_type_expr (typ ti) ) let explain_unbound_single ppf tv ty = @@ -1978,7 +1954,7 @@ module Reaching_path = struct | [] -> [] in simplify path - (* See Printtyp.add_type_to_preparation. + (* See Out_type.add_type_to_preparation. Note: it is better to call this after [simplify], otherwise some type variable names may be used for types that are removed @@ -1987,29 +1963,32 @@ module Reaching_path = struct let add_to_preparation path = List.iter (function | Contains (ty1, ty2) | Expands_to (ty1, ty2) -> - List.iter Printtyp.add_type_to_preparation [ty1; ty2] + List.iter Out_type.add_type_to_preparation [ty1; ty2] ) path + module Fmt = Format_doc + let pp ppf reaching_path = let pp_step ppf = function | Expands_to (ty, body) -> - Format.fprintf ppf "%a = %a" - (Style.as_inline_code Printtyp.prepared_type_expr) ty - (Style.as_inline_code Printtyp.prepared_type_expr) body + Fmt.fprintf ppf "%a = %a" + (Style.as_inline_code Out_type.prepared_type_expr) ty + (Style.as_inline_code Out_type.prepared_type_expr) body | Contains (outer, inner) -> - Format.fprintf ppf "%a contains %a" - (Style.as_inline_code Printtyp.prepared_type_expr) outer - (Style.as_inline_code Printtyp.prepared_type_expr) inner + Fmt.fprintf ppf "%a contains %a" + (Style.as_inline_code Out_type.prepared_type_expr) outer + (Style.as_inline_code Out_type.prepared_type_expr) inner in - let comma ppf () = Format.fprintf ppf ",@ " in - Format.(pp_print_list ~pp_sep:comma pp_step) ppf reaching_path + Fmt.(pp_print_list ~pp_sep:comma) pp_step ppf reaching_path let pp_colon ppf path = - Format.fprintf ppf ":@;<1 2>@[%a@]" - pp path + Fmt.fprintf ppf ":@;<1 2>@[%a@]" pp path end -let report_error ppf = function +let quoted_out_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty +let quoted_type ppf ty = Style.as_inline_code Printtyp.type_expr ppf ty + +let report_error_doc ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" | Duplicate_constructor s -> @@ -2023,7 +2002,7 @@ let report_error ppf = function | Recursive_abbrev (s, env, reaching_path) -> let reaching_path = Reaching_path.simplify reaching_path in Printtyp.wrap_printing_env ~error:true env @@ fun () -> - Printtyp.reset (); + Out_type.reset (); Reaching_path.add_to_preparation reaching_path; fprintf ppf "@[The type abbreviation %a is cyclic%a@]" Style.inline_code s @@ -2031,7 +2010,7 @@ let report_error ppf = function | Cycle_in_def (s, env, reaching_path) -> let reaching_path = Reaching_path.simplify reaching_path in Printtyp.wrap_printing_env ~error:true env @@ fun () -> - Printtyp.reset (); + Out_type.reset (); Reaching_path.add_to_preparation reaching_path; fprintf ppf "@[The definition of %a contains a cycle%a@]" Style.inline_code s @@ -2039,24 +2018,24 @@ let report_error ppf = function | Definition_mismatch (ty, _env, None) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" "This variant or record definition" "does not match that of type" - (Style.as_inline_code Printtyp.type_expr) ty + quoted_type ty | Definition_mismatch (ty, env, Some err) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" "This variant or record definition" "does not match that of type" - (Style.as_inline_code Printtyp.type_expr) ty + quoted_type ty (Includecore.report_type_mismatch "the original" "this" "definition" env) err | Constraint_failed (env, err) -> + let msg = Format_doc.Doc.msg in fprintf ppf "@[Constraints are not satisfied in this type.@ "; - Printtyp.report_unification_error ppf env err - (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "should be an instance of"); + Errortrace_report.unification ppf env err + (msg "Type") + (msg "should be an instance of"); fprintf ppf "@]" | Non_regular { definition; used_as; defined_as; reaching_path } -> let reaching_path = Reaching_path.simplify reaching_path in - let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in - Printtyp.prepare_for_printing [used_as; defined_as]; + Out_type.prepare_for_printing [used_as; defined_as]; Reaching_path.add_to_preparation reaching_path; fprintf ppf "@[This recursive type is not regular.@ \ @@ -2065,8 +2044,8 @@ let report_error ppf = function All uses need to match the definition for the recursive type \ to be regular.@]" Style.inline_code (Path.name definition) - pp_type (Printtyp.tree_of_typexp Type defined_as) - pp_type (Printtyp.tree_of_typexp Type used_as) + quoted_out_type (Out_type.tree_of_typexp Type defined_as) + quoted_out_type (Out_type.tree_of_typexp Type used_as) (fun pp -> let is_expansion = function Expands_to _ -> true | _ -> false in if List.exists is_expansion reaching_path then @@ -2074,17 +2053,17 @@ let report_error ppf = function Reaching_path.pp_colon reaching_path else fprintf pp ".@ ") | Inconsistent_constraint (env, err) -> + let msg = Format_doc.Doc.msg in fprintf ppf "@[The type constraints are not consistent.@ "; - Printtyp.report_unification_error ppf env err - (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type"); + Errortrace_report.unification ppf env err + (msg "Type") + (msg "is not compatible with type"); fprintf ppf "@]" | Type_clash (env, err) -> - Printtyp.report_unification_error ppf env err - (function ppf -> - fprintf ppf "This type constructor expands to type") - (function ppf -> - fprintf ppf "but is used here with type") + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf env err + (msg "This type constructor expands to type") + (msg "but is used here with type") | Null_arity_external -> fprintf ppf "External identifiers must be functions" | Missing_native_external -> @@ -2133,12 +2112,11 @@ let report_error ppf = function "the type" "this extension" "definition" env) err | Rebind_wrong_type (lid, env, err) -> - Printtyp.report_unification_error ppf env err - (function ppf -> - fprintf ppf "The constructor %a@ has type" + let msg = Format_doc.doc_printf in + Errortrace_report.unification ppf env err + (msg "The constructor %a@ has type" (Style.as_inline_code Printtyp.longident) lid) - (function ppf -> - fprintf ppf "but was expected to be of type") + (msg "but was expected to be of type") | Rebind_mismatch (lid, p, p') -> fprintf ppf "@[%s@ %a@ %s@ %a@ %s@ %s@ %a@]" @@ -2163,44 +2141,44 @@ let report_error ppf = function in (match n with | Variance_variable_error { error; variable; context } -> - Printtyp.prepare_for_printing [ variable ]; + Out_type.prepare_for_printing [ variable ]; begin match context with | Type_declaration (id, decl) -> - Printtyp.add_type_declaration_to_preparation id decl; + Out_type.add_type_declaration_to_preparation id decl; fprintf ppf "@[%s@;<1 2>%a@;" "In the definition" - (Style.as_inline_code @@ Printtyp.prepared_type_declaration id) + (Style.as_inline_code @@ Out_type.prepared_type_declaration id) decl | Gadt_constructor c -> - Printtyp.add_constructor_to_preparation c; + Out_type.add_constructor_to_preparation c; fprintf ppf "@[%s@;<1 2>%a@;" "In the GADT constructor" - (Style.as_inline_code Printtyp.prepared_constructor) + (Style.as_inline_code Out_type.prepared_constructor) c | Extension_constructor (id, e) -> - Printtyp.add_extension_constructor_to_preparation e; + Out_type.add_extension_constructor_to_preparation e; fprintf ppf "@[%s@;<1 2>%a@;" "In the extension constructor" - (Printtyp.prepared_extension_constructor id) + (Out_type.prepared_extension_constructor id) e end; begin match error with | Variance_not_reflected -> fprintf ppf "@[%s@ %a@ %s@ %s@ It" "the type variable" - (Style.as_inline_code Printtyp.prepared_type_expr) variable + (Style.as_inline_code Out_type.prepared_type_expr) variable "has a variance that" "is not reflected by its occurrence in type parameters." | No_variable -> fprintf ppf "@[%s@ %a@ %s@ %s@]@]" "the type variable" - (Style.as_inline_code Printtyp.prepared_type_expr) variable + (Style.as_inline_code Out_type.prepared_type_expr) variable "cannot be deduced" "from the type parameters." | Variance_not_deducible -> fprintf ppf "@[%s@ %a@ %s@ %s@ It" "the type variable" - (Style.as_inline_code Printtyp.prepared_type_expr) variable + (Style.as_inline_code Out_type.prepared_type_expr) variable "has a variance that" "cannot be deduced from the type parameters." end @@ -2268,7 +2246,7 @@ let report_error ppf = function fprintf ppf "an unnamed existential variable" | Some str -> fprintf ppf "the existential variable %a" - (Style.as_inline_code Pprintast.tyvar) str in + (Style.as_inline_code Pprintast.Doc.tyvar) str in fprintf ppf "@[This type cannot be unboxed because@ \ it might contain both float and non-float values,@ \ depending on the instantiation of %a.@ \ @@ -2283,7 +2261,7 @@ let report_error ppf = function Style.inline_code "nonrec" | Invalid_private_row_declaration ty -> let pp_private ppf ty = fprintf ppf "private %a" Printtyp.type_expr ty in - Format.fprintf ppf + fprintf ppf "@[This private row type declaration is invalid.@ \ The type expression on the right-hand side reduces to@;<1 2>%a@ \ which does not have a free row type variable.@]@,\ @@ -2297,7 +2275,9 @@ let () = Location.register_error_of_exn (function | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) + Some (Location.error_of_printer ~loc report_error_doc err) | _ -> None ) + +let report_error = Format_doc.compat report_error_doc diff --git a/src/ocaml/typing/typedecl.mli b/src/ocaml/typing/typedecl.mli index 52a3197f7..38c00487e 100644 --- a/src/ocaml/typing/typedecl.mli +++ b/src/ocaml/typing/typedecl.mli @@ -16,8 +16,6 @@ (* Typing of type definitions and primitive definitions *) open Types -open Format - val transl_type_decl: Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> Typedtree.type_declaration list * Env.t * Shape.t list @@ -111,4 +109,5 @@ type error = exception Error of Location.t * error -val report_error: formatter -> error -> unit +val report_error: error Format_doc.format_printer +val report_error_doc: error Format_doc.printer diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml index 4080b1460..bbea6f43c 100644 --- a/src/ocaml/typing/typedtree.ml +++ b/src/ocaml/typing/typedtree.ml @@ -105,8 +105,8 @@ and expression_desc = | Texp_let of rec_flag * value_binding list * expression | Texp_function of function_param list * function_body | Texp_apply of expression * (arg_label * expression option) list - | Texp_match of expression * computation case list * partial - | Texp_try of expression * value case list + | Texp_match of expression * computation case list * value case list * partial + | Texp_try of expression * value case list * value case list | Texp_tuple of expression list | Texp_construct of Longident.t loc * constructor_description * expression list @@ -159,6 +159,7 @@ and meth = and 'k case = { c_lhs: 'k general_pattern; + c_cont: Ident.t option; c_guard: expression option; c_rhs: expression; } @@ -891,6 +892,12 @@ let split_pattern pat = let vals1, exns1 = split_pattern cp1 in let vals2, exns2 = split_pattern cp2 in combine_opts (into cpat) vals1 vals2, +<<<<<<< +======= + combine_opts (into cpat) exns1 exns2 + in + split_pattern pat +>>>>>>> (* We could change the pattern type for exception patterns to [Predef.exn], but it doesn't really matter. *) combine_opts (into cpat) exns1 exns2 diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli index be0732c8c..44db63a2d 100644 --- a/src/ocaml/typing/typedtree.mli +++ b/src/ocaml/typing/typedtree.mli @@ -217,17 +217,22 @@ and expression_desc = (Labelled "y", Some (Texp_constant Const_int 3)) ]) *) - | Texp_match of expression * computation case list * partial + | Texp_match of expression * computation case list * value case list * partial (** match E0 with | P1 -> E1 | P2 | exception P3 -> E2 | exception P4 -> E3 + | effect P4 k -> E4 [Texp_match (E0, [(P1, E1); (P2 | exception P3, E2); - (exception P4, E3)], _)] + (exception P4, E3)], [(P4, E4)], _)] *) - | Texp_try of expression * value case list - (** try E with P1 -> E1 | ... | PN -> EN *) + | Texp_try of expression * value case list * value case list + (** try E with + | P1 -> E1 + | effect P2 k -> E2 + [Texp_try (E, [(P1, E1)], [(P2, E2)])] + *) | Texp_tuple of expression list (** (E1, ..., EN) *) | Texp_construct of @@ -297,6 +302,7 @@ and meth = and 'k case = { c_lhs: 'k general_pattern; + c_cont: Ident.t option; c_guard: expression option; c_rhs: expression; } @@ -921,6 +927,7 @@ val pat_bound_idents_full: (** Splits an or pattern into its value (left) and exception (right) parts. *) val split_pattern: computation general_pattern -> pattern option * pattern option +<<<<<<< (** Whether an expression looks nice as the subject of a sentence in a error message. *) @@ -930,3 +937,5 @@ val exp_is_nominal : expression -> bool val unpack_functor_me : module_expr -> functor_parameter * module_expr val unpack_functor_mty : module_type -> functor_parameter * module_type +======= +>>>>>>> diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index a5fea9214..e14848ce5 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -19,7 +19,7 @@ open Path open Asttypes open Parsetree open Types -open Format +open Format_doc module Style = Misc.Style @@ -78,6 +78,7 @@ type error = | Invalid_type_subst_rhs | Unpackable_local_modtype_subst of Path.t | With_cannot_remove_packed_modtype of Path.t * module_type + | Cannot_alias of Path.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -273,9 +274,8 @@ let path_is_strict_prefix = Ident.same ident1 ident2 && list_is_strict_prefix l1 ~prefix:l2 -let iterator_with_env env = +let iterator_with_env super env = let env = ref (lazy env) in - let super = Btype.type_iterators in env, { super with Btype.it_signature = (fun self sg -> (* add all items to the env before recursing down, to handle recursive @@ -368,7 +368,8 @@ let check_usage_of_module_types ~error ~paths ~loc env super = { super with Btype.it_do_type_expr } let do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg = - let env, iterator = iterator_with_env env in + with_type_mark begin fun mark -> + let env, iterator = iterator_with_env (Btype.type_iterators mark) env in let last, rest = match List.rev paths with | [] -> assert false | last :: rest -> last, rest @@ -387,8 +388,8 @@ let do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg = let error p = With_cannot_remove_packed_modtype(p,mty) in check_usage_of_module_types ~error ~paths ~loc env iterator in - iterator.Btype.it_signature iterator sg; - Btype.(unmark_iterators.it_signature unmark_iterators) sg + iterator.Btype.it_signature iterator sg + end let check_usage_after_substitution env ~loc ~lid paths unpackable_modtype sg = match paths, unpackable_modtype with @@ -422,9 +423,9 @@ let check_well_formed_module env loc context mty = | _ :: rem -> check_signature env rem in - let env, super = iterator_with_env env in + let env, super = + iterator_with_env Btype.type_iterators_without_type_expr env in { super with - it_type_expr = (fun _self _ty -> ()); it_signature = (fun self sg -> let env_before = !env in let env = lazy (Env.add_signature sg (Lazy.force env_before)) in @@ -536,7 +537,7 @@ let merge_constraint initial_env loc sg lid constr = type_attributes = []; type_immediate = Unknown; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } and id_row = Ident.create_local (s^"#row") in let initial_env = @@ -608,7 +609,7 @@ let merge_constraint initial_env loc sg lid constr = if not destructive_substitution then let mtd': modtype_declaration = { - mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + mtd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); mtd_type = Some mty.mty_type; mtd_attributes = []; mtd_loc = loc; @@ -1184,19 +1185,19 @@ end = struct should raise an error. *) let check_unpackable_modtypes ~loc ~env to_remove component = - if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then begin - let iterator = - let error p = Unpackable_local_modtype_subst p in - let paths = - List.map (fun id -> Pident id) - (Ident.Set.elements to_remove.unpackable_modtypes) + if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then + with_type_mark begin fun mark -> + let iterator = + let error p = Unpackable_local_modtype_subst p in + let paths = + List.map (fun id -> Pident id) + (Ident.Set.elements to_remove.unpackable_modtypes) + in + check_usage_of_module_types ~loc ~error ~paths + (ref (lazy env)) (Btype.type_iterators mark) in - check_usage_of_module_types ~loc ~error ~paths - (ref (lazy env)) Btype.type_iterators - in - iterator.Btype.it_signature_item iterator component; - Btype.(unmark_iterators.it_signature_item unmark_iterators) component - end + iterator.Btype.it_signature_item iterator component + end (* We usually require name uniqueness of signature components (e.g. types, modules, etc), however in some situation reusing the name is allowed: if @@ -1356,7 +1357,7 @@ and transl_modtype_aux env smty = { md_type = arg.mty_type; md_attributes = []; md_loc = param.loc; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in Env.enter_module_declaration ~scope ~arg:true name Mp_present @@ -1412,7 +1413,11 @@ and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr = +<<<<<<< and transl_signature ?(keep_warnings = false) ?(toplevel = false) env sg = +======= +and transl_signature env sg = +>>>>>>> let names = Signature_names.create () in let rec transl_sig env sg = match sg with @@ -1554,14 +1559,17 @@ and transl_signature ?(keep_warnings = false) ?(toplevel = false) env sg = in let pres = match tmty.mty_type with - | Mty_alias _ -> Mp_absent + | Mty_alias p -> + if Env.is_functor_arg p env then + raise (Error (pmd.pmd_loc, env, Cannot_alias p)); + Mp_absent | _ -> Mp_present in let md = { md_type=tmty.mty_type; md_attributes=pmd.pmd_attributes; md_loc=pmd.pmd_loc; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in match pmd.pmd_name.txt with @@ -1603,7 +1611,7 @@ and transl_signature ?(keep_warnings = false) ?(toplevel = false) env sg = { md_type = Mty_alias path; md_attributes = pms.pms_attributes; md_loc = pms.pms_loc; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in let pres = @@ -1813,8 +1821,6 @@ and transl_signature ?(keep_warnings = false) ?(toplevel = false) env sg = end | Psig_attribute x -> Builtin_attributes.warning_attribute x; - if toplevel || not (Warnings.is_active (Misplaced_attribute "")) - then Builtin_attributes.mark_alert_used x; let (trem,rem, final_env) = transl_sig env srem in mksig (Tsig_attribute x) env loc :: trem, rem, final_env | Psig_extension (ext, _attrs) -> @@ -1844,7 +1850,7 @@ and transl_modtype_decl_aux env Types.mtd_type=Option.map (fun t -> t.mty_type) tmty; mtd_attributes=pmtd_attributes; mtd_loc=pmtd_loc; - mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + mtd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in let scope = Ctype.create_scope () in @@ -1903,7 +1909,7 @@ and transl_recmodule_modtypes env sdecls = let init = List.map2 (fun id pmd -> - let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let md = { md_type = approx_modtype approx_env pmd.pmd_type; md_loc = pmd.pmd_loc; @@ -2202,11 +2208,11 @@ and package_constraints env loc mty constrs = end let modtype_of_package env loc p fl = - (* We call Ctype.correct_levels to ensure that the types being added to the + (* We call Ctype.duplicate_type to ensure that the types being added to the module type are at generic_level. *) let mty = package_constraints env loc (Mty_ident p) - (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.duplicate_type t) fl) in Subst.modtype Keep Subst.identity mty @@ -2217,12 +2223,20 @@ let package_subtype env p1 fl1 p2 fl2 = modtype_of_package env Location.none p fl in match mkmty p1 fl1, mkmty p2 fl2 with - | exception Error(_, _, Cannot_scrape_package_type _) -> false + | exception Error(_, _, Cannot_scrape_package_type r) -> + Result.Error (Errortrace.Package_cannot_scrape r) | mty1, mty2 -> let loc = Location.none in match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with - | Tcoerce_none -> true - | _ | exception Includemod.Error _ -> false + | Tcoerce_none -> Ok () + | c -> + let msg = + Includemod_errorprinter.coercion_in_package_subtype env mty1 c + in + Result.Error (Errortrace.Package_coercion msg) + | exception Includemod.Error e -> + let msg = doc_printf "%a" Includemod_errorprinter.err_msgs e in + Result.Error (Errortrace.Package_inclusion msg) let () = Ctype.package_subtype := package_subtype @@ -2286,6 +2300,8 @@ let simplify_app_summary app_view = match app_view.arg with | false, Some p -> Includemod.Error.Named p, mty | false, None -> Includemod.Error.Anonymous, mty +let not_principal msg = Warnings.Not_principal (Format_doc.Doc.msg msg) + let rec type_module ?(alias=false) sttn funct_body anchor env smod = (* Merlin: when we start typing a module we don't want to include potential saved_items from its parent. We backup them before starting and restore them @@ -2374,7 +2390,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = match param.txt with | None -> None, env, Shape.for_unnamed_functor_param | Some name -> - let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let arg_md = { md_type = mty.mty_type; md_attributes = []; @@ -2432,9 +2448,8 @@ and type_module_aux ~alias sttn funct_body anchor env smod = end | Pmod_unpack sexp -> let exp = - Ctype.with_local_level_if_principal + Ctype.with_local_level_generalize_structure_if_principal (fun () -> Typecore.type_exp env sexp) - ~post:Typecore.generalize_structure_exp in let mty = match get_desc (Ctype.expand_head env exp.exp_type) with @@ -2446,7 +2461,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type) then Location.prerr_warning smod.pmod_loc - (Warnings.Not_principal "this module unpacking"); + (not_principal "this module unpacking"); modtype_of_package env smod.pmod_loc p fl | Tvar _ -> raise (Typecore.Error @@ -2808,7 +2823,7 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho | Mty_alias _ -> Mp_absent | _ -> Mp_present in - let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let md = { md_type = enrich_module_type anchor name.txt modl.mod_type env; md_attributes = attrs; @@ -2887,6 +2902,8 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho let mty' = enrich_module_type anchor name.txt modl.mod_type newenv in + Includemod.modtypes_consistency ~loc:modl.mod_loc newenv + mty' mty.mty_type; (id, name, mty, modl, mty', attrs, loc, shape, uid)) decls sbind in let newenv = (* allow aliasing recursive modules from outside *) @@ -3033,8 +3050,6 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pstr_attribute x -> Builtin_attributes.warning_attribute x; - if toplevel || not (Warnings.is_active (Misplaced_attribute "")) then - Builtin_attributes.mark_alert_used x; Tstr_attribute x, [], shape_map, env in let rec type_struct env shape_map sstr = @@ -3280,7 +3295,7 @@ let type_implementation target initial_env ast = Typecore.force_delayed_checks (); let shape = Shape_reduce.local_reduce Env.empty shape in Printtyp.wrap_printing_env ~error:false initial_env - (fun () -> fprintf std_formatter "%a@." + Format.(fun () -> fprintf std_formatter "%a@." (Printtyp.printed_signature @@ Unit_info.source_file target) simple_sg ); @@ -3336,8 +3351,8 @@ let type_implementation target initial_env ast = declarations like "let x = true;; let x = 1;;", because in this case, the inferred signature contains only the last declaration. *) let shape = Shape_reduce.local_reduce Env.empty shape in + let alerts = Builtin_attributes.alerts_of_str ~mark:true ast in if not !Clflags.dont_write_files then begin - let alerts = Builtin_attributes.alerts_of_str ast in let cmi = Env.save_signature ~alerts simple_sg (Unit_info.cmi target) in @@ -3365,10 +3380,7 @@ let save_signature target tsg initial_env cmi = (Cmt_format.Interface tsg) initial_env (Some cmi) None let type_interface env ast = - transl_signature ~toplevel:true env ast - -let transl_signature env ast = - transl_signature ~toplevel:false env ast + transl_signature env ast (* "Packaging" of several compilation units into one unit having them as sub-modules. *) @@ -3397,7 +3409,7 @@ let package_signatures units = { md_type=Mty_signature sg; md_attributes=[]; md_loc=Location.none; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in Sig_module(newid, Mp_present, md, Trec_not, Exported)) @@ -3467,9 +3479,7 @@ let package_units initial_env objfiles target_cmi = (* Error report *) - - -open Printtyp +open Printtyp.Doc let report_error ~loc _env = function Cannot_apply mty -> @@ -3477,8 +3487,9 @@ let report_error ~loc _env = function "@[This module is not a functor; it has type@ %a@]" (Style.as_inline_code modtype) mty | Not_included errs -> - let main = Includemod_errorprinter.err_msgs errs in - Location.errorf ~loc "@[Signature mismatch:@ %t@]" main + Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg + "@[Signature mismatch:@ %a@]" + Includemod_errorprinter.err_msgs errs | Cannot_eliminate_dependency mty -> Location.errorf ~loc "@[This functor has type@ %a@ \ @@ -3497,26 +3508,25 @@ let report_error ~loc _env = function Style.inline_code "with" (Style.as_inline_code longident) lid | With_mismatch(lid, explanation) -> - let main = Includemod_errorprinter.err_msgs explanation in - Location.errorf ~loc + Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg "@[\ @[In this %a constraint, the new definition of %a@ \ does not match its original definition@ \ in the constrained signature:@]@ \ - %t@]" + %a@]" Style.inline_code "with" - (Style.as_inline_code longident) lid main + (Style.as_inline_code longident) lid + Includemod_errorprinter.err_msgs explanation | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> - let main = Includemod_errorprinter.err_msgs explanation in - Location.errorf ~loc + Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg "@[\ @[This %a constraint on %a makes the applicative functor @ \ type %a ill-typed in the constrained signature:@]@ \ - %t@]" + %a@]" Style.inline_code "with" (Style.as_inline_code longident) lid Style.inline_code (Path.name path) - main + Includemod_errorprinter.err_msgs explanation | With_changes_module_alias(lid, id, path) -> Location.errorf ~loc "@[\ @@ -3536,8 +3546,8 @@ let report_error ~loc _env = function [ 12; 7; 3 ] in let pp_constraint ppf () = - Format.fprintf ppf "%s := %a" - (Path.name p) Printtyp.modtype mty + fprintf ppf "%s := %a" + (Path.name p) modtype mty in Location.errorf ~loc "This %a constraint@ %a@ makes a packed module ill-formed.@ %a" @@ -3549,7 +3559,7 @@ let report_error ~loc _env = function "In the constrained signature, type %a is defined to be %a.@ \ Package %a constraints may only be used on abstract types." (Style.as_inline_code longident) lid - (Style.as_inline_code Printtyp.type_expr) ty + (Style.as_inline_code type_expr) ty Style.inline_code "with" | Repeated_name(kind, name) -> Location.errorf ~loc @@ -3558,27 +3568,27 @@ let report_error ~loc _env = function (Sig_component_kind.to_string kind) Style.inline_code name | Non_generalizable { vars; expression } -> let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in - prepare_for_printing vars; - add_type_to_preparation expression; + Out_type.prepare_for_printing vars; + Out_type.add_type_to_preparation expression; Location.errorf ~loc "@[The type of this expression,@ %a,@ \ contains the non-generalizable type variable(s): %a.@ %a@]" - (Style.as_inline_code prepared_type_scheme) expression + (Style.as_inline_code Out_type.prepared_type_scheme) expression (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") - (Style.as_inline_code prepared_type_scheme)) vars + (Style.as_inline_code Out_type.prepared_type_scheme)) vars Misc.print_see_manual manual_ref | Non_generalizable_module { vars; mty; item } -> let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in - prepare_for_printing vars; - add_type_to_preparation item.val_type; + Out_type.prepare_for_printing vars; + Out_type.add_type_to_preparation item.val_type; let sub = [ Location.msg ~loc:item.val_loc "The type of this value,@ %a,@ \ contains the non-generalizable type variable(s) %a." - (Style.as_inline_code prepared_type_scheme) + (Style.as_inline_code Out_type.prepared_type_scheme) item.val_type (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") - @@ Style.as_inline_code prepared_type_scheme) vars + @@ Style.as_inline_code Out_type.prepared_type_scheme) vars ] in Location.errorf ~loc ~sub @@ -3590,11 +3600,11 @@ let report_error ~loc _env = function Location.errorf ~loc "@[The interface %a@ declares values, not just types.@ \ An implementation must be provided.@]" - Location.print_filename intf_name + Location.Doc.quoted_filename intf_name | Interface_not_compiled intf_name -> Location.errorf ~loc "@[Could not find the .cmi file for interface@ %a.@]" - Location.print_filename intf_name + Location.Doc.quoted_filename intf_name | Not_allowed_in_functor_body -> Location.errorf ~loc "@[This expression creates fresh types.@ %s@]" @@ -3623,12 +3633,18 @@ let report_error ~loc _env = function Location.errorf ~loc "This is an alias for module %a, which is missing" (Style.as_inline_code path) p + | Cannot_alias p -> + Location.errorf ~loc + "Functor arguments, such as %a, cannot be aliased" + (Style.as_inline_code path) p | Cannot_scrape_package_type p -> Location.errorf ~loc "The type of this packed module refers to %a, which is missing" (Style.as_inline_code path) p | Badly_formed_signature (context, err) -> - Location.errorf ~loc "@[In %s:@ %a@]" context Typedecl.report_error err + Location.errorf ~loc "@[In %s:@ %a@]" + context + Typedecl.report_error_doc err | Cannot_hide_id Illegal_shadowing { shadowed_item_kind; shadowed_item_id; shadowed_item_loc; shadower_id; user_id; user_kind; user_loc } -> diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli index d88d5b247..0b9ac71fb 100644 --- a/src/ocaml/typing/typemod.mli +++ b/src/ocaml/typing/typemod.mli @@ -43,8 +43,6 @@ val type_implementation: Typedtree.implementation val type_interface: Env.t -> Parsetree.signature -> Typedtree.signature -val transl_signature: - Env.t -> Parsetree.signature -> Typedtree.signature val check_nongen_signature: Env.t -> Types.signature -> unit (* @@ -137,6 +135,7 @@ type error = | Invalid_type_subst_rhs | Unpackable_local_modtype_subst of Path.t | With_cannot_remove_packed_modtype of Path.t * module_type + | Cannot_alias of Path.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/src/ocaml/typing/typeopt.ml b/src/ocaml/typing/typeopt.ml index f983c499c..c154d3b23 100644 --- a/src/ocaml/typing/typeopt.ml +++ b/src/ocaml/typing/typeopt.ml @@ -23,7 +23,7 @@ open Lambda let scrape_ty env ty = match get_desc ty with | Tconstr _ -> - let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + let ty = Ctype.expand_head_opt env ty in begin match get_desc ty with | Tconstr (p, _, _) -> begin match Env.find_type p env with diff --git a/src/ocaml/typing/types.ml b/src/ocaml/typing/types.ml index bdc2a9e54..a9c8c59d1 100644 --- a/src/ocaml/typing/types.ml +++ b/src/ocaml/typing/types.ml @@ -22,9 +22,13 @@ open Asttypes type transient_expr = { mutable desc: type_desc; mutable level: int; - mutable scope: int; + mutable scope: scope_field; id: int } +and scope_field = int + (* bit field: 27 bits for scope (Ident.highest_scope = 100_000_000) + and at least 4 marks *) + and type_expr = transient_expr and type_desc = @@ -51,13 +55,14 @@ and row_desc = and fixed_explanation = | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid and row_field = [`some] row_field_gen +and row_field_cell = [`some | `none] row_field_gen ref and _ row_field_gen = RFpresent : type_expr option -> [> `some] row_field_gen | RFeither : { no_arg: bool; arg_type: type_expr list; matched: bool; - ext: [`some | `none] row_field_gen ref} -> [> `some] row_field_gen + ext: row_field_cell} -> [> `some] row_field_gen | RFabsent : [> `some] row_field_gen | RFnone : [> `none] row_field_gen @@ -87,6 +92,8 @@ module TransientTypeOps = struct let equal t1 t2 = t1 == t2 end +module TransientTypeHash = Hashtbl.Make(TransientTypeOps) + (* *) module Uid = Shape.Uid @@ -175,6 +182,7 @@ module Variance = struct let unknown = 7 let full = single Inv let covariant = single Pos + let contravariant = single Neg let swap f1 f2 v v' = set_if (mem f2 v) f1 (set_if (mem f1 v) f2 v') let conjugate v = @@ -579,12 +587,48 @@ let repr t = | _ -> t +(* scope_field and marks *) + +let scope_mask = (1 lsl 27) - 1 +let marks_mask = (-1) lxor scope_mask +let () = assert (Ident.highest_scope land marks_mask = 0) + +type type_mark = + | Mark of {mark: int; mutable marked: type_expr list} + | Hash of {visited: unit TransientTypeHash.t} +let type_marks = + (* All the bits in marks_mask *) + List.init (Sys.int_size - 27) (fun x -> 1 lsl (x + 27)) +let available_marks = Local_store.s_ref type_marks +let with_type_mark f = + match !available_marks with + | mark :: rem as old -> + available_marks := rem; + let mk = Mark {mark; marked = []} in + Misc.try_finally (fun () -> f mk) ~always: begin fun () -> + available_marks := old; + match mk with + | Mark {marked} -> + (* unmark marked type nodes *) + List.iter + (fun ty -> ty.scope <- ty.scope land ((-1) lxor mark)) + marked + | Hash _ -> () + end + | [] -> + (* When marks are exhausted, fall back to using a hash table *) + f (Hash {visited = TransientTypeHash.create 1}) + (* getters for type_expr *) let get_desc t = (repr t).desc let get_level t = (repr t).level -let get_scope t = (repr t).scope +let get_scope t = (repr t).scope land scope_mask let get_id t = (repr t).id +let not_marked_node mark t = + match mark with + | Mark {mark} -> (repr t).scope land mark = 0 + | Hash {visited} -> not (TransientTypeHash.mem visited (repr t)) (* transient type_expr *) @@ -593,12 +637,28 @@ module Transient_expr = struct let set_desc ty d = ty.desc <- d let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d let set_level ty lv = ty.level <- lv - let set_scope ty sc = ty.scope <- sc + let get_scope ty = ty.scope land scope_mask + let get_marks ty = ty.scope lsr 27 + let set_scope ty sc = + if (sc land marks_mask <> 0) then + invalid_arg "Types.Transient_expr.set_scope"; + ty.scope <- (ty.scope land marks_mask) lor sc + let try_mark_node mark ty = + match mark with + | Mark ({mark} as mk) -> + (ty.scope land mark = 0) && (* mark type node when not marked *) + (ty.scope <- ty.scope lor mark; mk.marked <- ty :: mk.marked; true) + | Hash {visited} -> + not (TransientTypeHash.mem visited ty) && + (TransientTypeHash.add visited ty (); true) let coerce ty = ty let repr = repr let type_expr ty = ty end +(* setting marks *) +let try_mark_node mark t = Transient_expr.try_mark_node mark (repr t) + (* Comparison for [type_expr]; cannot be used for functors *) let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 @@ -725,8 +785,7 @@ let match_row_field ~present ~absent ~either (f : row_field) = | RFnone -> None | RFeither _ | RFpresent _ | RFabsent as e -> Some e in - either no_arg arg_type matched e - + either no_arg arg_type matched (ext,e) (**** Some type creators ****) @@ -734,13 +793,10 @@ let new_id = Local_store.s_ref (-1) let create_expr = Transient_expr.create -let newty3 ~level ~scope desc = +let proto_newty3 ~level ~scope desc = incr new_id; create_expr desc ~level ~scope ~id:!new_id -let newty2 ~level desc = - newty3 ~level ~scope:Ident.lowest_scope desc - (**********************************) (* Utilities for backtracking *) (**********************************) @@ -804,13 +860,16 @@ let set_level ty level = if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); Transient_expr.set_level ty level end + (* TODO: introduce a guard and rename it to set_higher_scope? *) let set_scope ty scope = let ty = repr ty in - if scope <> ty.scope then begin - if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); + let prev_scope = ty.scope land marks_mask in + if scope <> prev_scope then begin + if ty.id <= !last_snapshot then log_change (Cscope (ty, prev_scope)); Transient_expr.set_scope ty scope end + let set_univar rty ty = log_change (Cuniv (rty, !rty)); rty := Some ty let set_name nm v = diff --git a/src/ocaml/typing/types.mli b/src/ocaml/typing/types.mli index d7a782da3..60a093862 100644 --- a/src/ocaml/typing/types.mli +++ b/src/ocaml/typing/types.mli @@ -221,18 +221,36 @@ val get_level: type_expr -> int val get_scope: type_expr -> int val get_id: type_expr -> int +(** Access to marks. They are stored in the scope field. *) +type type_mark +val with_type_mark: (type_mark -> 'a) -> 'a + (* run a computation using exclusively an available type mark *) + +val not_marked_node: type_mark -> type_expr -> bool + (* Return true if a type node is not yet marked *) + +val try_mark_node: type_mark -> type_expr -> bool + (* Mark a type node if it is not yet marked. + Marks will be automatically removed when leaving the + scope of [with_type_mark]. + + Return false if it was already marked *) + (** Transient [type_expr]. Should only be used immediately after [Transient_expr.repr] *) type transient_expr = private { mutable desc: type_desc; mutable level: int; - mutable scope: int; + mutable scope: scope_field; id: int } +and scope_field (* abstract *) module Transient_expr : sig (** Operations on [transient_expr] *) val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr + val get_scope: transient_expr -> int + val get_marks: transient_expr -> int val set_desc: transient_expr -> type_desc -> unit val set_level: transient_expr -> int -> unit val set_scope: transient_expr -> int -> unit @@ -244,18 +262,17 @@ module Transient_expr : sig val set_stub_desc: type_expr -> type_desc -> unit (** Instantiate a not yet instantiated stub. Fail if already instantiated. *) + + val try_mark_node: type_mark -> transient_expr -> bool end val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr (** Functions and definitions moved from Btype *) -val newty3: level:int -> scope:int -> type_desc -> type_expr +val proto_newty3: level:int -> scope:int -> type_desc -> transient_expr (** Create a type with a fresh id *) -val newty2: level:int -> type_desc -> type_expr - (** Create a type with a fresh id and no scope *) - module TransientTypeOps : sig (** Comparisons for functors *) @@ -265,6 +282,8 @@ module TransientTypeOps : sig val hash : t -> int end +module TransientTypeHash : Hashtbl.S with type key = transient_expr + (** Comparisons for [type_expr]; cannot be used for functors *) val eq_type: type_expr -> type_expr -> bool @@ -346,12 +365,15 @@ val rf_either_of: type_expr option -> row_field val eq_row_field_ext: row_field -> row_field -> bool val changed_row_field_exts: row_field list -> (unit -> unit) -> bool +type row_field_cell val match_row_field: present:(type_expr option -> 'a) -> absent:(unit -> 'a) -> - either:(bool -> type_expr list -> bool -> row_field option ->'a) -> + either:(bool -> type_expr list -> bool -> + row_field_cell * row_field option ->'a) -> row_field -> 'a + (* *) module Uid = Shape.Uid @@ -413,6 +435,7 @@ module Variance : sig val null : t (* no occurrence *) val full : t (* strictly invariant (all flags) *) val covariant : t (* strictly covariant (May_pos, Pos and Inj) *) + val contravariant : t (* strictly contravariant *) val unknown : t (* allow everything, guarantee nothing *) val union : t -> t -> t val inter : t -> t -> t diff --git a/src/ocaml/typing/typetexp.ml b/src/ocaml/typing/typetexp.ml index 78d4fa883..c6d045543 100644 --- a/src/ocaml/typing/typetexp.ml +++ b/src/ocaml/typing/typetexp.ml @@ -218,7 +218,6 @@ end = struct promoted vars let check_poly_univars env loc vars = - vars |> List.iter (fun (_, p) -> generalize p.univar); let univars = vars |> List.map (fun (name, {univar=ty1; _ }) -> let v = Btype.proxy ty1 in @@ -350,8 +349,6 @@ let sort_constraints_no_duplicates loc env l = (* Translation of type expressions *) -let generalize_ctyp typ = generalize typ.ctyp_type - let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') let validate_name = function @@ -533,7 +530,7 @@ and transl_type_aux env ~row_context ~aliased ~policy styp = ty with Not_found -> let t, ty = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let t = newvar () in (* Use the whole location, which is used by [Type_mismatch]. *) TyVarEnv.remember_used alias.txt t styp.ptyp_loc; @@ -544,7 +541,6 @@ and transl_type_aux env ~row_context ~aliased ~policy styp = end; (t, ty) end - ~post: (fun (t, _) -> generalize_structure t) in let t = instance t in let px = Btype.proxy t in @@ -659,14 +655,13 @@ and transl_type_aux env ~row_context ~aliased ~policy styp = | Ptyp_poly(vars, st) -> let vars = List.map (fun v -> v.txt) vars in let new_univars, cty = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let new_univars = TyVarEnv.make_poly_univars vars in let cty = TyVarEnv.with_univars new_univars begin fun () -> transl_type env ~policy ~row_context st end in (new_univars, cty) end - ~post:(fun (_,cty) -> generalize_ctyp cty) in let ty = cty.ctyp_type in let ty_list = TyVarEnv.check_poly_univars env styp.ptyp_loc new_univars in @@ -776,8 +771,8 @@ let transl_type env policy styp = transl_type env ~policy ~row_context:[] styp (* Make the rows "fixed" in this type, to make universal check easier *) -let rec make_fixed_univars ty = - if Btype.try_mark_node ty then +let rec make_fixed_univars mark ty = + if try_mark_node mark ty then begin match get_desc ty with | Tvariant row -> let Row {fields; more; name; closed} = row_repr row in @@ -794,14 +789,19 @@ let rec make_fixed_univars ty = (Tvariant (create_row ~fields ~more ~name ~closed ~fixed:(Some (Univar more)))); - Btype.iter_row make_fixed_univars row + Btype.iter_row (make_fixed_univars mark) row | _ -> - Btype.iter_type_expr make_fixed_univars ty + Btype.iter_type_expr (make_fixed_univars mark) ty end +<<<<<<< +======= let make_fixed_univars ty = - make_fixed_univars ty; - Btype.unmark_type ty + with_type_mark (fun mark -> make_fixed_univars mark ty) + +let transl_type env policy styp = + transl_type env ~policy ~row_context:[] styp +>>>>>>> let transl_simple_type env ?univars ~closed styp = TyVarEnv.reset_locals ?univars (); @@ -815,7 +815,7 @@ let transl_simple_type_univars env styp = TyVarEnv.reset_locals (); let typ, univs = TyVarEnv.collect_univars begin fun () -> - with_local_level ~post:generalize_ctyp begin fun () -> + with_local_level_generalize begin fun () -> let policy = TyVarEnv.univars_policy in let typ = transl_type env policy styp in TyVarEnv.globalize_used_variables policy env (); @@ -829,7 +829,7 @@ let transl_simple_type_univars env styp = let transl_simple_type_delayed env styp = TyVarEnv.reset_locals (); let typ, force = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let policy = TyVarEnv.extensible_policy in let typ = transl_type env policy styp in make_fixed_univars typ.ctyp_type; @@ -839,8 +839,6 @@ let transl_simple_type_delayed env styp = let force = TyVarEnv.globalize_used_variables policy env in (typ, force) end - (* Generalize everything except the variables that were just globalized. *) - ~post:(fun (typ,_) -> generalize_ctyp typ) in (typ, instance typ.ctyp_type, force) @@ -849,13 +847,12 @@ let transl_type_scheme env styp = | Ptyp_poly (vars, st) -> let vars = List.map (fun v -> v.txt) vars in let univars, typ = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> TyVarEnv.reset (); let univars = TyVarEnv.make_poly_univars vars in let typ = transl_simple_type env ~univars ~closed:true st in (univars, typ) end - ~post:(fun (_,typ) -> generalize_ctyp typ) in let _ = TyVarEnv.instance_poly_univars env styp.ptyp_loc univars in { ctyp_desc = Ttyp_poly (vars, typ); @@ -864,20 +861,20 @@ let transl_type_scheme env styp = ctyp_loc = styp.ptyp_loc; ctyp_attributes = styp.ptyp_attributes } | _ -> - with_local_level + with_local_level_generalize (fun () -> TyVarEnv.reset (); transl_simple_type env ~closed:false styp) - ~post:generalize_ctyp (* Error report *) -open Format -open Printtyp +open Format_doc +open Printtyp.Doc module Style = Misc.Style -let pp_tag ppf t = Format.fprintf ppf "`%s" t - +let pp_tag ppf t = fprintf ppf "`%s" t +let pp_out_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty +let pp_type ppf ty = Style.as_inline_code Printtyp.Doc.type_expr ppf ty -let report_error env ppf = function +let report_error_doc env ppf = function | Unbound_type_variable (name, in_scope_names) -> fprintf ppf "The type variable %a is unbound in this type declaration.@ %a" Style.inline_code name @@ -895,21 +892,19 @@ let report_error env ppf = function (Style.as_inline_code longident) lid expected provided | Bound_type_variable name -> fprintf ppf "Already bound type parameter %a" - (Style.as_inline_code Pprintast.tyvar) name + (Style.as_inline_code Pprintast.Doc.tyvar) name | Recursive_type -> fprintf ppf "This type is recursive" | Type_mismatch trace -> - Printtyp.report_unification_error ppf Env.empty trace - (function ppf -> - fprintf ppf "This type") - (function ppf -> - fprintf ppf "should be an instance of type") + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf Env.empty trace + (msg "This type") + (msg "should be an instance of type") | Alias_type_mismatch trace -> - Printtyp.report_unification_error ppf Env.empty trace - (function ppf -> - fprintf ppf "This alias is bound to type") - (function ppf -> - fprintf ppf "but is used as an instance of type") + let msg = Format_doc.Doc.msg in + Errortrace_report.unification ppf Env.empty trace + (msg "This alias is bound to type") + (msg "but is used as an instance of type") | Present_has_conjunction l -> fprintf ppf "The present constructor %a has a conjunctive type" Style.inline_code l @@ -926,18 +921,17 @@ let report_error env ppf = function Style.inline_code ">" (Style.as_inline_code pp_tag) l | Constructor_mismatch (ty, ty') -> - let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in wrap_printing_env ~error:true env (fun () -> - Printtyp.prepare_for_printing [ty; ty']; + Out_type.prepare_for_printing [ty; ty']; fprintf ppf "@[%s %a@ %s@ %a@]" "This variant type contains a constructor" - pp_type (tree_of_typexp Type ty) + pp_out_type (Out_type.tree_of_typexp Type ty) "which should be" - pp_type (tree_of_typexp Type ty')) + pp_out_type (Out_type.tree_of_typexp Type ty')) | Not_a_variant ty -> fprintf ppf "@[The type %a@ does not expand to a polymorphic variant type@]" - (Style.as_inline_code Printtyp.type_expr) ty; + pp_type ty; begin match get_desc ty with | Tvar (Some s) -> (* PR#7012: help the user that wrote 'Foo instead of `Foo *) @@ -956,14 +950,13 @@ let report_error env ppf = function | Cannot_quantify (name, v) -> fprintf ppf "@[The universal type variable %a cannot be generalized:@ " - (Style.as_inline_code Pprintast.tyvar) name; + (Style.as_inline_code Pprintast.Doc.tyvar) name; if Btype.is_Tvar v then fprintf ppf "it escapes its scope" else if Btype.is_Tunivar v then fprintf ppf "it is already bound to another variable" else - fprintf ppf "it is bound to@ %a" - (Style.as_inline_code Printtyp.type_expr) v; + fprintf ppf "it is bound to@ %a" pp_type v; fprintf ppf ".@]"; | Multiple_constraints_on_type s -> fprintf ppf "Multiple constraints for type %a" @@ -972,8 +965,8 @@ let report_error env ppf = function wrap_printing_env ~error:true env (fun () -> fprintf ppf "@[Method %a has type %a,@ which should be %a@]" Style.inline_code l - (Style.as_inline_code Printtyp.type_expr) ty - (Style.as_inline_code Printtyp.type_expr) ty') + pp_type ty + pp_type ty') | Opened_object nm -> fprintf ppf "Illegal open object type%a" @@ -982,15 +975,17 @@ let report_error env ppf = function | None -> fprintf ppf "") nm | Not_an_object ty -> fprintf ppf "@[The type %a@ is not an object type@]" - (Style.as_inline_code Printtyp.type_expr) ty + pp_type ty let () = Location.register_error_of_exn (function | Error (loc, env, err) -> - Some (Location.error_of_printer ~loc (report_error env) err) + Some (Location.error_of_printer ~loc (report_error_doc env) err) | Error_forward err -> Some err | _ -> None ) + +let report_error env = Format_doc.compat (report_error_doc env) diff --git a/src/ocaml/typing/typetexp.mli b/src/ocaml/typing/typetexp.mli index 34243b1d4..bd03489f3 100644 --- a/src/ocaml/typing/typetexp.mli +++ b/src/ocaml/typing/typetexp.mli @@ -95,7 +95,8 @@ type error = exception Error of Location.t * Env.t * error -val report_error: Env.t -> Format.formatter -> error -> unit +val report_error: Env.t -> error Format_doc.format_printer +val report_error_doc: Env.t -> error Format_doc.printer (* Support for first-class modules. *) val transl_modtype_longident: (* from Typemod *) diff --git a/src/ocaml/typing/untypeast.ml b/src/ocaml/typing/untypeast.ml index 00a8ab142..a5e0741ac 100644 --- a/src/ocaml/typing/untypeast.ml +++ b/src/ocaml/typing/untypeast.ml @@ -121,13 +121,13 @@ let rec extract_letop_patterns n pat = (** Mapping functions. *) let constant = function - | Const_char c -> Pconst_char c - | Const_string (s,loc,d) -> Pconst_string (s,loc,d) - | Const_int i -> Pconst_integer (Int.to_string i, None) - | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') - | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') - | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n') - | Const_float f -> Pconst_float (f,None) + | Const_char c -> Const.char c + | Const_string (s,loc,d) -> Const.string ?quotation_delimiter:d ~loc s + | Const_int i -> Const.integer (Int.to_string i) + | Const_int32 i -> Const.integer ~suffix:'l' (Int32.to_string i) + | Const_int64 i -> Const.integer ~suffix:'L' (Int64.to_string i) + | Const_nativeint i -> Const.integer ~suffix:'n' (Nativeint.to_string i) + | Const_float f -> Const.float f let attribute sub a = { attr_name = map_loc sub a.attr_name; @@ -452,10 +452,32 @@ let expression sub exp = None -> list | Some exp -> (label, sub.expr sub exp) :: list ) list []) - | Texp_match (exp, cases, _) -> - Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases) - | Texp_try (exp, cases) -> - Pexp_try (sub.expr sub exp, List.map (sub.case sub) cases) + | Texp_match (exp, cases, eff_cases, _) -> + let merged_cases = List.map (sub.case sub) cases + @ List.map + (fun c -> + let uc = sub.case sub c in + let pat = { uc.pc_lhs + (* XXX KC: The 2nd argument of Ppat_effect is wrong *) + with ppat_desc = Ppat_effect (uc.pc_lhs, uc.pc_lhs) } + in + { uc with pc_lhs = pat }) + eff_cases + in + Pexp_match (sub.expr sub exp, merged_cases) + | Texp_try (exp, exn_cases, eff_cases) -> + let merged_cases = List.map (sub.case sub) exn_cases + @ List.map + (fun c -> + let uc = sub.case sub c in + let pat = { uc.pc_lhs + (* XXX KC: The 2nd argument of Ppat_effect is wrong *) + with ppat_desc = Ppat_effect (uc.pc_lhs, uc.pc_lhs) } + in + { uc with pc_lhs = pat }) + eff_cases + in + Pexp_try (sub.expr sub exp, merged_cases) | Texp_tuple list -> Pexp_tuple (List.map (sub.expr sub) list) | Texp_construct (lid, _, args) -> diff --git a/src/ocaml/typing/value_rec_check.ml b/src/ocaml/typing/value_rec_check.ml index eb741e744..985e42a63 100644 --- a/src/ocaml/typing/value_rec_check.ml +++ b/src/ocaml/typing/value_rec_check.ml @@ -154,7 +154,7 @@ let classify_expression : Typedtree.expression -> sd = (* Note on module presence: For absent modules (i.e. module aliases), the module being bound does not have a physical representation, but its size can still be - derived from the alias itself, so we can re-use the same code as + derived from the alias itself, so we can reuse the same code as for modules that are present. *) let size = classify_module_expression env mexp in let env = Ident.add mid size env in @@ -596,8 +596,8 @@ let rec expression : Typedtree.expression -> term_judg = value_bindings rec_flag bindings >> expression body | Texp_letmodule (x, _, _, mexp, e) -> module_binding (x, mexp) >> expression e - | Texp_match (e, cases, _) -> - (* + | Texp_match (e, cases, eff_cases, _) -> + (* TODO: update comment below for eff_cases (Gi; mi |- pi -> ei : m)^i G |- e : sum(mi)^i ---------------------------------------------- @@ -607,7 +607,11 @@ let rec expression : Typedtree.expression -> term_judg = let pat_envs, pat_modes = List.split (List.map (fun c -> case c mode) cases) in let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in - Env.join_list (env_e :: pat_envs)) + let eff_envs, eff_modes = + List.split (List.map (fun c -> case c mode) eff_cases) in + let eff_e = expression e (List.fold_left Mode.join Ignore eff_modes) in + Env.join_list + ((Env.join_list (env_e :: pat_envs)) :: (eff_e :: eff_envs))) | Texp_for (_, _, low, high, _, body) -> (* G1 |- low: m[Dereference] @@ -829,7 +833,7 @@ let rec expression : Typedtree.expression -> term_judg = modexp mexp | Texp_object (clsstrct, _) -> class_structure clsstrct - | Texp_try (e, cases) -> + | Texp_try (e, cases, eff_cases) -> (* G |- e: m (Gi; _ |- pi -> ei : m)^i -------------------------------------------- @@ -843,6 +847,7 @@ let rec expression : Typedtree.expression -> term_judg = join [ expression e; list case_env cases; + list case_env eff_cases; ] | Texp_override (pth, fields) -> (* diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml index f507f5836..8bb0532f6 100644 --- a/src/ocaml/utils/clflags.ml +++ b/src/ocaml/utils/clflags.ml @@ -31,3 +31,246 @@ let opaque = ref false let unboxed_types = ref false let locations = ref true +<<<<<<< +======= +let dump_parsetree = ref false (* -dparsetree *) +and dump_typedtree = ref false (* -dtypedtree *) +and dump_shape = ref false (* -dshape *) +and dump_matchcomp = ref false (* -dmatchcomp *) +and dump_rawlambda = ref false (* -drawlambda *) +and dump_lambda = ref false (* -dlambda *) +and dump_rawclambda = ref false (* -drawclambda *) +>>>>>>> +<<<<<<< +======= + +and dump_cmm = ref false (* -dcmm *) +let dump_selection = ref false (* -dsel *) +let dump_combine = ref false (* -dcombine *) +let dump_cse = ref false (* -dcse *) +let dump_live = ref false (* -dlive *) +let dump_spill = ref false (* -dspill *) +let dump_split = ref false (* -dsplit *) +let dump_interf = ref false (* -dinterf *) +let dump_prefer = ref false (* -dprefer *) +let dump_interval = ref false (* -dinterval *) +let dump_regalloc = ref false (* -dalloc *) +let dump_reload = ref false (* -dreload *) +let dump_scheduling = ref false (* -dscheduling *) +let dump_linear = ref false (* -dlinear *) +let keep_startup_file = ref false (* -dstartup *) +let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *) + +let native_code = ref false (* set to true under ocamlopt *) +>>>>>>> +<<<<<<< +======= +let dlcode = ref true (* not -nodynlink *) + +let pic_code = ref (match Config.architecture with (* -fPIC *) + | "amd64" | "s390x" -> true + | _ -> false) + +let runtime_variant = ref "" + +>>>>>>> +<<<<<<< +======= + in + save_ir_after := new_passes + +module Dump_option = struct + type t = + | Source + | Parsetree + | Typedtree + | Shape + | Match_comp + | Raw_lambda + | Lambda + | Instr + | Raw_clambda + | Clambda + | Raw_flambda + | Flambda + | Cmm + | Selection + | Combine + | CSE + | Live + | Spill + | Split + | Interf + | Prefer + | Regalloc + | Scheduling + | Linear + | Interval + + let compare (op1 : t) op2 = + Stdlib.compare op1 op2 + + let to_string = function + | Source -> "source" + | Parsetree -> "parsetree" + | Typedtree -> "typedtree" + | Shape -> "shape" + | Match_comp -> "matchcomp" + | Raw_lambda -> "rawlambda" + | Lambda -> "lambda" + | Instr -> "instr" + | Raw_clambda -> "rawclambda" + | Clambda -> "clambda" + | Raw_flambda -> "rawflambda" + | Flambda -> "flambda" + | Cmm -> "cmm" + | Selection -> "selection" + | Combine -> "combine" + | CSE -> "cse" + | Live -> "live" + | Spill -> "spill" + | Split -> "split" + | Interf -> "interf" + | Prefer -> "prefer" + | Regalloc -> "regalloc" + | Scheduling -> "scheduling" + | Linear -> "linear" + | Interval -> "interval" + + let of_string = function + | "source" -> Some Source + | "parsetree" -> Some Parsetree + | "typedtree" -> Some Typedtree + | "shape" -> Some Shape + | "matchcomp" -> Some Match_comp + | "rawlambda" -> Some Raw_lambda + | "lambda" -> Some Lambda + | "instr" -> Some Instr + | "rawclambda" -> Some Raw_clambda + | "clambda" -> Some Clambda + | "rawflambda" -> Some Raw_flambda + | "flambda" -> Some Flambda + | "cmm" -> Some Cmm + | "selection" -> Some Selection + | "combine" -> Some Combine + | "cse" -> Some CSE + | "live" -> Some Live + | "spill" -> Some Spill + | "split" -> Some Split + | "interf" -> Some Interf + | "prefer" -> Some Prefer + | "regalloc" -> Some Regalloc + | "scheduling" -> Some Scheduling + | "linear" -> Some Linear + | "interval" -> Some Interval + | _ -> None + + let flag = function + | Source -> dump_source + | Parsetree -> dump_parsetree + | Typedtree -> dump_typedtree + | Shape -> dump_shape + | Match_comp -> dump_matchcomp + | Raw_lambda -> dump_rawlambda + | Lambda -> dump_lambda + | Instr -> dump_instr + | Raw_clambda -> dump_rawclambda + | Clambda -> dump_clambda + | Raw_flambda -> dump_rawflambda + | Flambda -> dump_flambda + | Cmm -> dump_cmm + | Selection -> dump_selection + | Combine -> dump_combine + | CSE -> dump_cse + | Live -> dump_live + | Spill -> dump_spill + | Split -> dump_split + | Interf -> dump_interf + | Prefer -> dump_prefer + | Regalloc -> dump_regalloc + | Scheduling -> dump_scheduling + | Linear -> dump_linear + | Interval -> dump_interval + + type middle_end = + | Flambda + | Any + | Closure + + type class_ = + | Frontend + | Bytecode + | Middle of middle_end + | Backend + + let _ = + (* no Closure-specific dump option for now, silence a warning *) + Closure + + let classify : t -> class_ = function + | Source + | Parsetree + | Typedtree + | Shape + | Match_comp + | Raw_lambda + | Lambda + -> Frontend + | Instr + -> Bytecode + | Raw_clambda + | Clambda + -> Middle Any + | Raw_flambda + | Flambda + -> Middle Flambda + | Cmm + | Selection + | Combine + | CSE + | Live + | Spill + | Split + | Interf + | Prefer + | Regalloc + | Scheduling + | Linear + | Interval + -> Backend + + let available (option : t) : (unit, string) result = + let pass = Result.ok () in + let ( let* ) = Result.bind in + let fail descr = + Error ( + Printf.sprintf + "this compiler does not support %s-specific options" + descr + ) in + let guard descr cond = + if cond then pass + else fail descr in + let check_bytecode = guard "bytecode" (not !native_code) in + let check_native = guard "native" !native_code in + let check_middle_end = function + | Flambda -> guard "flambda" Config.flambda + | Closure -> guard "closure" (not Config.flambda) + | Any -> pass + in + match classify option with + | Frontend -> + pass + | Bytecode -> + check_bytecode + | Middle middle_end -> + let* () = check_native in + check_middle_end middle_end + | Backend -> + check_native +end + +module String = Misc.Stdlib.String + +let arg_spec = ref [] +>>>>>>> diff --git a/src/ocaml/utils/clflags.mli b/src/ocaml/utils/clflags.mli index 4948f5890..790c81e10 100644 --- a/src/ocaml/utils/clflags.mli +++ b/src/ocaml/utils/clflags.mli @@ -39,3 +39,67 @@ val opaque : bool ref val unboxed_types : bool ref val locations : bool ref +<<<<<<< +======= +val dump_parsetree : bool ref +val dump_typedtree : bool ref +val dump_shape : bool ref +val dump_matchcomp : bool ref +val dump_rawlambda : bool ref +val dump_lambda : bool ref +val dump_rawclambda : bool ref +>>>>>>> +<<<<<<< +======= + val to_output_filename: t -> prefix:string -> string + val of_input_filename: string -> t option +end + +val stop_after : Compiler_pass.t option ref +val should_stop_after : Compiler_pass.t -> bool +val set_save_ir_after : Compiler_pass.t -> bool -> unit +val should_save_ir_after : Compiler_pass.t -> bool + +module Dump_option : sig + type t = + | Source + | Parsetree + | Typedtree + | Shape + | Match_comp + | Raw_lambda + | Lambda + | Instr + | Raw_clambda + | Clambda + | Raw_flambda + | Flambda + (* Note: no support for [-dflambda-let ] for now. *) + | Cmm + | Selection + | Combine + | CSE + | Live + | Spill + | Split + | Interf + | Prefer + | Regalloc + | Scheduling + | Linear + | Interval + + val compare : t -> t -> int + + val of_string : string -> t option + val to_string : t -> string + + val flag : t -> bool ref + + val available : t -> (unit, string) Result.t +end + +val arg_spec : (string * Arg.spec * string) list ref + +(* [add_arguments __LOC__ args] will add the arguments from [args] at +>>>>>>> diff --git a/src/ocaml/utils/config.mli b/src/ocaml/utils/config.mli index df34aee28..6a9cd2bcd 100644 --- a/src/ocaml/utils/config.mli +++ b/src/ocaml/utils/config.mli @@ -46,13 +46,33 @@ val cmt_magic_number: string val index_magic_number: string (* Magic number for index files *) +<<<<<<< val max_tag: int (* Biggest tag that can be stored in the header of a regular block. *) +======= +val bytecode_cflags : string +(** The flags ocamlc should pass to the C compiler *) +>>>>>>> +<<<<<<< val flat_float_array: bool +======= +val bytecode_cppflags : string +(** The flags ocamlc should pass to the C preprocessor *) +>>>>>>> +<<<<<<< (**/**) +======= +val native_cflags : string +(** The flags ocamlopt should pass to the C compiler *) +>>>>>>> +<<<<<<< val merlin : bool +======= +val native_cppflags : string +(** The flags ocamlopt should pass to the C preprocessor *) +>>>>>>> (**/**) diff --git a/src/ocaml/utils/diffing.ml b/src/ocaml/utils/diffing.ml index 94391803a..f2c336d9c 100644 --- a/src/ocaml/utils/diffing.ml +++ b/src/ocaml/utils/diffing.ml @@ -42,10 +42,11 @@ let style = function | Modification -> Misc.Style.[ FG Magenta; Bold] let prefix ppf (pos, p) = + let open Format_doc in let sty = style p in - Format.pp_open_stag ppf (Misc.Style.Style sty); - Format.fprintf ppf "%i. " pos; - Format.pp_close_stag ppf () + pp_open_stag ppf (Misc.Style.Style sty); + fprintf ppf "%i. " pos; + pp_close_stag ppf () let (let*) = Option.bind @@ -346,7 +347,22 @@ let compute_inner_cell tbl i j = compute_proposition (i-1) (j-1) diff in let*! newweight, (diff, localstate) = - select_best_proposition [diag;del;insert] + (* The order of propositions is important here: + the call [select_best_proposition [P_0, ...; P_n]] keeps the first + proposition with minimal weight as the representative path for this + weight class at the current matrix position. + + By induction, the representative path for the minimal weight class will + be the smallest path according to the reverse lexical order induced by + the element order [[P_0;...; P_n]]. + + This is why we choose to start with the [Del] case since path ending with + [Del+] suffix are likely to correspond to parital application in the + functor application case. + Similarly, large block of deletions or insertions at the end of the + definitions might point toward incomplete definitions. + Thus this seems a good overall setting. *) + select_best_proposition [del;insert;diag] in let state = update diff localstate in Matrix.set tbl i j ~weight:newweight ~state ~diff:(Some diff) diff --git a/src/ocaml/utils/diffing.mli b/src/ocaml/utils/diffing.mli index 7f4d7ced1..79c51fbba 100644 --- a/src/ocaml/utils/diffing.mli +++ b/src/ocaml/utils/diffing.mli @@ -79,7 +79,7 @@ type change_kind = | Insertion | Modification | Preservation -val prefix: Format.formatter -> (int * change_kind) -> unit +val prefix: (int * change_kind) Format_doc.printer val style: change_kind -> Misc.Style.style list diff --git a/src/ocaml/utils/diffing_with_keys.ml b/src/ocaml/utils/diffing_with_keys.ml index 33a03b4da..c319b0378 100644 --- a/src/ocaml/utils/diffing_with_keys.ml +++ b/src/ocaml/utils/diffing_with_keys.ml @@ -37,8 +37,8 @@ let prefix ppf x = in let style k ppf inner = let sty = Diffing.style k in - Format.pp_open_stag ppf (Misc.Style.Style sty); - Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner + Format_doc.pp_open_stag ppf (Misc.Style.Style sty); + Format_doc.kfprintf (fun ppf -> Format_doc.pp_close_stag ppf () ) ppf inner in match x with | Change (Name {pos; _ } | Type {pos; _}) @@ -53,7 +53,7 @@ let prefix ppf x = (** To detect [move] and [swaps], we are using the fact that there are 2-cycles in the graph of name renaming. - - [Change (x,y,_) is then an edge from + - [Change (x,y,_)] is then an edge from [key_left x] to [key_right y]. - [Insert x] is an edge between the special node epsilon and [key_left x] diff --git a/src/ocaml/utils/diffing_with_keys.mli b/src/ocaml/utils/diffing_with_keys.mli index 2da826876..94e56fb72 100644 --- a/src/ocaml/utils/diffing_with_keys.mli +++ b/src/ocaml/utils/diffing_with_keys.mli @@ -46,7 +46,7 @@ type ('l,'r,'diff) change = | Insert of {pos:int; insert:'r} | Delete of {pos:int; delete:'l} -val prefix: Format.formatter -> ('l,'r,'diff) change -> unit +val prefix: ('l,'r,'diff) change Format_doc.printer module Define(D:Diffing.Defs with type eq := unit): sig diff --git a/src/ocaml/utils/load_path.ml b/src/ocaml/utils/load_path.ml index 2707339ba..8e6c0a8a5 100644 --- a/src/ocaml/utils/load_path.ml +++ b/src/ocaml/utils/load_path.ml @@ -106,15 +106,16 @@ let get_hidden_path_list () = List.rev_map Dir.path !hidden_dirs order. *) let prepend_add dir = List.iter (fun base -> - let fn = Filename.concat dir.Dir.path base in - let filename = Misc.normalized_unit_filename base in - if dir.Dir.hidden then begin - STbl.replace !hidden_files base fn; - STbl.replace !hidden_files_uncap filename fn - end else begin - STbl.replace !visible_files base fn; - STbl.replace !visible_files_uncap filename fn - end + Result.iter (fun filename -> + let fn = Filename.concat dir.Dir.path base in + if dir.Dir.hidden then begin + STbl.replace !hidden_files base fn; + STbl.replace !hidden_files_uncap filename fn + end else begin + STbl.replace !visible_files base fn; + STbl.replace !visible_files_uncap filename fn + end) + (Misc.normalized_unit_filename base) ) dir.Dir.files let init ~auto_include ~visible ~hidden = @@ -184,10 +185,13 @@ let add (dir : Dir.t) = in List.iter (fun base -> - let fn = Filename.concat dir.Dir.path base in - update base fn visible_files hidden_files; - let ubase = Misc.normalized_unit_filename base in - update ubase fn visible_files_uncap hidden_files_uncap) + Result.iter (fun ubase -> + let fn = Filename.concat dir.Dir.path base in + update base fn visible_files hidden_files; + update ubase fn visible_files_uncap hidden_files_uncap + ) + (Misc.normalized_unit_filename base) + ) dir.files; if dir.hidden then hidden_dirs := dir :: !hidden_dirs @@ -250,9 +254,12 @@ let find fn = let find_normalized_with_visibility fn = assert (not Config.merlin || Local_store.is_bound ()); + match Misc.normalized_unit_filename fn with + | Error _ -> raise Not_found + | Ok fn_uncap -> try if is_basename fn && not !Sys.interactive then - find_file_in_cache (Misc.normalized_unit_filename fn) + find_file_in_cache fn_uncap visible_files_uncap hidden_files_uncap else try @@ -261,7 +268,6 @@ let find_normalized_with_visibility fn = | Not_found -> (Misc.find_in_path_normalized (get_hidden_path_list ()) fn, Hidden) with Not_found -> - let fn_uncap = Misc.normalized_unit_filename fn in (!auto_include_callback Dir.find_normalized fn_uncap, Visible) let find_normalized fn = fst (find_normalized_with_visibility fn) diff --git a/src/ocaml/utils/local_store.mli b/src/ocaml/utils/local_store.mli index 3ea05d588..545cf71e0 100644 --- a/src/ocaml/utils/local_store.mli +++ b/src/ocaml/utils/local_store.mli @@ -14,7 +14,8 @@ (**************************************************************************) (** This module provides some facilities for creating references (and hash - tables) which can easily be snapshoted and restored to an arbitrary version. + tables) which can easily be snapshotted and restored to an arbitrary + version. It is used throughout the frontend (read: typechecker), to register all (well, hopefully) the global state. Thus making it easy for tools like diff --git a/src/ocaml/utils/warnings.ml b/src/ocaml/utils/warnings.ml index 4eb85d8a9..d4d3323f9 100644 --- a/src/ocaml/utils/warnings.ml +++ b/src/ocaml/utils/warnings.ml @@ -52,7 +52,7 @@ type t = | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) | Undeclared_virtual_method of string (* 17 *) - | Not_principal of string (* 18 *) + | Not_principal of Format_doc.t (* 18 *) | Non_principal_labels of string (* 19 *) | Ignored_extra_argument (* 20 *) | Nonreturning_statement (* 21 *) @@ -109,6 +109,7 @@ type t = | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -190,12 +191,13 @@ let number = function | Unused_tmc_attribute -> 71 | Tmc_breaks_tailcall -> 72 | Generative_application_expects_unit -> 73 + | Degraded_to_partial_match -> 74 ;; (* DO NOT REMOVE the ;; above: it is used by the testsuite/ests/warnings/mnemonics.mll test to determine where the definition of the number function above ends *) -let last_warning_number = 73 +let last_warning_number = 74 type description = { number : int; @@ -534,6 +536,11 @@ let descriptions = [ description = "A generative functor is applied to an empty structure \ (struct end) rather than to ()."; since = since 5 1 }; + { number = 74; + names = ["degraded-to-partial-match"]; + description = "A pattern-matching is compiled as partial \ + even if it appears to be total."; + since = since 5 3 }; ] let name_to_number = @@ -870,7 +877,7 @@ let parse_options errflag s = alerts (* If you change these, don't forget to change them in man/ocamlc.m *) -let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70" +let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70-74" let defaults_warn_error = "-a" let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] @@ -934,7 +941,9 @@ let message = function ^ String.concat " " l ^ "." | Unerasable_optional_argument -> "this optional argument cannot be erased." | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared." - | Not_principal s -> s^" is not principal." + | Not_principal msg -> + Format_doc.asprintf "%a is not principal." + Format_doc.pp_doc msg | Non_principal_labels s -> s^" without principality." | Ignored_extra_argument -> "this argument will not be used by the function." | Nonreturning_statement -> @@ -1047,7 +1056,7 @@ let message = function "Code should not depend on the actual values of\n\ this constructor's arguments. They are only for information\n\ and may change in future versions. %a" - Misc.print_see_manual ref_manual + (Format_doc.compat Misc.print_see_manual) ref_manual | Unreachable_case -> "this match case is unreachable.\n\ Consider replacing it with a refutation case ' -> .'" @@ -1078,7 +1087,7 @@ let message = function %s.\n\ Only the first match will be used to evaluate the guard expression.\n\ %a" - vars_explanation Misc.print_see_manual ref_manual + vars_explanation (Format_doc.compat Misc.print_see_manual) ref_manual | No_cmx_file name -> Printf.sprintf "no cmx file was found in path for module %s, \ @@ -1103,7 +1112,7 @@ let message = function | Erroneous_printed_signature s -> "The printed interface differs from the inferred interface.\n\ The inferred interface contained items which could not be printed\n\ - properly due to name collisions between identifiers." + properly due to name collisions between identifiers.\n" ^ s ^ "\nBeware that this warning is purely informational and will not catch\n\ all instances of erroneous printed interface." @@ -1143,6 +1152,16 @@ let message = function | Generative_application_expects_unit -> "A generative functor\n\ should be applied to '()'; using '(struct end)' is deprecated." + | Degraded_to_partial_match -> + let[@manual.ref "ss:warn74"] ref_manual = [ 13; 5; 5 ] in + Format.asprintf + "This pattern-matching is compiled \n\ + as partial, even if it appears to be total. \ + It may generate a Match_failure\n\ + exception. This typically occurs due to \ + complex matches on mutable fields.\n\ + %a" + (Format_doc.compat Misc.print_see_manual) ref_manual ;; let nerrors = ref 0 diff --git a/src/ocaml/utils/warnings.mli b/src/ocaml/utils/warnings.mli index bb42eec6e..b1b3a12f7 100644 --- a/src/ocaml/utils/warnings.mli +++ b/src/ocaml/utils/warnings.mli @@ -57,7 +57,7 @@ type t = | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) | Undeclared_virtual_method of string (* 17 *) - | Not_principal of string (* 18 *) + | Not_principal of Format_doc.t (* 18 *) | Non_principal_labels of string (* 19 *) | Ignored_extra_argument (* 20 *) | Nonreturning_statement (* 21 *) @@ -116,6 +116,7 @@ type t = | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) type alert = {kind:string; message:string; def:loc; use:loc} From 4e5690e451af5732082bb582e916fa4268392e96 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 17 Sep 2024 05:30:54 +0200 Subject: [PATCH 06/36] Apply a first bunch of patches --- src/ocaml/parsing/ast_helper.ml | 2 +- src/ocaml/parsing/builtin_attributes.ml | 5 - src/ocaml/parsing/location.ml | 183 +- src/ocaml/parsing/location.mli | 51 +- src/ocaml/parsing/pprintast.ml | 31 +- src/ocaml/parsing/pprintast.mli | 6 +- src/ocaml/parsing/printast.ml | 3 - src/ocaml/parsing/unit_info.ml | 3 +- src/ocaml/preprocess/lexer_raw.mll | 1054 +++--- src/ocaml/typing/btype.ml | 11 +- src/ocaml/typing/env.ml | 14 +- src/ocaml/typing/errortrace_report.ml | 590 ++++ src/ocaml/typing/errortrace_report.mli | 56 + src/ocaml/typing/ident.ml | 16 - src/ocaml/typing/magic_numbers.ml | 10 +- src/ocaml/typing/out_type.ml | 1973 ++++++++++++ src/ocaml/typing/out_type.mli | 259 ++ src/ocaml/typing/persistent_env.ml | 21 +- src/ocaml/typing/printtyp.ml | 5 - src/ocaml/typing/printtyp.mli | 245 +- src/ocaml/typing/rawprinttyp.ml | 147 + src/ocaml/typing/rawprinttyp.mli | 20 + src/ocaml/typing/stypes.ml | 6 - src/ocaml/typing/typeclass.ml | 6 +- src/ocaml/typing/typecore.ml | 208 +- src/ocaml/typing/typecore.ml.rej | 39 + src/ocaml/typing/typecore.mli | 3 - src/ocaml/typing/typedecl.ml | 6 +- src/ocaml/typing/typedtree.ml | 6 - src/ocaml/typing/typedtree.mli | 3 - src/ocaml/typing/typemod.ml | 5 - src/ocaml/typing/typetexp.ml | 3 - src/ocaml/utils/clflags.ml | 323 +- src/ocaml/utils/clflags.mli | 68 +- src/ocaml/utils/compression.ml | 31 + src/ocaml/utils/compression.mli | 34 + src/ocaml/utils/config.common.ml.in | 163 + src/ocaml/utils/config.fixed.ml | 13 + src/ocaml/utils/config.generated.ml.in | 94 + src/ocaml/utils/config.mli | 16 +- src/ocaml/utils/domainstate.ml.c | 38 + src/ocaml/utils/domainstate.mli.c | 24 + src/ocaml/utils/linkdeps.ml | 142 + src/ocaml/utils/linkdeps.mli | 64 + src/ocaml/utils/load_path.ml | 36 +- src/utils/format_doc.ml | 481 +++ src/utils/format_doc.mli | 297 ++ src/utils/misc.ml | 235 +- src/utils/misc.mli | 59 +- .../file_formats/cmi_format.ml.patch | 36 + .../file_formats/cmi_format.mli.patch | 11 + .../patches_503/parsing/ast_helper.ml.patch | 47 + .../patches_503/parsing/ast_helper.mli.patch | 34 + .../parsing/ast_invariants.ml.patch | 19 + .../patches_503/parsing/ast_iterator.ml.patch | 10 + .../patches_503/parsing/ast_mapper.ml.patch | 74 + .../patches_503/parsing/asttypes.ml.patch | 75 + .../patches_503/parsing/asttypes.mli.patch | 8 + .../patches_503/parsing/attr_helper.ml.patch | 25 + .../patches_503/parsing/attr_helper.mli.patch | 9 + .../parsing/builtin_attributes.ml.patch | 168 + .../parsing/builtin_attributes.mli.patch | 32 + upstream/patches_503/parsing/depend.ml.patch | 10 + .../patches_503/parsing/docstrings.ml.patch | 24 + upstream/patches_503/parsing/lexer.mli.patch | 16 + upstream/patches_503/parsing/lexer.mll.patch | 277 ++ .../patches_503/parsing/location.ml.patch | 374 +++ .../patches_503/parsing/location.mli.patch | 102 + upstream/patches_503/parsing/parse.ml.patch | 38 + upstream/patches_503/parsing/parser.mly.patch | 225 ++ .../patches_503/parsing/parsetree.mli.patch | 24 + .../patches_503/parsing/pprintast.ml.patch | 178 ++ .../patches_503/parsing/pprintast.mli.patch | 16 + .../patches_503/parsing/printast.ml.patch | 76 + .../patches_503/parsing/unit_info.ml.patch | 111 + .../patches_503/parsing/unit_info.mli.patch | 78 + upstream/patches_503/typing/btype.ml.patch | 309 ++ upstream/patches_503/typing/btype.mli.patch | 170 + .../patches_503/typing/cmt2annot.ml.patch | 19 + .../patches_503/typing/cmt2annot.mli.patch | 10 + upstream/patches_503/typing/ctype.ml.patch | 1524 +++++++++ upstream/patches_503/typing/ctype.mli.patch | 75 + upstream/patches_503/typing/datarepr.ml.patch | 46 + .../patches_503/typing/datarepr.mli.patch | 19 + upstream/patches_503/typing/env.ml.patch | 372 +++ upstream/patches_503/typing/env.mli.patch | 47 + upstream/patches_503/typing/envaux.ml.patch | 26 + upstream/patches_503/typing/envaux.mli.patch | 18 + .../patches_503/typing/errortrace.ml.patch | 43 + .../patches_503/typing/errortrace.mli.patch | 32 + .../typing/errortrace_report.ml.patch | 593 ++++ .../typing/errortrace_report.mli.patch | 59 + .../patches_503/typing/gprinttyp.ml.patch | 915 ++++++ .../patches_503/typing/gprinttyp.mli.patch | 328 ++ upstream/patches_503/typing/ident.ml.patch | 54 + upstream/patches_503/typing/ident.mli.patch | 24 + .../patches_503/typing/includeclass.ml.patch | 84 + .../patches_503/typing/includeclass.mli.patch | 18 + .../patches_503/typing/includecore.ml.patch | 363 +++ .../patches_503/typing/includecore.mli.patch | 42 + .../patches_503/typing/includemod.ml.patch | 609 ++++ .../patches_503/typing/includemod.mli.patch | 13 + .../typing/includemod_errorprinter.ml.patch | 795 +++++ .../typing/includemod_errorprinter.mli.patch | 11 + upstream/patches_503/typing/mtype.ml.patch | 51 + upstream/patches_503/typing/oprint.ml.patch | 126 + upstream/patches_503/typing/oprint.mli.patch | 43 + upstream/patches_503/typing/out_type.ml.patch | 1976 ++++++++++++ .../patches_503/typing/out_type.mli.patch | 262 ++ .../patches_503/typing/outcometree.mli.patch | 33 + upstream/patches_503/typing/parmatch.ml.patch | 88 + .../patches_503/typing/parmatch.mli.patch | 17 + upstream/patches_503/typing/path.ml.patch | 13 + upstream/patches_503/typing/path.mli.patch | 11 + .../typing/persistent_env.ml.patch | 70 + .../typing/persistent_env.mli.patch | 12 + upstream/patches_503/typing/predef.ml.patch | 96 + upstream/patches_503/typing/predef.mli.patch | 27 + .../patches_503/typing/primitive.ml.patch | 22 + upstream/patches_503/typing/printpat.ml.patch | 59 + .../patches_503/typing/printpat.mli.patch | 22 + upstream/patches_503/typing/printtyp.ml.patch | 2841 +++++++++++++++++ .../patches_503/typing/printtyp.mli.patch | 330 ++ .../patches_503/typing/printtyped.ml.patch | 25 + .../patches_503/typing/rawprinttyp.ml.patch | 150 + .../patches_503/typing/rawprinttyp.mli.patch | 23 + upstream/patches_503/typing/shape.ml.patch | 45 + upstream/patches_503/typing/shape.mli.patch | 30 + upstream/patches_503/typing/stypes.ml.patch | 22 + .../patches_503/typing/tast_iterator.ml.patch | 21 + .../patches_503/typing/tast_mapper.ml.patch | 38 + .../patches_503/typing/typeclass.ml.patch | 498 +++ .../patches_503/typing/typeclass.mli.patch | 30 + upstream/patches_503/typing/typecore.ml.patch | 2384 ++++++++++++++ .../patches_503/typing/typecore.mli.patch | 67 + upstream/patches_503/typing/typedecl.ml.patch | 548 ++++ .../patches_503/typing/typedecl.mli.patch | 18 + .../patches_503/typing/typedtree.ml.patch | 41 + .../patches_503/typing/typedtree.mli.patch | 45 + upstream/patches_503/typing/typemod.ml.patch | 477 +++ upstream/patches_503/typing/typemod.mli.patch | 19 + upstream/patches_503/typing/typeopt.ml.patch | 11 + upstream/patches_503/typing/types.ml.patch | 174 + upstream/patches_503/typing/types.mli.patch | 96 + upstream/patches_503/typing/typetexp.ml.patch | 259 ++ .../patches_503/typing/typetexp.mli.patch | 12 + .../patches_503/typing/untypeast.ml.patch | 60 + .../typing/value_rec_check.ml.patch | 52 + upstream/patches_503/utils/ccomp.ml.patch | 30 + upstream/patches_503/utils/ccomp.mli.patch | 8 + upstream/patches_503/utils/clflags.ml.patch | 241 ++ upstream/patches_503/utils/clflags.mli.patch | 62 + .../patches_503/utils/compression.ml.patch | 34 + .../patches_503/utils/compression.mli.patch | 37 + .../utils/config.common.ml.in.patch | 166 + .../patches_503/utils/config.fixed.ml.patch | 17 + .../utils/config.generated.ml.in.patch | 97 + upstream/patches_503/utils/config.mli.patch | 30 + upstream/patches_503/utils/diffing.ml.patch | 41 + upstream/patches_503/utils/diffing.mli.patch | 11 + .../utils/diffing_with_keys.ml.patch | 22 + .../utils/diffing_with_keys.mli.patch | 11 + .../patches_503/utils/domainstate.ml.c.patch | 41 + .../patches_503/utils/domainstate.mli.c.patch | 27 + .../patches_503/utils/format_doc.ml.patch | 484 +++ .../patches_503/utils/format_doc.mli.patch | 300 ++ upstream/patches_503/utils/linkdeps.ml.patch | 145 + upstream/patches_503/utils/linkdeps.mli.patch | 67 + upstream/patches_503/utils/load_path.ml.patch | 68 + .../patches_503/utils/local_store.mli.patch | 12 + upstream/patches_503/utils/misc.ml.patch | 345 ++ upstream/patches_503/utils/misc.mli.patch | 137 + upstream/patches_503/utils/warnings.ml.patch | 110 + upstream/patches_503/utils/warnings.mli.patch | 19 + 174 files changed, 28185 insertions(+), 1444 deletions(-) create mode 100644 src/ocaml/typing/errortrace_report.ml create mode 100644 src/ocaml/typing/errortrace_report.mli create mode 100644 src/ocaml/typing/out_type.ml create mode 100644 src/ocaml/typing/out_type.mli create mode 100644 src/ocaml/typing/rawprinttyp.ml create mode 100644 src/ocaml/typing/rawprinttyp.mli create mode 100644 src/ocaml/typing/typecore.ml.rej create mode 100644 src/ocaml/utils/compression.ml create mode 100644 src/ocaml/utils/compression.mli create mode 100644 src/ocaml/utils/config.common.ml.in create mode 100644 src/ocaml/utils/config.fixed.ml create mode 100644 src/ocaml/utils/config.generated.ml.in create mode 100644 src/ocaml/utils/domainstate.ml.c create mode 100644 src/ocaml/utils/domainstate.mli.c create mode 100644 src/ocaml/utils/linkdeps.ml create mode 100644 src/ocaml/utils/linkdeps.mli create mode 100644 src/utils/format_doc.ml create mode 100644 src/utils/format_doc.mli create mode 100644 upstream/patches_503/file_formats/cmi_format.ml.patch create mode 100644 upstream/patches_503/file_formats/cmi_format.mli.patch create mode 100644 upstream/patches_503/parsing/ast_helper.ml.patch create mode 100644 upstream/patches_503/parsing/ast_helper.mli.patch create mode 100644 upstream/patches_503/parsing/ast_invariants.ml.patch create mode 100644 upstream/patches_503/parsing/ast_iterator.ml.patch create mode 100644 upstream/patches_503/parsing/ast_mapper.ml.patch create mode 100644 upstream/patches_503/parsing/asttypes.ml.patch create mode 100644 upstream/patches_503/parsing/asttypes.mli.patch create mode 100644 upstream/patches_503/parsing/attr_helper.ml.patch create mode 100644 upstream/patches_503/parsing/attr_helper.mli.patch create mode 100644 upstream/patches_503/parsing/builtin_attributes.ml.patch create mode 100644 upstream/patches_503/parsing/builtin_attributes.mli.patch create mode 100644 upstream/patches_503/parsing/depend.ml.patch create mode 100644 upstream/patches_503/parsing/docstrings.ml.patch create mode 100644 upstream/patches_503/parsing/lexer.mli.patch create mode 100644 upstream/patches_503/parsing/lexer.mll.patch create mode 100644 upstream/patches_503/parsing/location.ml.patch create mode 100644 upstream/patches_503/parsing/location.mli.patch create mode 100644 upstream/patches_503/parsing/parse.ml.patch create mode 100644 upstream/patches_503/parsing/parser.mly.patch create mode 100644 upstream/patches_503/parsing/parsetree.mli.patch create mode 100644 upstream/patches_503/parsing/pprintast.ml.patch create mode 100644 upstream/patches_503/parsing/pprintast.mli.patch create mode 100644 upstream/patches_503/parsing/printast.ml.patch create mode 100644 upstream/patches_503/parsing/unit_info.ml.patch create mode 100644 upstream/patches_503/parsing/unit_info.mli.patch create mode 100644 upstream/patches_503/typing/btype.ml.patch create mode 100644 upstream/patches_503/typing/btype.mli.patch create mode 100644 upstream/patches_503/typing/cmt2annot.ml.patch create mode 100644 upstream/patches_503/typing/cmt2annot.mli.patch create mode 100644 upstream/patches_503/typing/ctype.ml.patch create mode 100644 upstream/patches_503/typing/ctype.mli.patch create mode 100644 upstream/patches_503/typing/datarepr.ml.patch create mode 100644 upstream/patches_503/typing/datarepr.mli.patch create mode 100644 upstream/patches_503/typing/env.ml.patch create mode 100644 upstream/patches_503/typing/env.mli.patch create mode 100644 upstream/patches_503/typing/envaux.ml.patch create mode 100644 upstream/patches_503/typing/envaux.mli.patch create mode 100644 upstream/patches_503/typing/errortrace.ml.patch create mode 100644 upstream/patches_503/typing/errortrace.mli.patch create mode 100644 upstream/patches_503/typing/errortrace_report.ml.patch create mode 100644 upstream/patches_503/typing/errortrace_report.mli.patch create mode 100644 upstream/patches_503/typing/gprinttyp.ml.patch create mode 100644 upstream/patches_503/typing/gprinttyp.mli.patch create mode 100644 upstream/patches_503/typing/ident.ml.patch create mode 100644 upstream/patches_503/typing/ident.mli.patch create mode 100644 upstream/patches_503/typing/includeclass.ml.patch create mode 100644 upstream/patches_503/typing/includeclass.mli.patch create mode 100644 upstream/patches_503/typing/includecore.ml.patch create mode 100644 upstream/patches_503/typing/includecore.mli.patch create mode 100644 upstream/patches_503/typing/includemod.ml.patch create mode 100644 upstream/patches_503/typing/includemod.mli.patch create mode 100644 upstream/patches_503/typing/includemod_errorprinter.ml.patch create mode 100644 upstream/patches_503/typing/includemod_errorprinter.mli.patch create mode 100644 upstream/patches_503/typing/mtype.ml.patch create mode 100644 upstream/patches_503/typing/oprint.ml.patch create mode 100644 upstream/patches_503/typing/oprint.mli.patch create mode 100644 upstream/patches_503/typing/out_type.ml.patch create mode 100644 upstream/patches_503/typing/out_type.mli.patch create mode 100644 upstream/patches_503/typing/outcometree.mli.patch create mode 100644 upstream/patches_503/typing/parmatch.ml.patch create mode 100644 upstream/patches_503/typing/parmatch.mli.patch create mode 100644 upstream/patches_503/typing/path.ml.patch create mode 100644 upstream/patches_503/typing/path.mli.patch create mode 100644 upstream/patches_503/typing/persistent_env.ml.patch create mode 100644 upstream/patches_503/typing/persistent_env.mli.patch create mode 100644 upstream/patches_503/typing/predef.ml.patch create mode 100644 upstream/patches_503/typing/predef.mli.patch create mode 100644 upstream/patches_503/typing/primitive.ml.patch create mode 100644 upstream/patches_503/typing/printpat.ml.patch create mode 100644 upstream/patches_503/typing/printpat.mli.patch create mode 100644 upstream/patches_503/typing/printtyp.ml.patch create mode 100644 upstream/patches_503/typing/printtyp.mli.patch create mode 100644 upstream/patches_503/typing/printtyped.ml.patch create mode 100644 upstream/patches_503/typing/rawprinttyp.ml.patch create mode 100644 upstream/patches_503/typing/rawprinttyp.mli.patch create mode 100644 upstream/patches_503/typing/shape.ml.patch create mode 100644 upstream/patches_503/typing/shape.mli.patch create mode 100644 upstream/patches_503/typing/stypes.ml.patch create mode 100644 upstream/patches_503/typing/tast_iterator.ml.patch create mode 100644 upstream/patches_503/typing/tast_mapper.ml.patch create mode 100644 upstream/patches_503/typing/typeclass.ml.patch create mode 100644 upstream/patches_503/typing/typeclass.mli.patch create mode 100644 upstream/patches_503/typing/typecore.ml.patch create mode 100644 upstream/patches_503/typing/typecore.mli.patch create mode 100644 upstream/patches_503/typing/typedecl.ml.patch create mode 100644 upstream/patches_503/typing/typedecl.mli.patch create mode 100644 upstream/patches_503/typing/typedtree.ml.patch create mode 100644 upstream/patches_503/typing/typedtree.mli.patch create mode 100644 upstream/patches_503/typing/typemod.ml.patch create mode 100644 upstream/patches_503/typing/typemod.mli.patch create mode 100644 upstream/patches_503/typing/typeopt.ml.patch create mode 100644 upstream/patches_503/typing/types.ml.patch create mode 100644 upstream/patches_503/typing/types.mli.patch create mode 100644 upstream/patches_503/typing/typetexp.ml.patch create mode 100644 upstream/patches_503/typing/typetexp.mli.patch create mode 100644 upstream/patches_503/typing/untypeast.ml.patch create mode 100644 upstream/patches_503/typing/value_rec_check.ml.patch create mode 100644 upstream/patches_503/utils/ccomp.ml.patch create mode 100644 upstream/patches_503/utils/ccomp.mli.patch create mode 100644 upstream/patches_503/utils/clflags.ml.patch create mode 100644 upstream/patches_503/utils/clflags.mli.patch create mode 100644 upstream/patches_503/utils/compression.ml.patch create mode 100644 upstream/patches_503/utils/compression.mli.patch create mode 100644 upstream/patches_503/utils/config.common.ml.in.patch create mode 100644 upstream/patches_503/utils/config.fixed.ml.patch create mode 100644 upstream/patches_503/utils/config.generated.ml.in.patch create mode 100644 upstream/patches_503/utils/config.mli.patch create mode 100644 upstream/patches_503/utils/diffing.ml.patch create mode 100644 upstream/patches_503/utils/diffing.mli.patch create mode 100644 upstream/patches_503/utils/diffing_with_keys.ml.patch create mode 100644 upstream/patches_503/utils/diffing_with_keys.mli.patch create mode 100644 upstream/patches_503/utils/domainstate.ml.c.patch create mode 100644 upstream/patches_503/utils/domainstate.mli.c.patch create mode 100644 upstream/patches_503/utils/format_doc.ml.patch create mode 100644 upstream/patches_503/utils/format_doc.mli.patch create mode 100644 upstream/patches_503/utils/linkdeps.ml.patch create mode 100644 upstream/patches_503/utils/linkdeps.mli.patch create mode 100644 upstream/patches_503/utils/load_path.ml.patch create mode 100644 upstream/patches_503/utils/local_store.mli.patch create mode 100644 upstream/patches_503/utils/misc.ml.patch create mode 100644 upstream/patches_503/utils/misc.mli.patch create mode 100644 upstream/patches_503/utils/warnings.ml.patch create mode 100644 upstream/patches_503/utils/warnings.mli.patch diff --git a/src/ocaml/parsing/ast_helper.ml b/src/ocaml/parsing/ast_helper.ml index f3d154c09..862dacb69 100644 --- a/src/ocaml/parsing/ast_helper.ml +++ b/src/ocaml/parsing/ast_helper.ml @@ -696,7 +696,7 @@ let no_label = Nolabel let extract_str_payload = function | PStr [{ pstr_desc = Pstr_eval ( {Parsetree. pexp_loc; pexp_desc = - Parsetree.Pexp_constant (Parsetree.Pconst_string (msg, _, _)) ; _ }, _ + Parsetree.Pexp_constant ({pconst_desc = Parsetree.Pconst_string (msg, _, _); _}) ; _ }, _ ); _ }] -> Some (msg, pexp_loc) | _ -> None diff --git a/src/ocaml/parsing/builtin_attributes.ml b/src/ocaml/parsing/builtin_attributes.ml index 35a2a549e..2336d52f5 100644 --- a/src/ocaml/parsing/builtin_attributes.ml +++ b/src/ocaml/parsing/builtin_attributes.ml @@ -103,13 +103,8 @@ let register_attr current_phase name = if is_builtin_attr name.txt then Attribute_table.replace unused_attrs name () -<<<<<<< - -let string_of_cst = function -======= let string_of_cst const = match const.pconst_desc with ->>>>>>> | Pconst_string(s, _, _) -> Some s | _ -> None diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml index 1710b45a1..e33cbfb54 100644 --- a/src/ocaml/parsing/location.ml +++ b/src/ocaml/parsing/location.ml @@ -122,6 +122,13 @@ let echo_eof () = print_newline (); incr num_loc_lines +(* This is used by the toplevel and the report printers below. *) +let separate_new_message ppf = + if not (is_first_message ()) then begin + Format.pp_print_newline ppf (); + incr num_loc_lines + end + (* Code printing errors and warnings must be wrapped using this function, in order to update [num_loc_lines]. @@ -143,12 +150,7 @@ let print_updating_num_loc_lines ppf f arg = pp_print_flush ppf (); pp_set_formatter_out_functions ppf out_functions -<<<<<<< (* -======= -(** {1 Printing setup }*) - ->>>>>>> let setup_tags () = Misc.Style.setup !Clflags.color *) @@ -213,17 +215,9 @@ let show_filename file = (* if !Clflags.absname then absolute_path file else *) file module Fmt = Format_doc -module Doc = struct - - (* This is used by the toplevel and the report printers below. *) - let separate_new_message ppf () = - if not (is_first_message ()) then begin - Fmt.pp_print_newline ppf (); - incr num_loc_lines - end - let filename ppf file = - Fmt.pp_print_string ppf (show_filename file) +let print_filename ppf file = + Format.pp_print_string ppf (show_filename file) (* Best-effort printing of the text describing a location, of the form 'File "foo.ml", line 3, characters 10-12'. @@ -231,7 +225,6 @@ module Doc = struct Some of the information (filename, line number or characters numbers) in the location might be invalid; in which case we do not print it. *) -<<<<<<< let print_loc ppf loc = (* setup_tags (); *) let file_valid = function @@ -273,75 +266,18 @@ let print_loc ppf loc = comma (); Format.fprintf ppf "%s %i" (capitalize "line") (if line_valid line then line else 1); -======= - let loc ppf loc = - setup_tags (); - let file_valid = function - | "_none_" -> - (* This is a dummy placeholder, but we print it anyway to please - editors that parse locations in error messages (e.g. Emacs). *) - true - | "" | "//toplevel//" -> false - | _ -> true - in - let line_valid line = line > 0 in - let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in ->>>>>>> - - let file = - (* According to the comment in location.mli, if [pos_fname] is "", we must - use [!input_name]. *) - if loc.loc_start.pos_fname = "" then !input_name - else loc.loc_start.pos_fname - in - let startline = loc.loc_start.pos_lnum in - let endline = loc.loc_end.pos_lnum in - let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in - - let first = ref true in - let capitalize s = - if !first then (first := false; String.capitalize_ascii s) - else s in - let comma () = - if !first then () else Fmt.fprintf ppf ", " in - - Fmt.fprintf ppf "@{"; - - if file_valid file then - Fmt.fprintf ppf "%s \"%a\"" (capitalize "file") filename file; - - (* Print "line 1" in the case of a dummy line number. This is to please the - existing setup of editors that parse locations in error messages (e.g. - Emacs). *) - comma (); - let startline = if line_valid startline then startline else 1 in - let endline = if line_valid endline then endline else startline in - begin if startline = endline then - Fmt.fprintf ppf "%s %i" (capitalize "line") startline - else - Fmt.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline - end; - - if chars_valid ~startchar ~endchar then ( - comma (); - Fmt.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar - ); - Fmt.fprintf ppf "@}" + if chars_valid ~startchar ~endchar then ( + comma (); + Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar + ); - (* Print a comma-separated list of locations *) - let locs ppf locs = - Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.fprintf ppf ",@ ") - loc ppf locs - let quoted_filename ppf f = Misc.Style.as_inline_code filename ppf f + Format.fprintf ppf "@}" -end - -let print_filename = Fmt.compat Doc.filename -let print_loc = Fmt.compat Doc.loc -let print_locs = Fmt.compat Doc.locs -let separate_new_message ppf = Fmt.compat Doc.separate_new_message ppf () +(* Print a comma-separated list of locations *) +let print_locs ppf locs = + Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") + print_loc ppf locs (******************************************************************************) (* An interval set structure; additionally, it stores user-provided information @@ -535,13 +471,13 @@ let highlight_quote ppf Option.fold ~some:Int.to_string ~none:"" lnum, start_pos)) in - Fmt.fprintf ppf "@["; + Format.fprintf ppf "@["; begin match lines with | [] | [("", _, _)] -> () | [(line, line_nb, line_start_cnum)] -> (* Single-line error *) - Fmt.fprintf ppf "%s | %s@," line_nb line; - Fmt.fprintf ppf "%*s " (String.length line_nb) ""; + Format.fprintf ppf "%s | %s@," line_nb line; + Format.fprintf ppf "%*s " (String.length line_nb) ""; (* Iterate up to [rightmost], which can be larger than the length of the line because we may point to a location after the end of the last token on the line, for instance: @@ -553,21 +489,21 @@ let highlight_quote ppf for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do let pos = line_start_cnum + i in if ISet.is_start iset ~pos <> None then - Fmt.fprintf ppf "@{<%s>" highlight_tag; - if ISet.mem iset ~pos then Fmt.pp_print_char ppf '^' + Format.fprintf ppf "@{<%s>" highlight_tag; + if ISet.mem iset ~pos then Format.pp_print_char ppf '^' else if i < String.length line then begin (* For alignment purposes, align using a tab for each tab in the source code *) - if line.[i] = '\t' then Fmt.pp_print_char ppf '\t' - else Fmt.pp_print_char ppf ' ' + if line.[i] = '\t' then Format.pp_print_char ppf '\t' + else Format.pp_print_char ppf ' ' end; if ISet.is_end iset ~pos <> None then - Fmt.fprintf ppf "@}" + Format.fprintf ppf "@}" done; - Fmt.fprintf ppf "@}@," + Format.fprintf ppf "@}@," | _ -> (* Multi-line error *) - Fmt.pp_two_columns ~sep:"|" ~max_lines ppf + Misc.pp_two_columns ~sep:"|" ~max_lines ppf @@ List.map (fun (line, line_nb, line_start_cnum) -> let line = String.mapi (fun i car -> if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.' @@ -575,12 +511,8 @@ let highlight_quote ppf (line_nb, line) ) lines end; -<<<<<<< Format.fprintf ppf "@]" *) -======= - Fmt.fprintf ppf "@]" ->>>>>>> @@ -684,10 +616,10 @@ let lines_around_from_current_input ~start_pos ~end_pos = (******************************************************************************) (* Reporting errors and warnings *) -type msg = Fmt.t loc +type msg = (Format.formatter -> unit) loc let msg ?(loc = none) fmt = - Fmt.kdoc_printf (fun txt -> { loc; txt }) fmt + Format.kdprintf (fun txt -> { loc; txt }) fmt type report_kind = | Report_error @@ -702,11 +634,7 @@ type report = { kind : report_kind; main : msg; sub : msg list; -<<<<<<< - source : error_source; -======= footnote: Fmt.t option; ->>>>>>> } let loc_of_report { main; _ } = main.loc @@ -725,7 +653,7 @@ type report_printer = { pp_main_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_main_txt : report_printer -> report -> - Format.formatter -> Fmt.t -> unit; + Format.formatter -> (Format.formatter -> unit) -> unit; pp_submsgs : report_printer -> report -> Format.formatter -> msg list -> unit; pp_submsg : report_printer -> report -> @@ -733,7 +661,7 @@ type report_printer = { pp_submsg_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_submsg_txt : report_printer -> report -> - Format.formatter -> Fmt.t -> unit; + Format.formatter -> (Format.formatter -> unit) -> unit; } (* @@ -795,19 +723,11 @@ let batch_mode_printer : report_printer = | Misc.Error_style.Short -> () in -<<<<<<< Format.fprintf ppf "@[%a:@ %a@]" print_loc loc highlight loc *) () -======= - Format.fprintf ppf "@[%a:@ %a@]" print_loc loc - (Fmt.compat highlight) loc - in - let pp_txt ppf txt = Format.fprintf ppf "@[%a@]" Fmt.Doc.format txt in - let pp_footnote ppf f = - Option.iter (Format.fprintf ppf "@,%a" pp_txt) f ->>>>>>> in + let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in let pp self ppf report = (* setup_tags (); *) separate_new_message ppf; @@ -816,14 +736,13 @@ let batch_mode_printer : report_printer = to be aligned with the main message box *) print_updating_num_loc_lines ppf (fun ppf () -> - Format.fprintf ppf "@[%a%a%a: %a%a%a%a%a@]@." + Format.fprintf ppf "@[%a%a%a: %a%a%a%a@]@." Format.pp_open_tbox () (self.pp_main_loc self report) report.main.loc (self.pp_report_kind self report) report.kind Format.pp_set_tab () (self.pp_main_txt self report) report.main.txt (self.pp_submsgs self report) report.sub - pp_footnote report.footnote Format.pp_close_tbox () ) () in @@ -909,44 +828,27 @@ type delayed_msg = unit -> Fmt.t option let report_error ppf err = print_report ppf err -<<<<<<< -let mkerror loc sub txt source = - { kind = Report_error; main = { loc; txt }; sub; source } -======= let mkerror loc sub footnote txt = { kind = Report_error; main = { loc; txt }; sub; footnote=footnote () } let errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = Fmt.kdoc_printf (mkerror loc sub footnote) ->>>>>>> -<<<<<<< -let errorf ?(loc = none) ?(sub = []) ?(source=Typer) = - Format.kdprintf (fun msg -> mkerror loc sub msg source) -======= let error ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) msg_str = mkerror loc sub footnote Fmt.Doc.(string msg_str empty) ->>>>>>> -<<<<<<< -let error ?(loc = none) ?(sub = []) ?(source=Typer) msg_str = - mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str) source -======= let error_of_printer ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) pp x = mkerror loc sub footnote (Fmt.doc_printf "%a" pp x) ->>>>>>> -let error_of_printer ?(loc = none) ?(sub = []) ?(source=Typer) pp x = - mkerror loc sub (fun ppf -> pp ppf x) source +let error_of_printer_file print x = + error_of_printer ~loc:(in_file !input_name) print x -let error_of_printer_file ?source print x = - error_of_printer ?source ~loc:(in_file !input_name) print x (******************************************************************************) (* Reporting warnings: generating a report from a warning number using the information in [Warnings] + convenience functions. *) -let default_warning_alert_reporter ?(source = Typer) report mk (loc: t) w : report option = +let default_warning_alert_reporter report mk (loc: t) w : report option = match report w with | `Inactive -> None | `Active { Warnings.id; message; is_error; sub_locs } -> @@ -956,12 +858,7 @@ let default_warning_alert_reporter ?(source = Typer) report mk (loc: t) w : repo let sub = List.map (fun (loc, sub_message) -> { loc; txt = msg_of_str sub_message } ) sub_locs in -<<<<<<< - Some { kind; main; sub; source } -======= Some { kind; main; sub; footnote=None } ->>>>>>> - let default_warning_reporter = default_warning_alert_reporter @@ -1072,6 +969,7 @@ let error_of_exn exn = in loop !error_of_exn + let () = register_error_of_exn (function @@ -1101,10 +999,5 @@ let () = | _ -> None ) -<<<<<<< -let raise_errorf ?(loc = none) ?(sub = []) ?(source = Typer)= - Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt source))) -======= let raise_errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = Fmt.kdoc_printf (fun txt -> raise (Error (mkerror loc sub footnote txt))) ->>>>>>> diff --git a/src/ocaml/parsing/location.mli b/src/ocaml/parsing/location.mli index abe46fcb8..bdee872d2 100644 --- a/src/ocaml/parsing/location.mli +++ b/src/ocaml/parsing/location.mli @@ -84,6 +84,7 @@ val input_lexbuf: Lexing.lexbuf option ref toplevel phrase. *) val input_phrase_buffer: Buffer.t option ref + (** {1 Toplevel-specific functions} *) val echo_eof: unit -> unit @@ -106,9 +107,7 @@ val rewrite_absolute_path: string -> string the BUILD_PATH_PREFIX_MAP spec} *) -(* val rewrite_find_first_existing: string -> string option -*) (** [rewrite_find_first_existing path] uses a BUILD_PATH_PREFIX_MAP mapping and tries to find a source in mapping that maps to a result that exists in the file system. @@ -130,9 +129,7 @@ val rewrite_find_first_existing: string -> string option the BUILD_PATH_PREFIX_MAP spec} *) -(* val rewrite_find_all_existing_dirs: string -> string list -*) (** [rewrite_find_all_existing_dirs dir] accumulates a list of existing directories, [dirs], that are the result of mapping a potentially abstract directory, [dir], over all the mapping pairs in the @@ -176,8 +173,6 @@ val print_loc: formatter -> t -> unit val print_locs: formatter -> t list -> unit val separate_new_message: formatter -> unit -<<<<<<< -======= module Doc: sig val separate_new_message: unit Format_doc.printer val filename: string Format_doc.printer @@ -186,12 +181,11 @@ module Doc: sig val locs: t list Format_doc.printer end ->>>>>>> (** {1 Toplevel-specific location highlighting} *) -(* + val highlight_terminfo: Lexing.lexbuf -> formatter -> t list -> unit -*) + (** {1 Reporting errors and warnings} *) @@ -208,24 +202,13 @@ type report_kind = | Report_alert of string | Report_alert_as_error of string -type error_source = Lexer | Parser | Typer | Warning | Unknown | Env | Config - type report = { kind : report_kind; main : msg; sub : msg list; -<<<<<<< - source : error_source; -======= footnote: Format_doc.t option ->>>>>>> } -(* Exposed for Merlin *) -val loc_of_report: report -> t -val print_main : formatter -> report -> unit -val print_sub_msg : formatter -> msg -> unit - type report_printer = { (* The entry point *) pp : report_printer -> @@ -254,12 +237,11 @@ type report_printer = { (** {2 Report printers used in the compiler} *) val batch_mode_printer: report_printer -(* + val terminfo_toplevel_printer: Lexing.lexbuf -> report_printer val best_toplevel_printer: unit -> report_printer (** Detects the terminal capabilities and selects an adequate printer *) -*) (** {2 Printing a [report]} *) @@ -323,7 +305,7 @@ val default_alert_reporter: t -> Warnings.alert -> report option val print_alert: t -> formatter -> Warnings.alert -> unit (** Prints an alert. This is simply the composition of [report_alert] and - [print_report]. *) + [print_report]. *) val prerr_alert_ref: (t -> Warnings.alert -> unit) ref @@ -350,35 +332,17 @@ val deprecated_script_alert: string -> unit type error = report (** An [error] is a [report] which [report_kind] must be [Report_error]. *) -<<<<<<< -val error: ?loc:t -> ?sub:msg list -> ?source:error_source -> string -> error -======= type delayed_msg = unit -> Format_doc.t option val error: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> string -> error ->>>>>>> -<<<<<<< -val errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> - ('a, Format.formatter, unit, error) format4 -> 'a -======= val errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> ('a, Format_doc.formatter, unit, error) format4 -> 'a ->>>>>>> -<<<<<<< -val error_of_printer: ?loc:t -> ?sub:msg list -> ?source:error_source -> - (formatter -> 'a -> unit) -> 'a -> error -======= val error_of_printer: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> (Format_doc.formatter -> 'a -> unit) -> 'a -> error ->>>>>>> -<<<<<<< -val error_of_printer_file: ?source:error_source -> (formatter -> 'a -> unit) -> 'a -> error -======= val error_of_printer_file: (Format_doc.formatter -> 'a -> unit) -> 'a -> error ->>>>>>> (** {1 Automatically reporting errors for raised exceptions} *) @@ -401,13 +365,8 @@ exception Already_displayed_error (** Raising [Already_displayed_error] signals an error which has already been printed. The exception will be caught, but nothing will be printed *) -<<<<<<< -val raise_errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> - ('a, Format.formatter, unit, 'b) format4 -> 'a -======= val raise_errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> ('a, Format_doc.formatter, unit, 'b) format4 -> 'a ->>>>>>> val report_exception: formatter -> exn -> unit (** Reraise the exception if it is unknown. *) diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index 9132073b2..0af98ba45 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -1818,14 +1818,13 @@ let payload = payload reset_ctxt let case_list = case_list reset_ctxt module Style = Misc.Style + (* merlin: moved from parse.ml *) let prepare_error err = - let source = Location.Parser in let open Syntaxerr in match err with | Unclosed(opening_loc, opening, closing_loc, closing) -> Location.errorf - ~source ~loc:closing_loc ~sub:[ Location.msg ~loc:opening_loc @@ -1834,47 +1833,47 @@ let prepare_error err = "Syntax error: %a expected" Style.inline_code closing | Expecting (loc, nonterm) -> - Location.errorf ~source ~loc "Syntax error: %a expected." + Location.errorf ~loc "Syntax error: %a expected." Style.inline_code nonterm | Not_expecting (loc, nonterm) -> - Location.errorf ~source ~loc "Syntax error: %a not expected." + Location.errorf ~loc "Syntax error: %a not expected." Style.inline_code nonterm | Applicative_path loc -> - Location.errorf ~source ~loc + Location.errorf ~loc "Syntax error: applicative paths of the form %a \ are not supported when the option %a is set." Style.inline_code "F(X).t" Style.inline_code "-no-app-func" | Variable_in_scope (loc, var) -> - Location.errorf ~source ~loc + Location.errorf ~loc "In this scoped type, variable %a \ is reserved for the local type %a." - (Style.as_inline_code tyvar) var + (Style.as_inline_code Doc.tyvar) var Style.inline_code var | Other loc -> - Location.errorf ~source ~loc "Syntax error" + Location.errorf ~loc "Syntax error" | Ill_formed_ast (loc, s) -> - Location.errorf ~source ~loc + Location.errorf ~loc "broken invariant in parsetree: %s" s | Invalid_package_type (loc, ipt) -> let invalid ppf ipt = match ipt with | Syntaxerr.Parameterized_types -> - Format.fprintf ppf "parametrized types are not supported" + Format_doc.fprintf ppf "parametrized types are not supported" | Constrained_types -> - Format.fprintf ppf "constrained types are not supported" + Format_doc.fprintf ppf "constrained types are not supported" | Private_types -> - Format.fprintf ppf "private types are not supported" + Format_doc.fprintf ppf "private types are not supported" | Not_with_type -> - Format.fprintf ppf "only %a constraints are supported" + Format_doc.fprintf ppf "only %a constraints are supported" Style.inline_code "with type t =" | Neither_identifier_nor_with_type -> - Format.fprintf ppf + Format_doc.fprintf ppf "only module type identifier and %a constraints are supported" Style.inline_code "with type" in - Location.errorf ~source ~loc "invalid package type: %a" invalid ipt + Location.errorf ~loc "Syntax error: invalid package type: %a" invalid ipt | Removed_string_set loc -> - Location.errorf ~source ~loc + Location.errorf ~loc "Syntax error: strings are immutable, there is no assignment \ syntax for them.\n\ @{Hint@}: Mutable sequences of bytes are available in \ diff --git a/src/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli index 56a9b12f1..7d6081c68 100644 --- a/src/ocaml/parsing/pprintast.mli +++ b/src/ocaml/parsing/pprintast.mli @@ -60,12 +60,12 @@ val tyvar: Format.formatter -> string -> unit special treatment required for the single quote character in second position, or for keywords by escaping them with \#. No-op on "_". *) -<<<<<<< (* merlin *) val case_list : Format.formatter -> Parsetree.case list -> unit val ident_of_name : Format.formatter -> string -> unit val needs_parens : string -> bool -======= + + (** {!Format_doc} functions for error messages *) module Doc:sig val longident: Longident.t Format_doc.printer @@ -75,4 +75,4 @@ module Doc:sig of a sentence in a error message. *) val nominal_exp : Parsetree.expression -> Format_doc.t option end ->>>>>>> + diff --git a/src/ocaml/parsing/printast.ml b/src/ocaml/parsing/printast.ml index 331d82f62..034f0d35e 100644 --- a/src/ocaml/parsing/printast.ml +++ b/src/ocaml/parsing/printast.ml @@ -59,7 +59,6 @@ let fmt_char_option f = function | None -> fprintf f "None" | Some c -> fprintf f "Some %c" c -<<<<<<< let fmt_constant f x = match x with | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; @@ -70,8 +69,6 @@ let fmt_constant f x = fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m -======= ->>>>>>> let fmt_mutable_flag f x = match x with | Immutable -> fprintf f "Immutable" diff --git a/src/ocaml/parsing/unit_info.ml b/src/ocaml/parsing/unit_info.ml index 66ad51b7c..87c8ae831 100644 --- a/src/ocaml/parsing/unit_info.ml +++ b/src/ocaml/parsing/unit_info.ml @@ -48,8 +48,7 @@ let modulize s = match Misc.Utf8_lexeme.capitalize s with Ok x | Error x -> x (* We re-export the [Misc] definition, and ignore encoding errors under the assumption that we should focus our effort on not *producing* badly encoded module names *) -let normalize x = match Misc.normalized_unit_filename x with - | Ok x | Error x -> x +let normalize x = Misc.normalized_unit_filename x let stem source_file = source_file |> Filename.basename |> basename_chop_extensions diff --git a/src/ocaml/preprocess/lexer_raw.mll b/src/ocaml/preprocess/lexer_raw.mll index d80597c83..ddd970b11 100644 --- a/src/ocaml/preprocess/lexer_raw.mll +++ b/src/ocaml/preprocess/lexer_raw.mll @@ -1,24 +1,24 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) (* The lexer definition *) { -open Misc -open Std open Lexing -open Parser_raw - -type keywords = (string, Parser_raw.token) Hashtbl.t +open Misc +open Parser type error = | Illegal_character of char @@ -29,57 +29,19 @@ type error = | Unterminated_string_in_comment of Location.t * Location.t | Empty_character_literal | Keyword_as_label of string + | Capitalized_label of string | Invalid_literal of string + | Invalid_directive of string * string option + | Invalid_encoding of string + | Invalid_char_in_ident of Uchar.t + | Non_lowercase_delimiter of string + | Capitalized_raw_identifier of string exception Error of error * Location.t -(* Monad in which the lexer evaluates *) -type 'a result = - | Return of 'a - | Refill of (unit -> 'a result) - | Fail of error * Location.t - -let return a = Return a - -let fail lexbuf e = Fail (e, Location.curr lexbuf) -let fail_loc e l = Fail (e,l) - -let rec (>>=) (m : 'a result) (f : 'a -> 'b result) : 'b result = - match m with - | Return a -> f a - | Refill u -> - Refill (fun () -> u () >>= f) - | Fail _ as e -> e - -type preprocessor = (Lexing.lexbuf -> Parser_raw.token) -> Lexing.lexbuf -> Parser_raw.token - -type state = { - keywords: keywords; - mutable buffer: Buffer.t; - mutable string_start_loc: Location.t; - mutable comment_start_loc: Location.t list; - mutable preprocessor: preprocessor option; -} - -let make ?preprocessor keywords = { - keywords; - buffer = Buffer.create 17; - string_start_loc = Location.none; - comment_start_loc = []; - preprocessor; -} - -let lABEL m = m >>= fun v -> return (LABEL v) -let oPTLABEL m = m >>= fun v -> return (OPTLABEL v) - -let rec catch m f = match m with - | Fail (e,l) -> f e l - | Refill next -> Refill (fun () -> catch (next ()) f) - | Return _ -> m - (* The table of keywords *) -let keyword_table : keywords = +let keyword_table = create_hashtable 149 [ "and", AND; "as", AS; @@ -90,6 +52,7 @@ let keyword_table : keywords = "do", DO; "done", DONE; "downto", DOWNTO; + "effect", EFFECT; "else", ELSE; "end", END; "exception", EXCEPTION; @@ -138,21 +101,22 @@ let keyword_table : keywords = "land", INFIXOP3("land"); "lsl", INFIXOP4("lsl"); "lsr", INFIXOP4("lsr"); - "asr", INFIXOP4("asr"); + "asr", INFIXOP4("asr") ] -let keywords l = create_hashtable 11 l +(* To buffer string literals *) -let list_keywords = - let add_kw str _tok kws = str :: kws in - let init = Hashtbl.fold add_kw keyword_table [] in - fun keywords -> - Hashtbl.fold add_kw keywords init +let string_buffer = Buffer.create 256 +let reset_string_buffer () = Buffer.reset string_buffer +let get_stored_string () = Buffer.contents string_buffer -let store_string_char buf c = Buffer.add_char buf c -let store_substring buf s ~pos ~len = Buffer.add_substring buf s pos len +let store_string_char c = Buffer.add_char string_buffer c +let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u +let store_string s = Buffer.add_string string_buffer s +let store_substring s ~pos ~len = Buffer.add_substring string_buffer s pos len -let store_normalized_newline buf newline = +let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf) +let store_normalized_newline newline = (* #12502: we normalize "\r\n" to "\n" at lexing time, to avoid behavior difference due to OS-specific newline characters in string literals. @@ -175,43 +139,58 @@ let store_normalized_newline buf newline = the first carriage return, if any. *) let len = String.length newline in if len = 1 - then store_string_char buf '\n' - else store_substring buf newline ~pos:1 ~len:(len - 1) + then store_string_char '\n' + else store_substring newline ~pos:1 ~len:(len - 1) (* To store the position of the beginning of a string and comment *) -let in_comment state = state.comment_start_loc <> [] +let string_start_loc = ref Location.none +let comment_start_loc = ref [] +let in_comment () = !comment_start_loc <> [] +let is_in_string = ref false +let in_string () = !is_in_string +let print_warnings = ref true (* Escaped chars are interpreted in strings unless they are in comments. *) -let store_escaped_uchar state lexbuf u = - if in_comment state - then Buffer.add_string state.buffer (Lexing.lexeme lexbuf) - else Buffer.add_utf_8_uchar state.buffer u +let store_escaped_char lexbuf c = + if in_comment () then store_lexeme lexbuf else store_string_char c +let store_escaped_uchar lexbuf u = + if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u -let compute_quoted_string_idloc {Location.loc_start = orig_loc; _ } shift id = +let compute_quoted_string_idloc {Location.loc_start = orig_loc } shift id = let id_start_pos = orig_loc.Lexing.pos_cnum + shift in let loc_start = Lexing.{orig_loc with pos_cnum = id_start_pos } in let loc_end = - Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id } + Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id} in {Location. loc_start ; loc_end ; loc_ghost = false } -let wrap_string_lexer f state lexbuf = - Buffer.reset state.buffer; - state.string_start_loc <- Location.curr lexbuf; - f state lexbuf >>= fun loc_end -> - lexbuf.lex_start_p <- state.string_start_loc.Location.loc_start; - let loc = - Location.{ - loc_ghost = false; - loc_start = state.string_start_loc.Location.loc_end; - loc_end; - } - in - state.string_start_loc <- Location.none; - return (Buffer.contents state.buffer, loc) +let wrap_string_lexer f lexbuf = + let loc_start = lexbuf.lex_curr_p in + reset_string_buffer(); + is_in_string := true; + let string_start = lexbuf.lex_start_p in + string_start_loc := Location.curr lexbuf; + let loc_end = f lexbuf in + is_in_string := false; + lexbuf.lex_start_p <- string_start; + let loc = Location.{loc_ghost= false; loc_start; loc_end} in + get_stored_string (), loc + +let wrap_comment_lexer comment lexbuf = + let start_loc = Location.curr lexbuf in + comment_start_loc := [start_loc]; + reset_string_buffer (); + let end_loc = comment lexbuf in + let s = get_stored_string () in + reset_string_buffer (); + s, + { start_loc with Location.loc_end = end_loc.Location.loc_end } + +let error lexbuf e = raise (Error(e, Location.curr lexbuf)) +let error_loc loc e = raise (Error(e, loc)) (* to translate escape sequences *) @@ -240,38 +219,34 @@ let char_for_backslash = function let illegal_escape lexbuf reason = let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in - fail lexbuf error + raise (Error (error, Location.curr lexbuf)) -let char_for_decimal_code state lexbuf i = +let char_for_decimal_code lexbuf i = let c = num_value lexbuf ~base:10 ~first:i ~last:(i+2) in if (c < 0 || c > 255) then - if in_comment state - then return 'x' + if in_comment () + then 'x' else illegal_escape lexbuf (Printf.sprintf "%d is outside the range of legal characters (0-255)." c) - else return (Char.chr c) + else Char.chr c -let char_for_octal_code state lexbuf i = +let char_for_octal_code lexbuf i = let c = num_value lexbuf ~base:8 ~first:i ~last:(i+2) in if (c < 0 || c > 255) then - if in_comment state - then return 'x' + if in_comment () + then 'x' else illegal_escape lexbuf (Printf.sprintf "o%o (=%d) is outside the range of legal characters (0-255)." c c) - else return (Char.chr c) + else Char.chr c let char_for_hexadecimal_code lexbuf i = Char.chr (num_value lexbuf ~base:16 ~first:i ~last:(i+1)) let uchar_for_uchar_escape lexbuf = - let illegal_escape lexbuf reason = - let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in - raise (Error (error, Location.curr lexbuf)) - in let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in let first = 3 (* skip opening \u{ *) in let last = len - 2 (* skip closing } *) in @@ -286,27 +261,54 @@ let uchar_for_uchar_escape lexbuf = illegal_escape lexbuf (Printf.sprintf "%X is not a Unicode scalar value" cp) -let keyword_or state s default = - try Hashtbl.find state.keywords s - with Not_found -> try Hashtbl.find keyword_table s - with Not_found -> default +let validate_encoding lexbuf raw_name = + match Utf8_lexeme.normalize raw_name with + | Error _ -> error lexbuf (Invalid_encoding raw_name) + | Ok name -> name + +let ident_for_extended lexbuf raw_name = + let name = validate_encoding lexbuf raw_name in + match Utf8_lexeme.validate_identifier name with + | Utf8_lexeme.Valid -> name + | Utf8_lexeme.Invalid_character u -> error lexbuf (Invalid_char_in_ident u) + | Utf8_lexeme.Invalid_beginning _ -> + assert false (* excluded by the regexps *) + +let validate_delim lexbuf raw_name = + let name = validate_encoding lexbuf raw_name in + if Utf8_lexeme.is_lowercase name then name + else error lexbuf (Non_lowercase_delimiter name) + +let validate_ext lexbuf name = + let name = validate_encoding lexbuf name in + match Utf8_lexeme.validate_identifier ~with_dot:true name with + | Utf8_lexeme.Valid -> name + | Utf8_lexeme.Invalid_character u -> error lexbuf (Invalid_char_in_ident u) + | Utf8_lexeme.Invalid_beginning _ -> + assert false (* excluded by the regexps *) + +let lax_delim raw_name = + match Utf8_lexeme.normalize raw_name with + | Error _ -> None + | Ok name -> + if Utf8_lexeme.is_lowercase name then Some name + else None let is_keyword name = Hashtbl.mem keyword_table name -let () = Lexer.is_keyword_ref := is_keyword -let check_label_name lexbuf name = - if is_keyword name - then fail lexbuf (Keyword_as_label name) - else return name +let check_label_name ?(raw_escape=false) lexbuf name = + if Utf8_lexeme.is_capitalized name then + error lexbuf (Capitalized_label name); + if not raw_escape && is_keyword name then + error lexbuf (Keyword_as_label name) (* Update the current location with file name and line number. *) -let update_loc lexbuf _file line absolute chars = +let update_loc lexbuf file line absolute chars = let pos = lexbuf.lex_curr_p in - let new_file = pos.pos_fname - (*match file with - | None -> pos.pos_fname - | Some s -> s*) + let new_file = match file with + | None -> pos.pos_fname + | Some s -> s in lexbuf.lex_curr_p <- { pos with pos_fname = new_file; @@ -314,15 +316,27 @@ let update_loc lexbuf _file line absolute chars = pos_bol = pos.pos_cnum - chars; } -(* Warn about Latin-1 characters used in idents *) +let preprocessor = ref None + +let escaped_newlines = ref false -let warn_latin1 lexbuf = - Location.deprecated (Location.curr lexbuf) - "ISO-Latin1 characters in identifiers" +let handle_docstrings = ref true +let comment_list = ref [] + +let add_comment com = + comment_list := com :: !comment_list + +let add_docstring_comment ds = + let com = + ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds) + in + add_comment com + +let comments () = List.rev !comment_list (* Error report *) -open Format +open Format_doc let prepare_error loc = function | Illegal_character c -> @@ -351,22 +365,44 @@ let prepare_error loc = function let msg = "Illegal empty character literal ''" in let sub = [Location.msg - "Hint: Did you mean ' ' or a type variable 'a?"] in + "@{Hint@}: Did you mean ' ' or a type variable 'a?"] in Location.error ~loc ~sub msg | Keyword_as_label kwd -> Location.errorf ~loc "%a is a keyword, it cannot be used as label name" Style.inline_code kwd + | Capitalized_label lbl -> + Location.errorf ~loc + "%a cannot be used as label name, \ + it must start with a lowercase letter" Style.inline_code lbl | Invalid_literal s -> Location.errorf ~loc "Invalid literal %s" s -(* FIXME: Invalid_directive? *) + | Invalid_directive (dir, explanation) -> + Location.errorf ~loc "Invalid lexer directive %S%t" dir + (fun ppf -> match explanation with + | None -> () + | Some expl -> fprintf ppf ": %s" expl) + | Invalid_encoding s -> + Location.errorf ~loc "Invalid encoding of identifier %s." s + | Invalid_char_in_ident u -> + Location.errorf ~loc "Invalid character U+%X in identifier" + (Uchar.to_int u) + | Capitalized_raw_identifier lbl -> + Location.errorf ~loc + "%a cannot be used as a raw identifier, \ + it must start with a lowercase letter" Style.inline_code lbl + | Non_lowercase_delimiter name -> + Location.errorf ~loc + "%a cannot be used as a quoted string delimiter,@ \ + it must contain only lowercase letters." + Style.inline_code name let () = Location.register_error_of_exn (function | Error (err, loc) -> - Some (prepare_error loc err) + Some (prepare_error loc err) | _ -> - None + None ) } @@ -375,15 +411,14 @@ let newline = ('\013'* '\010') let blank = [' ' '\009' '\012'] let lowercase = ['a'-'z' '_'] let uppercase = ['A'-'Z'] -let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9' '\128'-'\255'] -let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] -let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar_latin1 = identchar - (*['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']*) +let identstart = lowercase | uppercase +let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] +let utf8 = ['\192'-'\255'] ['\128'-'\191']* +let identstart_ext = identstart | utf8 +let identchar_ext = identchar | utf8 + let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let symbolcharnopercent = - ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] let dotsymbolchar = ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|'] let symbolchar_or_hash = @@ -392,7 +427,8 @@ let kwdopchar = ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|'] let ident = (lowercase | uppercase) identchar* -let extattrident = ident ('.' ident)* +let ident_ext = identstart_ext identchar_ext* +let extattrident = ident_ext ('.' ident_ext)* let decimal_literal = ['0'-'9'] ['0'-'9' '_']* @@ -409,7 +445,7 @@ let int_literal = let float_literal = ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*) ? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? let hex_float_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']* @@ -418,428 +454,522 @@ let hex_float_literal = let literal_modifier = ['G'-'Z' 'g'-'z'] let raw_ident_escape = "\\#" - -refill {fun k lexbuf -> Refill (fun () -> k lexbuf)} - - -rule token state = parse - | ("\\" as bs) newline { - match state.preprocessor with - | None -> fail lexbuf (Illegal_character bs) - | Some _ -> - update_loc lexbuf None 1 false 0; - token state lexbuf } +rule token = parse + | ('\\' as bs) newline { + if not !escaped_newlines then error lexbuf (Illegal_character bs); + update_loc lexbuf None 1 false 0; + token lexbuf } | newline { update_loc lexbuf None 1 false 0; - match state.preprocessor with - | None -> token state lexbuf - | Some _ -> return EOL - } + EOL } | blank + - { token state lexbuf } - | ".<" - { return DOTLESS } - | ">." - { return (keyword_or state (Lexing.lexeme lexbuf) (INFIXOP0 ">.")) } - | ".~" - { return (keyword_or state (Lexing.lexeme lexbuf) DOTTILDE) } + { token lexbuf } | "_" - { return UNDERSCORE } + { UNDERSCORE } | "~" - { return TILDE } - (* + { TILDE } | ".~" - { fail lexbuf + { error lexbuf (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } - *) - | "~" raw_ident_escape (lowercase identchar * as name) ':' - { return (LABEL name) } - | "~" (lowercase identchar * as name) ':' - { lABEL (check_label_name lexbuf name) } - | "~" (lowercase_latin1 identchar_latin1 * as name) ':' - { warn_latin1 lexbuf; - return (LABEL name) } + | "~" (identstart identchar * as name) ':' + { check_label_name lexbuf name; + LABEL name } + | "~" (raw_ident_escape? as escape) (ident_ext as raw_name) ':' + { let name = ident_for_extended lexbuf raw_name in + check_label_name ~raw_escape:(escape<>"") lexbuf name; + LABEL name } | "?" - { return QUESTION } - | "?" raw_ident_escape (lowercase identchar * as name) ':' - { return (OPTLABEL name) } + { QUESTION } | "?" (lowercase identchar * as name) ':' - { oPTLABEL (check_label_name lexbuf name) } - | "?" (lowercase_latin1 identchar_latin1 * as name) ':' - { warn_latin1 lexbuf; return (OPTLABEL name) } - | raw_ident_escape (lowercase identchar * as name) - { return (LIDENT name) } + { check_label_name lexbuf name; + OPTLABEL name } + | "?" (raw_ident_escape? as escape) (ident_ext as raw_name) ':' + { let name = ident_for_extended lexbuf raw_name in + check_label_name ~raw_escape:(escape<>"") lexbuf name; + OPTLABEL name + } | lowercase identchar * as name - { return (try Hashtbl.find state.keywords name - with Not_found -> - try Hashtbl.find keyword_table name - with Not_found -> - LIDENT name) } - | lowercase_latin1 identchar_latin1 * as name - { warn_latin1 lexbuf; return (LIDENT name) } + { try Hashtbl.find keyword_table name + with Not_found -> LIDENT name } | uppercase identchar * as name - { (* Capitalized keywords for OUnit *) - return (try Hashtbl.find state.keywords name - with Not_found -> - try Hashtbl.find keyword_table name - with Not_found -> - UIDENT name) } - | uppercase_latin1 identchar_latin1 * as name - { warn_latin1 lexbuf; return (UIDENT name) } - | int_literal as lit { return (INT (lit, None)) } + { UIDENT name } (* No capitalized keywords *) + | (raw_ident_escape? as escape) (ident_ext as raw_name) + { let name = ident_for_extended lexbuf raw_name in + if Utf8_lexeme.is_capitalized name then begin + if escape="" then UIDENT name + else + (* we don't have capitalized keywords, and thus no needs for + capitalized raw identifiers. *) + error lexbuf (Capitalized_raw_identifier name) + end else + LIDENT name + } (* No non-ascii keywords *) + | int_literal as lit { INT (lit, None) } | (int_literal as lit) (literal_modifier as modif) - { return (INT (lit, Some modif)) } + { INT (lit, Some modif) } | float_literal | hex_float_literal as lit - { return (FLOAT (lit, None)) } + { FLOAT (lit, None) } | (float_literal | hex_float_literal as lit) (literal_modifier as modif) - { return (FLOAT (lit, Some modif)) } + { FLOAT (lit, Some modif) } | (float_literal | hex_float_literal | int_literal) identchar+ as invalid - { fail lexbuf (Invalid_literal invalid) } + { error lexbuf (Invalid_literal invalid) } | "\"" - { wrap_string_lexer string state lexbuf >>= fun (str, loc) -> - return (STRING (str, loc, None)) } - | "\'\'" - { wrap_string_lexer string state lexbuf >>= fun (str, loc) -> - return (STRING (str, loc, None)) } - | "{" (lowercase* as delim) "|" - { wrap_string_lexer (quoted_string delim) state lexbuf - >>= fun (str, loc) -> - return (STRING (str, loc, Some delim)) } - | "{%" (extattrident as id) "|" + { let s, loc = wrap_string_lexer string lexbuf in + STRING (s, loc, None) } + | "{" (ident_ext? as raw_name) '|' + { let delim = validate_delim lexbuf raw_name in + let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in + STRING (s, loc, Some delim) + } + | "{%" (extattrident as raw_id) "|" { let orig_loc = Location.curr lexbuf in - wrap_string_lexer (quoted_string "") state lexbuf - >>= fun (str, loc) -> + let id = validate_ext lexbuf raw_id in + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in let idloc = compute_quoted_string_idloc orig_loc 2 id in - return (QUOTED_STRING_EXPR (id, idloc, str, loc, Some "")) } - | "{%" (extattrident as id) blank+ (lowercase* as delim) "|" + QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") } + | "{%" (extattrident as raw_id) blank+ (ident_ext as raw_delim) "|" { let orig_loc = Location.curr lexbuf in - wrap_string_lexer (quoted_string delim) state lexbuf - >>= fun (str, loc) -> + let id = validate_ext lexbuf raw_id in + let delim = validate_delim lexbuf raw_delim in + let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in let idloc = compute_quoted_string_idloc orig_loc 2 id in - return (QUOTED_STRING_EXPR (id, idloc, str, loc, Some delim)) } - | "{%%" (extattrident as id) "|" + QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) } + | "{%%" (extattrident as raw_id) "|" { let orig_loc = Location.curr lexbuf in - wrap_string_lexer (quoted_string "") state lexbuf - >>= fun (str, loc) -> + let id = validate_ext lexbuf raw_id in + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in let idloc = compute_quoted_string_idloc orig_loc 3 id in - return (QUOTED_STRING_ITEM (id, idloc, str, loc, Some "")) } - | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|" + QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") } + | "{%%" (extattrident as raw_id) blank+ (ident_ext as raw_delim) "|" { let orig_loc = Location.curr lexbuf in - wrap_string_lexer (quoted_string delim) state lexbuf - >>= fun (str, loc) -> + let id = validate_ext lexbuf raw_id in + let delim = validate_delim lexbuf raw_delim in + let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in let idloc = compute_quoted_string_idloc orig_loc 3 id in - return (QUOTED_STRING_ITEM (id, idloc, str, loc, Some delim)) } + QUOTED_STRING_ITEM (id, idloc, s, loc, Some delim) } | "\'" newline "\'" - { update_loc lexbuf None 1 false 1; - (* newline is ('\013'* '\010') *) - return (CHAR '\n') } + { update_loc lexbuf None 1 false 1; + (* newline is ('\013'* '\010') *) + CHAR '\n' } | "\'" ([^ '\\' '\'' '\010' '\013'] as c) "\'" - { return (CHAR c) } + { CHAR c } | "\'\\" (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) "\'" - { return (CHAR (char_for_backslash c)) } - | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" - { char_for_octal_code state lexbuf 3 >>= fun c -> return (CHAR c) } + { CHAR (char_for_backslash c) } | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" - { char_for_decimal_code state lexbuf 2 >>= fun c -> return (CHAR c) } + { CHAR(char_for_decimal_code lexbuf 2) } + | "\'\\" 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] "\'" + { CHAR(char_for_octal_code lexbuf 3) } | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" - { return (CHAR (char_for_hexadecimal_code lexbuf 3)) } + { CHAR(char_for_hexadecimal_code lexbuf 3) } | "\'" ("\\" [^ '#'] as esc) - { fail lexbuf (Illegal_escape (esc, None)) } + { error lexbuf (Illegal_escape (esc, None)) } + | "\'\'" + { error lexbuf Empty_character_literal } | "(*" - { let start_loc = Location.curr lexbuf in - state.comment_start_loc <- [start_loc]; - Buffer.reset state.buffer; - comment state lexbuf >>= fun end_loc -> - let s = Buffer.contents state.buffer in - Buffer.reset state.buffer; - return (COMMENT (s, { start_loc with - Location.loc_end = end_loc.Location.loc_end })) + { let s, loc = wrap_comment_lexer comment lexbuf in + COMMENT (s, loc) } + | "(**" + { let s, loc = wrap_comment_lexer comment lexbuf in + if !handle_docstrings then + DOCSTRING (Docstrings.docstring s loc) + else + COMMENT ("*" ^ s, loc) } + | "(**" (('*'+) as stars) + { let s, loc = + wrap_comment_lexer + (fun lexbuf -> + store_string ("*" ^ stars); + comment lexbuf) + lexbuf + in + COMMENT (s, loc) } | "(*)" - { let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Comment_start; - state.comment_start_loc <- [loc]; - Buffer.reset state.buffer; - comment state lexbuf >>= fun end_loc -> - let s = Buffer.contents state.buffer in - Buffer.reset state.buffer; - return (COMMENT (s, { loc with Location.loc_end = end_loc.Location.loc_end })) - } + { if !print_warnings then + Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start; + let s, loc = wrap_comment_lexer comment lexbuf in + COMMENT (s, loc) } + | "(*" (('*'*) as stars) "*)" + { if !handle_docstrings && stars="" then + (* (**) is an empty docstring *) + DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf)) + else + COMMENT (stars, Location.curr lexbuf) } | "*)" { let loc = Location.curr lexbuf in Location.prerr_warning loc Warnings.Comment_not_end; lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; let curpos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 }; - return STAR + STAR } - | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")? - [^ '\010' '\013'] * newline - { update_loc lexbuf name (int_of_string num) true 0; - token state lexbuf + | "#" + { let at_beginning_of_line pos = (pos.pos_cnum = pos.pos_bol) in + if not (at_beginning_of_line lexbuf.lex_start_p) + then HASH + else try directive lexbuf with Failure _ -> HASH } - | "#" { return HASH } - | "&" { return AMPERSAND } - | "&&" { return AMPERAMPER } - | "`" { return BACKQUOTE } - | "\'" { return QUOTE } - | "(" { return LPAREN } - | ")" { return RPAREN } - | "*" { return STAR } - | "," { return COMMA } - | "->" { return MINUSGREATER } - | "." { return DOT } - | "." (dotsymbolchar symbolchar* as op) { return (DOTOP op) } - | ".." { return DOTDOT } - | ":" { return COLON } - | "::" { return COLONCOLON } - | ":=" { return COLONEQUAL } - | ":>" { return COLONGREATER } - | ";" { return SEMI } - | ";;" { return SEMISEMI } - | "<" { return LESS } - | "<-" { return LESSMINUS } - | "=" { return EQUAL } - | "[" { return LBRACKET } - | "[|" { return LBRACKETBAR } - | "[<" { return LBRACKETLESS } - | "[>" { return LBRACKETGREATER } - | "]" { return RBRACKET } - | "{" { return LBRACE } - | "{<" { return LBRACELESS } - | "|" { return BAR } - | "||" { return BARBAR } - | "|]" { return BARRBRACKET } - | ">" { return GREATER } - | ">]" { return GREATERRBRACKET } - | "}" { return RBRACE } - | ">}" { return GREATERRBRACE } - | "[@" { return LBRACKETAT } - | "[@@" { return LBRACKETATAT } - | "[@@@" { return LBRACKETATATAT } - | "[%" { return LBRACKETPERCENT } - | "[%%" { return LBRACKETPERCENTPERCENT } - | "!" { return BANG } - | "!=" { return (INFIXOP0 "!=") } - | "+" { return PLUS } - | "+." { return PLUSDOT } - | "+=" { return PLUSEQ } - | "-" { return MINUS } - | "-." { return MINUSDOT } + | "&" { AMPERSAND } + | "&&" { AMPERAMPER } + | "`" { BACKQUOTE } + | "\'" { QUOTE } + | "(" { LPAREN } + | ")" { RPAREN } + | "*" { STAR } + | "," { COMMA } + | "->" { MINUSGREATER } + | "." { DOT } + | ".." { DOTDOT } + | "." (dotsymbolchar symbolchar* as op) { DOTOP op } + | ":" { COLON } + | "::" { COLONCOLON } + | ":=" { COLONEQUAL } + | ":>" { COLONGREATER } + | ";" { SEMI } + | ";;" { SEMISEMI } + | "<" { LESS } + | "<-" { LESSMINUS } + | "=" { EQUAL } + | "[" { LBRACKET } + | "[|" { LBRACKETBAR } + | "[<" { LBRACKETLESS } + | "[>" { LBRACKETGREATER } + | "]" { RBRACKET } + | "{" { LBRACE } + | "{<" { LBRACELESS } + | "|" { BAR } + | "||" { BARBAR } + | "|]" { BARRBRACKET } + | ">" { GREATER } + | ">]" { GREATERRBRACKET } + | "}" { RBRACE } + | ">}" { GREATERRBRACE } + | "[@" { LBRACKETAT } + | "[@@" { LBRACKETATAT } + | "[@@@" { LBRACKETATATAT } + | "[%" { LBRACKETPERCENT } + | "[%%" { LBRACKETPERCENTPERCENT } + | "!" { BANG } + | "!=" { INFIXOP0 "!=" } + | "+" { PLUS } + | "+." { PLUSDOT } + | "+=" { PLUSEQ } + | "-" { MINUS } + | "-." { MINUSDOT } | "!" symbolchar_or_hash + as op - { return (PREFIXOP op) } + { PREFIXOP op } | ['~' '?'] symbolchar_or_hash + as op - { return (PREFIXOP op) } - | ['=' '<' '|' '&' '$' '>'] symbolchar * as op - { return (keyword_or state op - (INFIXOP0 op)) } + { PREFIXOP op } + | ['=' '<' '>' '|' '&' '$'] symbolchar * as op + { INFIXOP0 op } | ['@' '^'] symbolchar * as op - { return (INFIXOP1 op) } + { INFIXOP1 op } | ['+' '-'] symbolchar * as op - { return (INFIXOP2 op) } + { INFIXOP2 op } | "**" symbolchar * as op - { return (INFIXOP4 op) } - | '%' { return PERCENT } + { INFIXOP4 op } + | '%' { PERCENT } | ['*' '/' '%'] symbolchar * as op - { return (INFIXOP3 op) } - (* Old style js_of_ocaml support is implemented by generating a custom token *) + { INFIXOP3 op } | '#' symbolchar_or_hash + as op - { return (try Hashtbl.find state.keywords op - with Not_found -> HASHOP op) } + { HASHOP op } | "let" kwdopchar dotsymbolchar * as op - { return (LETOP op) } + { LETOP op } | "and" kwdopchar dotsymbolchar * as op - { return (ANDOP op) } - | eof { return EOF } - - | _ as illegal_char - { fail lexbuf (Illegal_character illegal_char) } - -and comment state = parse + { ANDOP op } + | eof { EOF } + | (_ as illegal_char) + { error lexbuf (Illegal_character illegal_char) } + +and directive = parse + | ([' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"") as directive) + [^ '\010' '\013'] * + { + match int_of_string num with + | exception _ -> + (* PR#7165 *) + let explanation = "line number out of range" in + error lexbuf (Invalid_directive ("#" ^ directive, Some explanation)) + | line_num -> + (* Documentation says that the line number should be + positive, but we have never guarded against this and it + might have useful hackish uses. *) + update_loc lexbuf (Some name) (line_num - 1) true 0; + token lexbuf + } +and comment = parse "(*" - { state.comment_start_loc <- (Location.curr lexbuf) :: state.comment_start_loc; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - comment state lexbuf - } + { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; + store_lexeme lexbuf; + comment lexbuf + } | "*)" - { match state.comment_start_loc with + { match !comment_start_loc with | [] -> assert false - | [_] -> state.comment_start_loc <- []; return (Location.curr lexbuf) - | _ :: l -> state.comment_start_loc <- l; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - comment state lexbuf + | [_] -> comment_start_loc := []; Location.curr lexbuf + | _ :: l -> comment_start_loc := l; + store_lexeme lexbuf; + comment lexbuf } | "\"" { - state.string_start_loc <- Location.curr lexbuf; - Buffer.add_char state.buffer '\"'; - let buffer = state.buffer in - state.buffer <- Buffer.create 15; - (catch (string state lexbuf) (fun e l -> match e with - | Unterminated_string -> - begin match state.comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev state.comment_start_loc) in - state.comment_start_loc <- []; - fail_loc (Unterminated_string_in_comment (start, l)) loc - end - | e -> fail_loc e l - ) - ) >>= fun _loc -> - state.string_start_loc <- Location.none; - Buffer.add_string buffer (String.escaped (Buffer.contents state.buffer)); - state.buffer <- buffer; - Buffer.add_char state.buffer '\"'; - comment state lexbuf } - | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|" - { - state.string_start_loc <- Location.curr lexbuf; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - (catch (quoted_string delim state lexbuf) (fun e l -> match e with - | Unterminated_string -> - begin match state.comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev state.comment_start_loc) in - state.comment_start_loc <- []; - fail_loc (Unterminated_string_in_comment (start, l)) loc - end - | e -> fail_loc e l - ) - ) >>= fun _loc -> - state.string_start_loc <- Location.none; - Buffer.add_char state.buffer '|'; - Buffer.add_string state.buffer delim; - Buffer.add_char state.buffer '}'; - comment state lexbuf } - + string_start_loc := Location.curr lexbuf; + store_string_char '\"'; + is_in_string := true; + let _loc = try string lexbuf + with Error (Unterminated_string, str_start) -> + match !comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + error_loc loc (Unterminated_string_in_comment (start, str_start)) + in + is_in_string := false; + store_string_char '\"'; + comment lexbuf } + | "{" ('%' '%'? extattrident blank*)? (ident_ext? as raw_delim) "|" + { match lax_delim raw_delim with + | None -> store_lexeme lexbuf; comment lexbuf + | Some delim -> + string_start_loc := Location.curr lexbuf; + store_lexeme lexbuf; + is_in_string := true; + let _loc = try quoted_string delim lexbuf + with Error (Unterminated_string, str_start) -> + match !comment_start_loc with + | [] -> assert false + | loc :: _ -> + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + error_loc loc (Unterminated_string_in_comment (start, str_start)) + in + is_in_string := false; + store_string_char '|'; + store_string delim; + store_string_char '}'; + comment lexbuf } | "\'\'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } + { store_lexeme lexbuf; comment lexbuf } | "\'" (newline as nl) "\'" { update_loc lexbuf None 1 false 1; - store_string_char state.buffer '\''; - store_normalized_newline state.buffer nl; - store_string_char state.buffer '\''; - comment state lexbuf + store_string_char '\''; + store_normalized_newline nl; + store_string_char '\''; + comment lexbuf } - | "\'" [^ '\\' '\'' '\010' '\013' ] "'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } + | "\'" [^ '\\' '\'' '\010' '\013' ] "\'" + { store_lexeme lexbuf; comment lexbuf } + | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'" + { store_lexeme lexbuf; comment lexbuf } + | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" + { store_lexeme lexbuf; comment lexbuf } | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } + { store_lexeme lexbuf; comment lexbuf } + | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" + { store_lexeme lexbuf; comment lexbuf } | eof - { match state.comment_start_loc with + { match !comment_start_loc with | [] -> assert false | loc :: _ -> - let start = List.hd (List.rev state.comment_start_loc) in - state.comment_start_loc <- []; - fail_loc (Unterminated_comment start) loc + let start = List.hd (List.rev !comment_start_loc) in + comment_start_loc := []; + error_loc loc (Unterminated_comment start) } | newline as nl { update_loc lexbuf None 1 false 0; - store_normalized_newline state.buffer nl; - comment state lexbuf + store_normalized_newline nl; + comment lexbuf } - | (lowercase | uppercase) identchar * - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } + | ident + { store_lexeme lexbuf; comment lexbuf } | _ - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } + { store_lexeme lexbuf; comment lexbuf } -and string state = parse +and string = parse '\"' - { return lexbuf.lex_start_p } - | '\\' newline ([' ' '\t'] * as space) + { lexbuf.lex_start_p } + | '\\' (newline as nl) ([' ' '\t'] * as space) { update_loc lexbuf None 1 false (String.length space); - string state lexbuf + if in_comment () then begin + store_string_char '\\'; + store_normalized_newline nl; + store_string space; + end; + string lexbuf } - | '\\' ['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] - { Buffer.add_char state.buffer - (char_for_backslash (Lexing.lexeme_char lexbuf 1)); - string state lexbuf } + | '\\' (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) + { store_escaped_char lexbuf (char_for_backslash c); + string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { char_for_decimal_code state lexbuf 1 >>= fun c -> - Buffer.add_char state.buffer c; - string state lexbuf } + { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1); + string lexbuf } + | '\\' 'o' ['0'-'7'] ['0'-'7'] ['0'-'7'] + { store_escaped_char lexbuf (char_for_octal_code lexbuf 2); + string lexbuf } | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] - { Buffer.add_char state.buffer (char_for_hexadecimal_code lexbuf 2); - string state lexbuf } + { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2); + string lexbuf } | '\\' 'u' '{' hex_digit+ '}' - { store_escaped_uchar state lexbuf (uchar_for_uchar_escape lexbuf); - string state lexbuf } + { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf); + string lexbuf } | '\\' _ - { if in_comment state - then string state lexbuf - else begin + { if not (in_comment ()) then begin (* Should be an error, but we are very lax. - fail (Illegal_escape (Lexing.lexeme lexbuf), - (Location.curr lexbuf) + error lexbuf (Illegal_escape (Lexing.lexeme lexbuf, None)) *) let loc = Location.curr lexbuf in Location.prerr_warning loc Warnings.Illegal_backslash; - Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0); - Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 1); - string state lexbuf - end + end; + store_lexeme lexbuf; + string lexbuf } | newline as nl { update_loc lexbuf None 1 false 0; - store_normalized_newline state.buffer nl; - string state lexbuf + store_normalized_newline nl; + string lexbuf } | eof - { let loc = state.string_start_loc in - state.string_start_loc <- Location.none; - fail_loc Unterminated_string loc } - | _ - { Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0); - string state lexbuf } + { is_in_string := false; + error_loc !string_start_loc Unterminated_string } + | (_ as c) + { store_string_char c; + string lexbuf } -and quoted_string delim state = parse +and quoted_string delim = parse | newline as nl { update_loc lexbuf None 1 false 0; - store_normalized_newline state.buffer nl; - quoted_string delim state lexbuf + store_normalized_newline nl; + quoted_string delim lexbuf } | eof - { let loc = state.string_start_loc in - state.string_start_loc <- Location.none; - fail_loc Unterminated_string loc } - | "|" lowercase* "}" + { is_in_string := false; + error_loc !string_start_loc Unterminated_string } + | "|" (ident_ext? as raw_edelim) "}" { - let edelim = Lexing.lexeme lexbuf in - let edelim = String.sub edelim ~pos:1 ~len:(String.length edelim - 2) in - if delim = edelim then return lexbuf.lex_start_p - else (Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - quoted_string delim state lexbuf) + let edelim = validate_encoding lexbuf raw_edelim in + if delim = edelim then lexbuf.lex_start_p + else (store_lexeme lexbuf; quoted_string delim lexbuf) } - | _ - { Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0); - quoted_string delim state lexbuf } + | (_ as c) + { store_string_char c; + quoted_string delim lexbuf } -and skip_sharp_bang state = parse +and skip_hash_bang = parse | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" - { update_loc lexbuf None 3 false 0; token state lexbuf } + { update_loc lexbuf None 3 false 0 } | "#!" [^ '\n']* '\n' - { update_loc lexbuf None 1 false 0; token state lexbuf } - | "" { token state lexbuf } + { update_loc lexbuf None 1 false 0 } + | "" { () } { - type comment = string * Location.t - (* preprocessor support not implemented, not compatible with monadic - interface *) + let token_with_comments lexbuf = + match !preprocessor with + | None -> token lexbuf + | Some (_init, preprocess) -> preprocess token lexbuf + + type newline_state = + | NoLine (* There have been no blank lines yet. *) + | NewLine + (* There have been no blank lines, and the previous + token was a newline. *) + | BlankLine (* There have been blank lines. *) + + type doc_state = + | Initial (* There have been no docstrings yet *) + | After of docstring list + (* There have been docstrings, none of which were + preceded by a blank line *) + | Before of docstring list * docstring list * docstring list + (* There have been docstrings, some of which were + preceded by a blank line *) + + and docstring = Docstrings.docstring + + let token lexbuf = + let post_pos = lexeme_end_p lexbuf in + let attach lines docs pre_pos = + let open Docstrings in + match docs, lines with + | Initial, _ -> () + | After a, (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_pre_docstrings pre_pos a; + | After a, BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_pre_extra_docstrings pre_pos (List.rev a) + | Before(a, f, b), (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos + (List.rev_append f (List.rev b)); + set_floating_docstrings pre_pos (List.rev f); + set_pre_extra_docstrings pre_pos (List.rev a); + set_pre_docstrings pre_pos b + | Before(a, f, b), BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos + (List.rev_append f (List.rev b)); + set_floating_docstrings pre_pos + (List.rev_append f (List.rev b)); + set_pre_extra_docstrings pre_pos (List.rev a) + in + let rec loop lines docs lexbuf = + match token_with_comments lexbuf with + | COMMENT (s, loc) -> + add_comment (s, loc); + let lines' = + match lines with + | NoLine -> NoLine + | NewLine -> NoLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | EOL -> + let lines' = + match lines with + | NoLine -> NewLine + | NewLine -> BlankLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | DOCSTRING doc -> + Docstrings.register doc; + add_docstring_comment doc; + let docs' = + if Docstrings.docstring_body doc = "/*" then + match docs with + | Initial -> Before([], [doc], []) + | After a -> Before (a, [doc], []) + | Before(a, f, b) -> Before(a, doc :: b @ f, []) + else + match docs, lines with + | Initial, (NoLine | NewLine) -> After [doc] + | Initial, BlankLine -> Before([], [], [doc]) + | After a, (NoLine | NewLine) -> After (doc :: a) + | After a, BlankLine -> Before (a, [], [doc]) + | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) + | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) + in + loop NoLine docs' lexbuf + | tok -> + attach lines docs (lexeme_start_p lexbuf); + tok + in + loop NoLine Initial lexbuf + + let init () = + is_in_string := false; + comment_start_loc := []; + comment_list := []; + match !preprocessor with + | None -> () + | Some (init, _preprocess) -> init () + + let set_preprocessor init preprocess = + escaped_newlines := true; + preprocessor := Some (init, preprocess) - let rec token_without_comments state lexbuf = - token state lexbuf >>= function - | COMMENT _ -> - token_without_comments state lexbuf - | tok -> return tok } diff --git a/src/ocaml/typing/btype.ml b/src/ocaml/typing/btype.ml index 4cc0cd4d4..df84fdb3f 100644 --- a/src/ocaml/typing/btype.ml +++ b/src/ocaml/typing/btype.ml @@ -97,6 +97,8 @@ end let generic_level = Ident.highest_scope let lowest_level = Ident.lowest_scope +let pivot_level = 2 * lowest_level - 1 + (* pivot_level - lowest_level < lowest_level *) (**** leveled type pool ****) (* This defines a stack of pools of type nodes indexed by the level @@ -777,7 +779,7 @@ let instance_variable_type label sign = | (_, _, ty) -> ty | exception Not_found -> assert false -<<<<<<< + (**********************************) (* Utilities for level-marking *) (**********************************) @@ -806,7 +808,7 @@ let type_iterators = let it_type_expr it ty = if try_mark_node ty then it.it_do_type_expr it ty in - {type_iterators with it_type_expr} + {type_iterators_without_type_expr with it_type_expr} (* Remove marks from a type. *) @@ -834,12 +836,7 @@ let unmark_class_signature sign = unmark_type sign.csig_self_row; Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars; Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths -======= ->>>>>>> - (**********) - (* Misc *) - (**********) (**** Type information getter ****) diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml index 8c2d88559..3dc8dae2e 100644 --- a/src/ocaml/typing/env.ml +++ b/src/ocaml/typing/env.ml @@ -4183,13 +4183,22 @@ let cleanup_functor_caches ~stamp = Stamped_hashtable.backtrack !stamped_changelog ~stamp let cleanup_usage_tables ~stamp = -<<<<<<< Stamped_hashtable.backtrack value_declarations_changelog ~stamp; Stamped_hashtable.backtrack type_declarations_changelog ~stamp; Stamped_hashtable.backtrack module_declarations_changelog ~stamp; Stamped_hashtable.backtrack used_constructors_changelog ~stamp; Stamped_hashtable.backtrack used_labels_changelog ~stamp -======= + +let () = + Location.register_error_of_exn + (function + | Error err -> + let loc = + match err with + | Missing_module (loc, _, _) + | Illegal_value_name (loc, _) + | Lookup_error(loc, _, _) -> loc + in let error_of_printer = if loc = Location.none then Location.error_of_printer_file @@ -4202,4 +4211,3 @@ let cleanup_usage_tables ~stamp = let report_lookup_error = Format_doc.compat2 report_lookup_error_doc let report_error = Format_doc.compat report_error_doc ->>>>>>> diff --git a/src/ocaml/typing/errortrace_report.ml b/src/ocaml/typing/errortrace_report.ml new file mode 100644 index 000000000..03012f7d8 --- /dev/null +++ b/src/ocaml/typing/errortrace_report.ml @@ -0,0 +1,590 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Trace-specific printing *) + +(* A configuration type that controls which trace we print. This could be + exposed, but we instead expose three separate + [{unification,equality,moregen}] functions. This also lets us + give the unification case an extra optional argument without adding it to the + equality and moregen cases. *) +type 'variety trace_format = + | Unification : Errortrace.unification trace_format + | Equality : Errortrace.comparison trace_format + | Moregen : Errortrace.comparison trace_format + +let incompatibility_phrase (type variety) : variety trace_format -> string = + function + | Unification -> "is not compatible with type" + | Equality -> "is not equal to type" + | Moregen -> "is not compatible with type" + +(* Print a unification error *) +open Out_type +open Format_doc +module Fmt = Format_doc +module Style = Misc.Style + +type 'a diff = 'a Out_type.diff = Same of 'a | Diff of 'a * 'a + +let trees_of_trace mode = + List.map (Errortrace.map_diff (trees_of_type_expansion mode)) + +let rec trace fst txt ppf = function + | {Errortrace.got; expected} :: rem -> + if not fst then fprintf ppf "@,"; + fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" + pp_type_expansion got txt pp_type_expansion expected + (trace false txt) rem + | _ -> () + +type printing_status = + | Discard + | Keep + | Optional_refinement + (** An [Optional_refinement] printing status is attributed to trace + elements that are focusing on a new subpart of a structural type. + Since the whole type should have been printed earlier in the trace, + we only print those elements if they are the last printed element + of a trace, and there is no explicit explanation for the + type error. + *) + +let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; + expected = {ty = t2; expanded = t2'} } = + if Btype.is_constr_row ~allow_ident:true t1' + || Btype.is_constr_row ~allow_ident:true t2' + then Discard + else if same_path t1 t1' && same_path t2 t2' then Optional_refinement + else Keep + +let printing_status = function + | Errortrace.Diff d -> diff_printing_status d + | Errortrace.Escape {kind = Constraint} -> Keep + | _ -> Keep + +(** Flatten the trace and remove elements that are always discarded + during printing *) + +(* Takes [printing_status] to change behavior for [Subtype] *) +let prepare_any_trace printing_status tr = + let clean_trace x l = match printing_status x with + | Keep -> x :: l + | Optional_refinement when l = [] -> [x] + | Optional_refinement | Discard -> l + in + match tr with + | [] -> [] + | elt :: rem -> elt :: List.fold_right clean_trace rem [] + +let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.map f tr) + +(** Keep elements that are [Diff _ ] and split the the last element if it is + optionally elidable, require a prepared trace *) +let rec filter_trace = function + | [] -> [], None + | [Errortrace.Diff d as elt] + when printing_status elt = Optional_refinement -> [], Some d + | Errortrace.Diff d :: rem -> + let filtered, last = filter_trace rem in + d :: filtered, last + | _ :: rem -> filter_trace rem + +let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = + match Types.get_desc expanded with + Tvariant _ | Tobject _ when compact -> + Variable_names.reserve ty; Errortrace.{ty; expanded = ty} + | _ -> prepare_expansion ty_exp + +let print_path p = + Fmt.dprintf "%a" !Oprint.out_ident (namespaced_tree_of_path Type p) + +let print_tag ppf s = Style.inline_code ppf ("`" ^ s) + +let print_tags ppf tags = + Fmt.(pp_print_list ~pp_sep:comma) print_tag ppf tags + +let is_unit env ty = + match Types.get_desc (Ctype.expand_head env ty) with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + +let unifiable env ty1 ty2 = + let snap = Btype.snapshot () in + let res = + try Ctype.unify env ty1 ty2; true + with Ctype.Unify _ -> false + in + Btype.backtrack snap; + res + +let explanation_diff env t3 t4 = + match Types.get_desc t3, Types.get_desc t4 with + | Tarrow (_, ty1, ty2, _), _ + when is_unit env ty1 && unifiable env ty2 t4 -> + Some (doc_printf + "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" + Style.inline_code "()" + ) + | _, Tarrow (_, ty1, ty2, _) + when is_unit env ty1 && unifiable env t3 ty2 -> + Some (doc_printf + "@,@[@{Hint@}: Did you forget to wrap the expression using \ + %a?@]" + Style.inline_code "fun () ->" + ) + | _ -> + None + +let explain_fixed_row_case = function + | Errortrace.Cannot_be_closed -> doc_printf "it cannot be closed" + | Errortrace.Cannot_add_tags tags -> + doc_printf "it may not allow the tag(s) %a" + print_tags tags + +let pp_path ppf p = + Style.as_inline_code Printtyp.Doc.path ppf p + +let explain_fixed_row pos expl = match expl with + | Types.Fixed_private -> + doc_printf "The %a variant type is private" Errortrace.print_pos pos + | Types.Univar x -> + Variable_names.reserve x; + doc_printf "The %a variant type is bound to the universal type variable %a" + Errortrace.print_pos pos + (Style.as_inline_code type_expr_with_reserved_names) x + | Types.Reified p -> + doc_printf "The %a variant type is bound to %a" + Errortrace.print_pos pos + (Style.as_inline_code + (fun ppf p -> + Internal_names.add p; + print_path p ppf)) + p + | Types.Rigid -> Format_doc.Doc.empty + +let explain_variant (type variety) : variety Errortrace.variant -> _ = function + (* Common *) + | Errortrace.Incompatible_types_for s -> + Some(doc_printf "@,Types for tag %a are incompatible" + print_tag s + ) + (* Unification *) + | Errortrace.No_intersection -> + Some(doc_printf "@,These two variant types have no intersection") + | Errortrace.No_tags(pos,fields) -> Some( + doc_printf + "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" + Errortrace.print_pos pos + print_tags (List.map fst fields) + ) + | Errortrace.Fixed_row (pos, + k, + (Univar _ | Reified _ | Fixed_private as e)) -> + Some ( + doc_printf "@,@[%a,@ %a@]" pp_doc (explain_fixed_row pos e) + pp_doc (explain_fixed_row_case k) + ) + | Errortrace.Fixed_row (_,_, Rigid) -> + (* this case never happens *) + None + (* Equality & Moregen *) + | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( + doc_printf + "@,@[The tag %a is guaranteed to be present in the %a variant type,\ + @ but not in the %a@]" + print_tag s + Errortrace.print_pos (Errortrace.swap_position pos) + Errortrace.print_pos pos + ) + | Errortrace.Openness pos -> + Some(doc_printf "@,The %a variant type is open and the %a is not" + Errortrace.print_pos pos + Errortrace.print_pos (Errortrace.swap_position pos)) + +let explain_escape pre = function + | Errortrace.Univ u -> + Variable_names.reserve u; + Some( + doc_printf "%a@,The universal variable %a would escape its scope" + pp_doc pre + (Style.as_inline_code type_expr_with_reserved_names) u + ) + | Errortrace.Constructor p -> Some( + doc_printf + "%a@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + pp_doc pre pp_path p + ) + | Errortrace.Module_type p -> Some( + doc_printf + "%a@,@[The module type@;<1 2>%a@ would escape its scope@]" + pp_doc pre pp_path p + ) + | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> + Variable_names.reserve t; + Some( + doc_printf "%a@ @[This instance of %a is ambiguous:@ %s@]" + pp_doc pre + (Style.as_inline_code type_expr_with_reserved_names) t + "it would escape the scope of its equation" + ) + | Errortrace.Self -> + Some (doc_printf "%a@,Self type cannot escape its class" pp_doc pre) + | Errortrace.Constraint -> + None + +let explain_object (type variety) : variety Errortrace.obj -> _ = function + | Errortrace.Missing_field (pos,f) -> Some( + doc_printf "@,@[The %a object type has no method %a@]" + Errortrace.print_pos pos Style.inline_code f + ) + | Errortrace.Abstract_row pos -> Some( + doc_printf + "@,@[The %a object type has an abstract row, it cannot be closed@]" + Errortrace.print_pos pos + ) + | Errortrace.Self_cannot_be_closed -> + Some (doc_printf + "@,Self type cannot be unified with a closed object type" + ) + +let explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = + Variable_names.reserve diff.got; + Variable_names.reserve diff.expected; + doc_printf "@,@[The method %a has type@ %a,@ \ + but the expected method type was@ %a@]" + Style.inline_code name + (Style.as_inline_code type_expr_with_reserved_names) diff.got + (Style.as_inline_code type_expr_with_reserved_names) diff.expected + + +let explain_label_mismatch ~got ~expected = + let quoted_label ppf l = Style.inline_code ppf (Asttypes.string_of_label l) in + match got, expected with + | Asttypes.Nolabel, Asttypes.(Labelled _ | Optional _ ) -> + doc_printf "@,@[A label@ %a@ was expected@]" + quoted_label expected + | Asttypes.(Labelled _|Optional _), Asttypes.Nolabel -> + doc_printf + "@,@[The first argument is labeled@ %a,@ \ + but an unlabeled argument was expected@]" + quoted_label got + | Asttypes.Labelled g, Asttypes.Optional e when g = e -> + doc_printf + "@,@[The label@ %a@ was expected to be optional@]" + quoted_label got + | Asttypes.Optional g, Asttypes.Labelled e when g = e -> + doc_printf + "@,@[The label@ %a@ was expected to not be optional@]" + quoted_label got + | Asttypes.(Labelled _ | Optional _), Asttypes.(Labelled _ | Optional _) -> + doc_printf "@,@[Labels %a@ and@ %a do not match@]" + quoted_label got + quoted_label expected + | Asttypes.Nolabel, Asttypes.Nolabel -> + (* Two empty labels cannot be mismatched*) + assert false + + +let explain_first_class_module = function + | Errortrace.Package_cannot_scrape p -> Some( + doc_printf "@,@[The module alias %a could not be expanded@]" + pp_path p + ) + | Errortrace.Package_inclusion pr -> + Some(doc_printf "@,@[%a@]" Fmt.pp_doc pr) + | Errortrace.Package_coercion pr -> + Some(doc_printf "@,@[%a@]" Fmt.pp_doc pr) + +let explanation (type variety) intro prev env + : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function + | Errortrace.Diff {got; expected} -> + explanation_diff env got.expanded expected.expanded + | Errortrace.Escape {kind; context} -> + let pre = + match context, kind, prev with + | Some ctx, _, _ -> + Variable_names.reserve ctx; + doc_printf "@[%a@;<1 2>%a@]" pp_doc intro + (Style.as_inline_code type_expr_with_reserved_names) ctx + | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> + explain_incompatible_fields name diff + | _ -> Format_doc.Doc.empty + in + explain_escape pre kind + | Errortrace.Incompatible_fields { name; diff} -> + Some(explain_incompatible_fields name diff) + | Errortrace.Function_label_mismatch diff -> + Some(explain_label_mismatch ~got:diff.got ~expected:diff.expected) + | Errortrace.Variant v -> + explain_variant v + | Errortrace.Obj o -> + explain_object o + | Errortrace.First_class_module fm -> + explain_first_class_module fm + | Errortrace.Rec_occur(x,y) -> + add_type_to_preparation x; + add_type_to_preparation y; + begin match Types.get_desc x with + | Tvar _ | Tunivar _ -> + Some( + doc_printf "@,@[The type variable %a occurs inside@ %a@]" + (Style.as_inline_code prepared_type_expr) x + (Style.as_inline_code prepared_type_expr) y + ) + | _ -> + (* We had a delayed unification of the type variable with + a non-variable after the occur check. *) + Some Format_doc.Doc.empty + (* There is no need to search further for an explanation, but + we don't want to print a message of the form: + {[ The type int occurs inside int list -> 'a |} + *) + end + +let mismatch intro env trace = + Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) + +let warn_on_missing_def env ppf t = + match Types.get_desc t with + | Tconstr (p,_,_) -> + begin match Env.find_type p env with + | exception Not_found -> + fprintf ppf + "@,@[Type %a is abstract because@ no corresponding\ + @ cmi file@ was found@ in path.@]" pp_path p + | { type_manifest = Some _; _ } -> () + | { type_manifest = None; _ } as decl -> + match Btype.type_origin decl with + | Rec_check_regularity -> + fprintf ppf + "@,@[Type %a was considered abstract@ when checking\ + @ constraints@ in this@ recursive type definition.@]" + pp_path p + | Definition | Existential _ -> () + end + | _ -> () + +let prepare_expansion_head empty_tr = function + | Errortrace.Diff d -> + Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) + | _ -> None + +let head_error_printer mode txt_got txt_but = function + | None -> Format_doc.Doc.empty + | Some d -> + let d = Errortrace.map_diff (trees_of_type_expansion mode) d in + doc_printf "%a@;<1 2>%a@ %a@;<1 2>%a" + pp_doc txt_got pp_type_expansion d.Errortrace.got + pp_doc txt_but pp_type_expansion d.Errortrace.expected + +let warn_on_missing_defs env ppf = function + | None -> () + | Some Errortrace.{got = {ty=te1; expanded=_}; + expected = {ty=te2; expanded=_} } -> + warn_on_missing_def env ppf te1; + warn_on_missing_def env ppf te2 + +(* [subst] comes out of equality, and is [[]] otherwise *) +let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = + reset (); + (* We want to substitute in the opposite order from [Eqtype] *) + Variable_names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); + let tr = + prepare_trace + (fun ty_exp -> + Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) + tr + in + match tr with + | [] -> assert false + | (elt :: tr) as full_trace -> + with_labels (not !Clflags.classic) (fun () -> + let tr, last = filter_trace tr in + let head = prepare_expansion_head (tr=[] && last=None) elt in + let tr = List.map (Errortrace.map_diff prepare_expansion) tr in + let last = Option.map (Errortrace.map_diff prepare_expansion) last in + let head_error = head_error_printer mode txt1 txt2 head in + let tr = trees_of_trace mode tr in + let last = + Option.map (Errortrace.map_diff (trees_of_type_expansion mode)) last in + let mis = mismatch txt1 env full_trace in + let tr = match mis, last with + | None, Some elt -> tr @ [elt] + | Some _, _ | _, None -> tr + in + fprintf ppf + "@[\ + @[%a%a@]%a%a\ + @]" + pp_doc head_error + pp_doc ty_expect_explanation + (trace false (incompatibility_phrase trace_format)) tr + (pp_print_option pp_doc) mis; + if env <> Env.empty + then warn_on_missing_defs env ppf head; + Internal_names.print_explanations env ppf; + Ident_conflicts.err_print ppf + ) + +let report_error trace_format ppf mode env tr + ?(subst = []) + ?(type_expected_explanation = Fmt.Doc.empty) + txt1 txt2 = + wrap_printing_env ~error:true env (fun () -> + error trace_format mode subst env tr txt1 ppf txt2 + type_expected_explanation) + +let unification + ppf env ({trace} : Errortrace.unification_error) = + report_error Unification ppf Type env + ?subst:None trace + +let equality + ppf mode env ({subst; trace} : Errortrace.equality_error) = + report_error Equality ppf mode env + ~subst ?type_expected_explanation:None trace + +let moregen + ppf mode env ({trace} : Errortrace.moregen_error) = + report_error Moregen ppf mode env + ?subst:None ?type_expected_explanation:None trace + +let comparison ppf mode env = function + | Errortrace.Equality_error error -> equality ppf mode env error + | Errortrace.Moregen_error error -> moregen ppf mode env error + +module Subtype = struct + (* There's a frustrating amount of code duplication between this module and + the outside code, particularly in [prepare_trace] and [filter_trace]. + Unfortunately, [Subtype] is *just* similar enough to have code duplication, + while being *just* different enough (it's only [Diff]) for the abstraction + to be nonobvious. Someday, perhaps... *) + + let printing_status = function + | Errortrace.Subtype.Diff d -> diff_printing_status d + + let prepare_unification_trace = prepare_trace + + let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.Subtype.map f tr) + + let trace filter_trace get_diff fst keep_last txt ppf tr = + with_labels (not !Clflags.classic) (fun () -> + match tr with + | elt :: tr' -> + let diffed_elt = get_diff elt in + let tr, last = filter_trace tr' in + let tr = match keep_last, last with + | true, Some last -> tr @ [last] + | _ -> tr + in + let tr = + trees_of_trace Type + @@ List.map (Errortrace.map_diff prepare_expansion) tr in + let tr = + match fst, diffed_elt with + | true, Some elt -> elt :: tr + | _, _ -> tr + in + trace fst txt ppf tr + | _ -> () + ) + + let rec filter_subtype_trace = function + | [] -> [], None + | [Errortrace.Subtype.Diff d as elt] + when printing_status elt = Optional_refinement -> + [], Some d + | Errortrace.Subtype.Diff d :: rem -> + let ftr, last = filter_subtype_trace rem in + d :: ftr, last + + let unification_get_diff = function + | Errortrace.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + | _ -> None + + let subtype_get_diff = function + | Errortrace.Subtype.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + + let error + ppf + env + (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) + txt1 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tr_sub = prepare_trace prepare_expansion tr_sub in + let tr_unif = prepare_unification_trace prepare_expansion tr_unif in + let keep_first = match tr_unif with + | [Obj _ | Variant _ | Escape _ ] | [] -> true + | _ -> false in + fprintf ppf "@[%a" + (trace filter_subtype_trace subtype_get_diff true keep_first txt1) + tr_sub; + if tr_unif = [] then fprintf ppf "@]" else + let mis = mismatch (doc_printf "Within this type") env tr_unif in + fprintf ppf "%a%a%t@]" + (trace filter_trace unification_get_diff false + (mis = None) "is not compatible with type") tr_unif + (pp_print_option pp_doc) mis + Ident_conflicts.err_print + ) +end + +let subtype = Subtype.error + +let quoted_ident ppf t = + Style.as_inline_code !Oprint.out_ident ppf t + +let type_path_expansion ppf = function + | Same p -> quoted_ident ppf p + | Diff(p,p') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + quoted_ident p + quoted_ident p' + +let trees_of_type_path_expansion (tp,tp') = + let path_tree = namespaced_tree_of_path Type in + if Path.same tp tp' then Same(path_tree tp) else + Diff(path_tree tp, path_tree tp) + +let type_path_list ppf l = + Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.pp_print_break ppf 2 0) + type_path_expansion ppf l + +let ambiguous_type ppf env tp0 tpl txt1 txt2 txt3 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tp0 = trees_of_type_path_expansion tp0 in + match tpl with + [] -> assert false + | [tp] -> + fprintf ppf + "@[%a@;<1 2>%a@ \ + %a@;<1 2>%a\ + @]" + pp_doc txt1 type_path_expansion (trees_of_type_path_expansion tp) + pp_doc txt3 type_path_expansion tp0 + | _ -> + fprintf ppf + "@[%a@;<1 2>@[%a@]\ + @ %a@;<1 2>%a\ + @]" + pp_doc txt2 type_path_list (List.map trees_of_type_path_expansion tpl) + pp_doc txt3 type_path_expansion tp0) diff --git a/src/ocaml/typing/errortrace_report.mli b/src/ocaml/typing/errortrace_report.mli new file mode 100644 index 000000000..bb6f0ea9e --- /dev/null +++ b/src/ocaml/typing/errortrace_report.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Functions for reporting core level type errors. *) + +open Format_doc + +val ambiguous_type: + formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> + Format_doc.t -> Format_doc.t -> Format_doc.t -> unit + +val unification : + formatter -> + Env.t -> Errortrace.unification_error -> + ?type_expected_explanation:Format_doc.t -> Format_doc.t -> Format_doc.t -> + unit + +val equality : + formatter -> + Out_type.type_or_scheme -> + Env.t -> Errortrace.equality_error -> + Format_doc.t -> Format_doc.t -> + unit + +val moregen : + formatter -> + Out_type.type_or_scheme -> + Env.t -> Errortrace.moregen_error -> + Format_doc.t -> Format_doc.t -> + unit + +val comparison : + formatter -> + Out_type.type_or_scheme -> + Env.t -> Errortrace.comparison_error -> + Format_doc.t -> Format_doc.t -> + unit + +val subtype : + formatter -> + Env.t -> + Errortrace.Subtype.error -> + string -> + unit diff --git a/src/ocaml/typing/ident.ml b/src/ocaml/typing/ident.ml index a26db8b7d..cc9d4e1f6 100644 --- a/src/ocaml/typing/ident.ml +++ b/src/ocaml/typing/ident.ml @@ -142,28 +142,12 @@ let print ~with_scope ppf = function | Global name -> fprintf ppf "%s!" name | Predef { name; stamp = n } -> -<<<<<<< fprintf ppf "%s/%i!" name n -======= - fprintf ppf "%s%s!" name - (if !Clflags.unique_ids then asprintf "/%i" n else "") ->>>>>>> | Local { name; stamp = n } -> -<<<<<<< fprintf ppf "%s/%i" name n -======= - fprintf ppf "%s%s" name - (if !Clflags.unique_ids then asprintf "/%i" n else "") ->>>>>>> | Scoped { name; stamp = n; scope } -> -<<<<<<< fprintf ppf "%s/%i%s" name n - (if with_scope then sprintf "[%i]" scope else "") -======= - fprintf ppf "%s%s%s" name - (if !Clflags.unique_ids then asprintf "/%i" n else "") (if with_scope then asprintf "[%i]" scope else "") ->>>>>>> let print_with_scope ppf id = print ~with_scope:true ppf id diff --git a/src/ocaml/typing/magic_numbers.ml b/src/ocaml/typing/magic_numbers.ml index f5503f000..3362a7494 100644 --- a/src/ocaml/typing/magic_numbers.ml +++ b/src/ocaml/typing/magic_numbers.ml @@ -29,13 +29,13 @@ module Cmi = struct let () = assert (to_version_opt Config.cmi_magic_number <> None) - open Format + open Format_doc module Style = Misc.Style let report_error ppf = function | Not_an_interface filename -> fprintf ppf "%a@ is not a compiled interface" - (Style.as_inline_code Location.print_filename) filename + (Style.as_inline_code Location.Doc.filename) filename | Wrong_version_interface (filename, compiler_magic) -> let program_name = Lib_config.program_name () in begin match to_version_opt compiler_magic with @@ -51,7 +51,7 @@ module Cmi = struct compiler. \n\ This diagnostic is based on the compiled interface file: %a" program_name program_name program_name - Location.print_filename filename + Location.Doc.filename filename | Some version -> fprintf ppf "Compiler version mismatch: this project seems to be compiled with \ @@ -63,11 +63,11 @@ module Cmi = struct This diagnostic is based on the compiled interface file: %a" version program_name (Option.get @@ to_version_opt Config.cmi_magic_number) - program_name Location.print_filename filename + program_name Location.Doc.filename filename end | Corrupted_interface filename -> fprintf ppf "Corrupted compiled interface@ %a" - (Style.as_inline_code Location.print_filename) filename + (Style.as_inline_code Location.Doc.filename) filename let () = Location.register_error_of_exn diff --git a/src/ocaml/typing/out_type.ml b/src/ocaml/typing/out_type.ml new file mode 100644 index 000000000..15e967c8c --- /dev/null +++ b/src/ocaml/typing/out_type.ml @@ -0,0 +1,1973 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compute a spanning tree representation of types *) + +open Misc +open Ctype +open Longident +open Path +open Asttypes +open Types +open Btype +open Outcometree + +module Sig_component_kind = Shape.Sig_component_kind +module Style = Misc.Style + +(* Print a long identifier *) + +module Fmt = Format_doc +open Format_doc + +let longident = Pprintast.Doc.longident + +let () = Env.print_longident := longident + +(* Print an identifier avoiding name collisions *) + +module Out_name = struct + let create x = { printed_name = x } + let print x = x.printed_name +end + +(** Some identifiers may require hiding when printing *) +type bound_ident = { hide:bool; ident:Ident.t } + +(* printing environment for path shortening and naming *) +let printing_env = ref Env.empty + +(* When printing, it is important to only observe the + current printing environment, without reading any new + cmi present on the file system *) +let in_printing_env f = Env.without_cmis f !printing_env + + type namespace = Sig_component_kind.t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value | Constructor | Label -> 5 + (* we do not handle those component *) + + let size = 1 + id Value + + + let pp ppf x = + Fmt.pp_print_string ppf (Shape.Sig_component_kind.to_string x) + + (** The two functions below should never access the filesystem, + and thus use {!in_printing_env} rather than directly + accessing the printing environment *) + let lookup = + let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in + function + | Some Type -> to_lookup Env.find_type_by_name + | Some Module -> to_lookup Env.find_module_by_name + | Some Module_type -> to_lookup Env.find_modtype_by_name + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | None | Some(Value|Extension_constructor|Constructor|Label) -> + fun _ -> raise Not_found + + let location namespace id = + let path = Path.Pident id in + try Some ( + match namespace with + | Some Type -> (in_printing_env @@ Env.find_type path).type_loc + | Some Module -> (in_printing_env @@ Env.find_module path).md_loc + | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc + | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc + | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc + | Some (Extension_constructor|Value|Constructor|Label) | None -> + Location.none + ) with Not_found -> None + + let best_class_namespace = function + | Papply _ | Pdot _ -> Some Module + | Pextra_ty _ -> assert false (* Only in type path *) + | Pident c -> + match location (Some Class) c with + | Some _ -> Some Class + | None -> Some Class_type + +end + +(** {2 Ident conflicts printing} + + Ident conflicts arise when multiple {!Ident.t}s are attributed the same name. + The following module stores the global conflict references and provides the + printing functions for explaining the source of the conflicts. +*) +module Ident_conflicts = struct + module M = String.Map + type explanation = + { kind: namespace; name:string; root_name:string; location:Location.t} + let explanations = ref M.empty + + let add namespace name id = + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = + { kind = namespace; location; name; root_name=Ident.name id} + in + explanations := M.add name explanation !explanations + + let collect_explanation namespace id ~name = + let root_name = Ident.name id in + (* if [name] is of the form "root_name/%d", we register both + [id] and the identifier in scope for [root_name]. + *) + if root_name <> name && not (M.mem name !explanations) then + begin + add namespace name id; + if not (M.mem root_name !explanations) then + (* lookup the identifier in scope with name [root_name] and + add it too + *) + match Namespace.lookup (Some namespace) root_name with + | Pident root_id -> add namespace root_name root_id + | exception Not_found | _ -> () + end + + let pp_explanation ppf r= + Fmt.fprintf ppf "@[%a:@,Definition of %s %a@]" + Location.Doc.loc r.location (Sig_component_kind.to_string r.kind) + Style.inline_code r.name + + let print_located_explanations ppf l = + Fmt.fprintf ppf "@[%a@]" + (Fmt.pp_print_list pp_explanation) l + + let reset () = explanations := M.empty + let list_explanations () = + let c = !explanations in + reset (); + c |> M.bindings |> List.map snd |> List.sort Stdlib.compare + + + let print_toplevel_hint ppf l = + let conj ppf () = Fmt.fprintf ppf " and@ " in + let pp_namespace_plural ppf n = Fmt.fprintf ppf "%as" Namespace.pp n in + let root_names = List.map (fun r -> r.kind, r.root_name) l in + let unique_root_names = List.sort_uniq Stdlib.compare root_names in + let submsgs = Array.make Namespace.size [] in + let () = List.iter (fun (n,_ as x) -> + submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) + ) unique_root_names in + let pp_submsg ppf names = + match names with + | [] -> () + | [namespace, a] -> + Fmt.fprintf ppf + "@,\ + @[<2>@{Hint@}: The %a %a has been defined multiple times@ \ + in@ this@ toplevel@ session.@ \ + Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ + @ Did you try to redefine them?@]" + Namespace.pp namespace + Style.inline_code a Namespace.pp namespace + | (namespace, _) :: _ :: _ -> + Fmt.fprintf ppf + "@,\ + @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ + in@ this@ toplevel@ session.@ \ + Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ + @ Did you try to redefine them?@]" + pp_namespace_plural namespace + Fmt.(pp_print_list ~pp_sep:conj Style.inline_code) + (List.map snd names) + pp_namespace_plural namespace in + Array.iter (pp_submsg ppf) submsgs + + let err_msg () = + let ltop, l = + (* isolate toplevel locations, since they are too imprecise *) + let from_toplevel a = + a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in + List.partition from_toplevel (list_explanations ()) + in + match l, ltop with + | [], [] -> None + | _ -> + Some + (Fmt.doc_printf "%a%a" + print_located_explanations l + print_toplevel_hint ltop + ) + let err_print ppf = Option.iter Fmt.(fprintf ppf "@,%a" pp_doc) (err_msg ()) + + let exists () = M.cardinal !explanations >0 +end + +module Ident_names = struct + +module M = String.Map +module S = String.Set + +let enabled = ref true +let enable b = enabled := b + +(* Names bound in recursive definitions should be considered as bound + in the environment when printing identifiers but not when trying + to find shortest path. + For instance, if we define + [{ + module Avoid__me = struct + type t = A + end + type t = X + type u = [` A of t * t ] + module M = struct + type t = A of [ u | `B ] + type r = Avoid__me.t + end + }] + It is is important that in the definition of [t] that the outer type [t] is + printed as [t/2] reserving the name [t] to the type being defined in the + current recursive definition. + Contrarily, in the definition of [r], one should not shorten the + path [Avoid__me.t] to [r] until the end of the definition of [r]. + The [bound_in_recursion] bridges the gap between those two slightly different + notions of printing environment. +*) +let bound_in_recursion = ref M.empty + +(* When dealing with functor arguments, identity becomes fuzzy because the same + syntactic argument may be represented by different identifiers during the + error processing, we are thus disabling disambiguation on the argument name +*) +let fuzzy = ref S.empty +let with_fuzzy id f = + protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f +let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy + +let with_hidden ids f = + let update m id = M.add (Ident.name id.ident) id.ident m in + let updated = List.fold_left update !bound_in_recursion ids in + protect_refs [ R(bound_in_recursion, updated )] f + +let human_id id index = + (* The identifier with index [k] is the (k+1)-th most recent identifier in + the printing environment. We print them as [name/(k+1)] except for [k=0] + which is printed as [name] rather than [name/1]. + *) + if index = 0 then + Ident.name id + else + let ordinal = index + 1 in + String.concat "/" [Ident.name id; string_of_int ordinal] + +let indexed_name namespace id = + let find namespace id env = match namespace with + | Type -> Env.find_type_index id env + | Module -> Env.find_module_index id env + | Module_type -> Env.find_modtype_index id env + | Class -> Env.find_class_index id env + | Class_type-> Env.find_cltype_index id env + | Value | Extension_constructor | Constructor | Label -> None + in + let index = + match M.find_opt (Ident.name id) !bound_in_recursion with + | Some rec_bound_id -> + (* the identifier name appears in the current group of recursive + definition *) + if Ident.same rec_bound_id id then + Some 0 + else + (* the current recursive definition shadows one more time the + previously existing identifier with the same name *) + Option.map succ (in_printing_env (find namespace id)) + | None -> + in_printing_env (find namespace id) + in + let index = + (* If [index] is [None] at this point, it might indicate that + the identifier id is not defined in the environment, while there + are other identifiers in scope that share the same name. + Currently, this kind of partially incoherent environment happens + within functor error messages where the left and right hand side + have a different views of the environment at the source level. + Printing the source-level by using a default index of `0` + seems like a reasonable compromise in this situation however.*) + Option.value index ~default:0 + in + human_id id index + +let ident_name namespace id = + match namespace, !enabled with + | None, _ | _, false -> Out_name.create (Ident.name id) + | Some namespace, true -> + if fuzzy_id namespace id then Out_name.create (Ident.name id) + else + let name = indexed_name namespace id in + Ident_conflicts.collect_explanation namespace id ~name; + Out_name.create name +end +let ident_name = Ident_names.ident_name + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_stdlib namespace = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match Namespace.lookup namespace s with + | path' -> Path.same path path' + | exception Not_found -> true) + | _ -> false + +let find_double_underscore s = + let len = String.length s in + let rec loop i = + if i + 1 >= len then + None + else if s.[i] = '_' && s.[i + 1] = '_' then + Some i + else + loop (i + 1) + in + loop 0 + +let rec module_path_is_an_alias_of env path ~alias_of = + match Env.find_module path env with + | { md_type = Mty_alias path'; _ } -> + Path.same path' alias_of || + module_path_is_an_alias_of env path' ~alias_of + | _ -> false + | exception Not_found -> false + +(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias + for Foo__bar. This pattern is used by the stdlib. *) +let rec rewrite_double_underscore_paths env p = + match p with + | Pdot (p, s) -> + Pdot (rewrite_double_underscore_paths env p, s) + | Papply (a, b) -> + Papply (rewrite_double_underscore_paths env a, + rewrite_double_underscore_paths env b) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths env p, extra) + | Pident id -> + let name = Ident.name id in + match find_double_underscore name with + | None -> p + | Some i -> + let better_lid = + Ldot + (Lident (String.sub name 0 i), + Unit_info.modulize + (String.sub name (i + 2) (String.length name - i - 2))) + in + match Env.find_module_by_name better_lid env with + | exception Not_found -> p + | p', _ -> + if module_path_is_an_alias_of env p' ~alias_of:p then + p' + else + p + +let rewrite_double_underscore_paths env p = + if env == Env.empty then + p + else + rewrite_double_underscore_paths env p + +let rec tree_of_path ?(disambiguation=true) namespace p = + let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in + let namespace = if disambiguation then namespace else None in + match p with + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> + Oide_ident (Out_name.create s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + let t1 = tree_of_path (Some Module) p1 in + let t2 = tree_of_path (Some Module) p2 in + Oide_apply (t1, t2) + | Pextra_ty (p, extra) -> begin + (* inline record types are syntactically prevented from escaping their + binding scope, and are never shown to users. *) + match extra with + Pcstr_ty s -> + Oide_dot (tree_of_path (Some Type) p, s) + | Pext_ty -> + tree_of_path None p + end + +let tree_of_path ?disambiguation namespace p = + tree_of_path ?disambiguation namespace + (rewrite_double_underscore_paths !printing_env p) + + +(* Print a recursive annotation *) + +let tree_of_rec = function + | Trec_not -> Orec_not + | Trec_first -> Orec_first + | Trec_next -> Orec_next + +(* Normalize paths *) + +type param_subst = Id | Nth of int | Map of int list + +let is_nth = function + Nth _ -> true + | _ -> false + +let compose l1 = function + | Id -> Map l1 + | Map l2 -> Map (List.map (List.nth l1) l2) + | Nth n -> Nth (List.nth l1 n) + +let apply_subst s1 tyl = + if tyl = [] then [] + (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) + else + match s1 with + Nth n1 -> [List.nth tyl n1] + | Map l1 -> List.map (List.nth tyl) l1 + | Id -> tyl + +type best_path = Paths of Path.t list | Best of Path.t + +(** Short-paths cache: the five mutable variables below implement a one-slot + cache for short-paths + *) +let printing_old = ref Env.empty +let printing_pers = ref String.Set.empty +(** {!printing_old} and {!printing_pers} are the keys of the one-slot cache *) + +let printing_depth = ref 0 +let printing_cont = ref ([] : Env.iter_cont list) +let printing_map = ref Path.Map.empty +(** + - {!printing_map} is the main value stored in the cache. + Note that it is evaluated lazily and its value is updated during printing. + - {!printing_dep} is the current exploration depth of the environment, + it is used to determine whenever the {!printing_map} should be evaluated + further before completing a request. + - {!printing_cont} is the list of continuations needed to evaluate + the {!printing_map} one level further (see also {!Env.run_iter_cont}) +*) + +let rec index l x = + match l with + [] -> raise Not_found + | a :: l -> if eq_type x a then 0 else 1 + index l x + +let rec uniq = function + [] -> true + | a :: l -> not (List.memq (a : int) l) && uniq l + +let rec normalize_type_path ?(cache=false) env p = + try + let (params, ty, _) = Env.find_type_expansion p env in + match get_desc ty with + Tconstr (p1, tyl, _) -> + if List.length params = List.length tyl + && List.for_all2 eq_type params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl + || not (uniq (List.map get_id tyl)) then (p, Id) + else + let l1 = List.map (index params) tyl in + let (p2, s2) = normalize_type_path ~cache env p1 in + (p2, compose l1 s2) + | _ -> + (p, Nth (index params ty)) + with + Not_found -> + (Env.normalize_type_path None env p, Id) + +let penalty s = + if s <> "" && s.[0] = '_' then + 10 + else + match find_double_underscore s with + | None -> 1 + | Some _ -> 10 + +let rec path_size = function + Pident id -> + penalty (Ident.name id), -Ident.scope id + | Pdot (p, _) | Pextra_ty (p, Pcstr_ty _) -> + let (l, b) = path_size p in (1+l, b) + | Papply (p1, p2) -> + let (l, b) = path_size p1 in + (l + fst (path_size p2), b) + | Pextra_ty (p, _) -> path_size p + +let same_printing_env env = + let used_pers = Env.used_persistent () in + Env.same_types !printing_old env && String.Set.equal !printing_pers used_pers + +let set_printing_env env = + printing_env := env; + if !Clflags.real_paths || + !printing_env == Env.empty || + same_printing_env env then + () + else begin + (* printf "Reset printing_map@."; *) + printing_old := env; + printing_pers := Env.used_persistent (); + printing_map := Path.Map.empty; + printing_depth := 0; + (* printf "Recompute printing_map.@."; *) + let cont = + Env.iter_types + (fun p (p', _decl) -> + let (p1, s1) = normalize_type_path env p' ~cache:true in + (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) + if s1 = Id then + try + let r = Path.Map.find p1 !printing_map in + match !r with + Paths l -> r := Paths (p :: l) + | Best p' -> r := Paths [p; p'] (* assert false *) + with Not_found -> + printing_map := Path.Map.add p1 (ref (Paths [p])) !printing_map) + env in + printing_cont := [cont]; + end + +let wrap_printing_env env f = + set_printing_env env; + try_finally f ~always:(fun () -> set_printing_env Env.empty) + +let wrap_printing_env ~error env f = + if error then Env.without_cmis (wrap_printing_env env) f + else wrap_printing_env env f + +let rec lid_of_path = function + Path.Pident id -> + Longident.Lident (Ident.name id) + | Path.Pdot (p1, s) | Path.Pextra_ty (p1, Pcstr_ty s) -> + Longident.Ldot (lid_of_path p1, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lid_of_path p1, lid_of_path p2) + | Path.Pextra_ty (p, Pext_ty) -> lid_of_path p + +let is_unambiguous path env = + let l = Env.find_shadowed_types path env in + List.exists (Path.same path) l || (* concrete paths are ok *) + match l with + [] -> true + | p :: rem -> + (* allow also coherent paths: *) + let normalize p = fst (normalize_type_path ~cache:true env p) in + let p' = normalize p in + List.for_all (fun p -> Path.same (normalize p) p') rem || + (* also allow repeatedly defining and opening (for toplevel) *) + let id = lid_of_path p in + List.for_all (fun p -> lid_of_path p = id) rem && + Path.same p (fst (Env.find_type_by_name id env)) + +let rec get_best_path r = + match !r with + Best p' -> p' + | Paths [] -> raise Not_found + | Paths l -> + r := Paths []; + List.iter + (fun p -> + (* Format.eprintf "evaluating %a@." path p; *) + match !r with + Best p' when path_size p >= path_size p' -> () + | _ -> if is_unambiguous p !printing_env then r := Best p) + (* else Format.eprintf "%a ignored as ambiguous@." path p *) + l; + get_best_path r + +let best_type_path p = + if !printing_env == Env.empty + then (p, Id) + else if !Clflags.real_paths + then (p, Id) + else + let (p', s) = normalize_type_path !printing_env p in + let get_path () = get_best_path (Path.Map.find p' !printing_map) in + while !printing_cont <> [] && + try fst (path_size (get_path ())) > !printing_depth with Not_found -> true + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth; + done; + let p'' = try get_path () with Not_found -> p' in + (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) + (p'', s) + +(* When building a tree for a best type path, we should not disambiguate + identifiers whenever the short-path algorithm detected a better path than + the original one.*) +let tree_of_best_type_path p p' = + if Path.same p p' then tree_of_path (Some Type) p' + else tree_of_path ~disambiguation:false None p' + +(* Print a type expression *) + +let proxy ty = Transient_expr.repr (proxy ty) + +(* When printing a type scheme, we print weak names. When printing a plain + type, we do not. This type controls that behavior *) +type type_or_scheme = Type | Type_scheme + +let is_non_gen mode ty = + match mode with + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level + | Type -> false + +let nameable_row row = + row_name row <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _) -> + row_closed row && if c then l = [] else List.length l = 1 + | _ -> true) + (row_fields row) + +(* This specialized version of [Btype.iter_type_expr] normalizes and + short-circuits the traversal of the [type_expr], so that it covers only the + subterms that would be printed by the type printer. *) +let printer_iter_type_expr f ty = + match get_desc ty with + | Tconstr(p, tyl, _) -> + let (_p', s) = best_type_path p in + List.iter f (apply_subst s tyl) + | Tvariant row -> begin + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter f tyl + | _ -> + iter_row f row + end + | Tobject (fi, nm) -> begin + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + f ty) + fields + | Some (_, l) -> + List.iter f (List.tl l) + end + | Tfield(_, kind, ty1, ty2) -> + if field_kind_repr kind = Fpublic then + f ty1; + f ty2 + | _ -> + Btype.iter_type_expr f ty + +let quoted_ident ppf x = + Style.as_inline_code !Oprint.out_ident ppf x + +module Internal_names : sig + + val reset : unit -> unit + + val add : Path.t -> unit + + val print_explanations : Env.t -> Fmt.formatter -> unit + +end = struct + + let names = ref Ident.Set.empty + + let reset () = + names := Ident.Set.empty + + let add p = + match p with + | Pident id -> + let name = Ident.name id in + if String.length name > 0 && name.[0] = '$' then begin + names := Ident.Set.add id !names + end + | Pdot _ | Papply _ | Pextra_ty _ -> () + + let print_explanations env ppf = + let constrs = + Ident.Set.fold + (fun id acc -> + let p = Pident id in + match Env.find_type p env with + | exception Not_found -> acc + | decl -> + match type_origin decl with + | Existential constr -> + let prev = String.Map.find_opt constr acc in + let prev = Option.value ~default:[] prev in + String.Map.add constr (tree_of_path None p :: prev) acc + | Definition | Rec_check_regularity -> acc) + !names String.Map.empty + in + String.Map.iter + (fun constr out_idents -> + match out_idents with + | [] -> () + | [out_ident] -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ + bound by the constructor@ %a.@]" + quoted_ident out_ident + Style.inline_code constr + | out_ident :: out_idents -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ + bound by the constructor@ %a.@]" + (Fmt.pp_print_list + ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") + quoted_ident) + (List.rev out_idents) + quoted_ident out_ident + Style.inline_code constr) + constrs + +end + +module Variable_names : sig + val reset_names : unit -> unit + + val add_subst : (type_expr * type_expr) list -> unit + + val new_name : unit -> string + val new_var_name : non_gen:bool -> type_expr -> unit -> string + + val name_of_type : (unit -> string) -> transient_expr -> string + val check_name_of_type : non_gen:bool -> transient_expr -> unit + + + val reserve: type_expr -> unit + + val remove_names : transient_expr list -> unit + + val with_local_names : (unit -> 'a) -> 'a + + (* Refresh the weak variable map in the toplevel; for [print_items], which is + itself for the toplevel *) + val refresh_weak : unit -> unit +end = struct + (* We map from types to names, but not directly; we also store a substitution, + which maps from types to types. The lookup process is + "type -> apply substitution -> find name". The substitution is presumed to + be one-shot. *) + let names = ref ([] : (transient_expr * string) list) + let name_subst = ref ([] : (transient_expr * transient_expr) list) + let name_counter = ref 0 + let named_vars = ref ([] : string list) + let visited_for_named_vars = ref ([] : transient_expr list) + + let weak_counter = ref 1 + let weak_var_map = ref TypeMap.empty + let named_weak_vars = ref String.Set.empty + + let reset_names () = + names := []; + name_subst := []; + name_counter := 0; + named_vars := []; + visited_for_named_vars := [] + + let add_named_var tty = + match tty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () + + let rec add_named_vars ty = + let tty = Transient_expr.repr ty in + let px = proxy ty in + if not (List.memq px !visited_for_named_vars) then begin + visited_for_named_vars := px :: !visited_for_named_vars; + match tty.desc with + | Tvar _ | Tunivar _ -> + add_named_var tty + | _ -> + printer_iter_type_expr add_named_vars ty + end + + let substitute ty = + match List.assq ty !name_subst with + | ty' -> ty' + | exception Not_found -> ty + + let add_subst subst = + name_subst := + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) + subst + @ !name_subst + + let name_is_already_used name = + List.mem name !named_vars + || List.exists (fun (_, name') -> name = name') !names + || String.Set.mem name !named_weak_vars + + let rec new_name () = + let name = Misc.letter_of_int !name_counter in + incr name_counter; + if name_is_already_used name then new_name () else name + + let rec new_weak_name ty () = + let name = "weak" ^ Int.to_string !weak_counter in + incr weak_counter; + if name_is_already_used name then new_weak_name ty () + else begin + named_weak_vars := String.Set.add name !named_weak_vars; + weak_var_map := TypeMap.add ty name !weak_var_map; + name + end + + let new_var_name ~non_gen ty () = + if non_gen then new_weak_name ty () + else new_name () + + let name_of_type name_generator t = + (* We've already been through repr at this stage, so t is our representative + of the union-find class. *) + let t = substitute t in + try List.assq t !names with Not_found -> + try TransientTypeMap.find t !weak_var_map with Not_found -> + let name = + match t.desc with + Tvar (Some name) | Tunivar (Some name) -> + (* Some part of the type we've already printed has assigned another + * unification variable to that name. We want to keep the name, so + * try adding a number until we find a name that's not taken. *) + let available name = + List.for_all + (fun (_, name') -> name <> name') + !names + in + if available name then name + else + let suffixed i = name ^ Int.to_string i in + let i = Misc.find_first_mono (fun i -> available (suffixed i)) in + suffixed i + | _ -> + (* No name available, create a new one *) + name_generator () + in + (* Exception for type declarations *) + if name <> "_" then names := (t, name) :: !names; + name + + let check_name_of_type ~non_gen px = + let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in + ignore(name_of_type name_gen px) + + let remove_names tyl = + let tyl = List.map substitute tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let with_local_names f = + let old_names = !names in + let old_subst = !name_subst in + names := []; + name_subst := []; + try_finally + ~always:(fun () -> + names := old_names; + name_subst := old_subst) + f + + let refresh_weak () = + let refresh t name (m,s) = + if is_non_gen Type_scheme t then + begin + TypeMap.add t name m, + String.Set.add name s + end + else m, s in + let m, s = + TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in + named_weak_vars := s; + weak_var_map := m + + let reserve ty = + normalize_type ty; + add_named_vars ty +end + +module Aliases = struct + let visited_objects = ref ([] : transient_expr list) + let aliased = ref ([] : transient_expr list) + let delayed = ref ([] : transient_expr list) + let printed_aliases = ref ([] : transient_expr list) + +(* [printed_aliases] is a subset of [aliased] that records only those aliased + types that have actually been printed; this allows us to avoid naming loops + that the user will never see. *) + + let is_delayed t = List.memq t !delayed + + let remove_delay t = + if is_delayed t then + delayed := List.filter ((!=) t) !delayed + + let add_delayed t = + if not (is_delayed t) then delayed := t :: !delayed + + let is_aliased_proxy px = List.memq px !aliased + let is_printed_proxy px = List.memq px !printed_aliases + + let add_proxy px = + if not (is_aliased_proxy px) then + aliased := px :: !aliased + + let add ty = add_proxy (proxy ty) + + let add_printed_proxy ~non_gen px = + Variable_names.check_name_of_type ~non_gen px; + printed_aliases := px :: !printed_aliases + + let mark_as_printed px = + if is_aliased_proxy px then (add_printed_proxy ~non_gen:false) px + + let add_printed ty = add_printed_proxy (proxy ty) + + let aliasable ty = + match get_desc ty with + Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> + not (is_nth (snd (best_type_path p))) + | _ -> true + + let should_visit_object ty = + match get_desc ty with + | Tvariant row -> not (static_row row) + | Tobject _ -> opened_object ty + | _ -> false + + let rec mark_loops_rec visited ty = + let px = proxy ty in + if List.memq px visited && aliasable ty then add_proxy px else + let tty = Transient_expr.repr ty in + let visited = px :: visited in + match tty.desc with + | Tvariant _ | Tobject _ -> + if List.memq px !visited_objects then add_proxy px else begin + if should_visit_object ty then + visited_objects := px :: !visited_objects; + printer_iter_type_expr (mark_loops_rec visited) ty + end + | Tpoly(ty, tyl) -> + List.iter add tyl; + mark_loops_rec visited ty + | _ -> + printer_iter_type_expr (mark_loops_rec visited) ty + + let mark_loops ty = + mark_loops_rec [] ty + + let reset () = + visited_objects := []; aliased := []; delayed := []; printed_aliases := [] + +end + +let prepare_type ty = + Variable_names.reserve ty; + Aliases.mark_loops ty + + +let reset_except_conflicts () = + Variable_names.reset_names (); Aliases.reset (); Internal_names.reset () + +let reset () = + Ident_conflicts.reset (); + reset_except_conflicts () + +let prepare_for_printing tyl = + reset_except_conflicts (); + List.iter prepare_type tyl + +let add_type_to_preparation = prepare_type + +(* Disabled in classic mode when printing an unification error *) +let print_labels = ref true +let with_labels b f = Misc.protect_refs [R (print_labels,b)] f + +let alias_nongen_row mode px ty = + match get_desc ty with + | Tvariant _ | Tobject _ -> + if is_non_gen mode (Transient_expr.type_expr px) then + Aliases.add_proxy px + | _ -> () + +let rec tree_of_typexp mode ty = + let px = proxy ty in + if Aliases.is_printed_proxy px && not (Aliases.is_delayed px) then + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + let name = Variable_names.(name_of_type (new_var_name ~non_gen ty)) px in + Otyp_var (non_gen, name) else + + let pr_typ () = + let tty = Transient_expr.repr ty in + match tty.desc with + | Tvar _ -> + let non_gen = is_non_gen mode ty in + let name_gen = Variable_names.new_var_name ~non_gen ty in + Otyp_var (non_gen, Variable_names.name_of_type name_gen tty) + | Tarrow(l, ty1, ty2, _) -> + let lab = + if !print_labels || is_optional l then l else Nolabel + in + let t1 = + if is_optional l then + match get_desc ty1 with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty1 in + Otyp_arrow (lab, t1, tree_of_typexp mode ty2) + | Ttuple tyl -> + Otyp_tuple (tree_of_typlist mode tyl) + | Tconstr(p, tyl, _abbrev) -> + let p', s = best_type_path p in + let tyl' = apply_subst s tyl in + if is_nth s && not (tyl'=[]) + then tree_of_typexp mode (List.hd tyl') + else begin + Internal_names.add p'; + Otyp_constr (tree_of_best_type_path p p', tree_of_typlist mode tyl') + end + | Tvariant row -> + let Row {fields; name; closed; _} = row_repr row in + let fields = + if closed then + List.filter (fun (_, f) -> row_field_repr f <> Rabsent) + fields + else fields in + let present = + List.filter + (fun (_, f) -> + match row_field_repr f with + | Rpresent _ -> true + | _ -> false) + fields in + let all_present = List.length present = List.length fields in + begin match name with + | Some(p, tyl) when nameable_row row -> + let (p', s) = best_type_path p in + let id = tree_of_best_type_path p p' in + let args = tree_of_typlist mode (apply_subst s tyl) in + let out_variant = + if is_nth s then List.hd args else Otyp_constr (id, args) in + if closed && all_present then + out_variant + else + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_typ out_variant, closed, tags) + | _ -> + let fields = List.map (tree_of_row_field mode) fields in + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tnil | Tfield _ -> + tree_of_typobject mode ty None + | Tsubst _ -> + (* This case should only happen when debugging the compiler *) + Otyp_stuff "" + | Tlink _ -> + fatal_error "Out_type.tree_of_typexp" + | Tpoly (ty, []) -> + tree_of_typexp mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + if tyl = [] then tree_of_typexp mode ty else begin + let tyl = List.map Transient_expr.repr tyl in + let old_delayed = !Aliases.delayed in + (* Make the names delayed, so that the real type is + printed once when used as proxy *) + List.iter Aliases.add_delayed tyl; + let tl = List.map Variable_names.(name_of_type new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode ty) in + (* Forget names when we leave scope *) + Variable_names.remove_names tyl; + Aliases.delayed := old_delayed; tr + end + | Tunivar _ -> + Otyp_var (false, Variable_names.(name_of_type new_name) tty) + | Tpackage (p, fl) -> + let fl = + List.map + (fun (li, ty) -> ( + String.concat "." (Longident.flatten li), + tree_of_typexp mode ty + )) fl in + Otyp_module (tree_of_path (Some Module_type) p, fl) + in + Aliases.remove_delay px; + alias_nongen_row mode px ty; + if Aliases.(is_aliased_proxy px && aliasable ty) then begin + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + Aliases.add_printed_proxy ~non_gen px; + (* add_printed_alias chose a name, thus the name generator + doesn't matter.*) + let alias = Variable_names.(name_of_type (new_var_name ~non_gen ty)) px in + Otyp_alias {non_gen; aliased = pr_typ (); alias } end + else pr_typ () + +and tree_of_row_field mode (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tree_of_typlist mode tyl) + else (l, false, tree_of_typlist mode tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode) tyl + +and tree_of_typobject mode fi nm = + begin match nm with + | None -> + let pr_fields fi = + let (fields, rest) = flatten_fields fi in + let present_fields = + List.fold_right + (fun (n, k, t) l -> + match field_kind_repr k with + | Fpublic -> (n, t) :: l + | _ -> l) + fields [] in + let sorted_fields = + List.sort + (fun (n, _) (n', _) -> String.compare n n') present_fields in + tree_of_typfields mode rest sorted_fields in + let (fields, open_row) = pr_fields fi in + Otyp_object {fields; open_row} + | Some (p, _ty :: tyl) -> + let args = tree_of_typlist mode tyl in + let (p', s) = best_type_path p in + assert (s = Id); + Otyp_class (tree_of_best_type_path p p', args) + | _ -> + fatal_error "Out_type.tree_of_typobject" + end + +and tree_of_typfields mode rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | (s, t) :: l -> + let field = (s, tree_of_typexp mode t) in + let (fields, rest) = tree_of_typfields mode rest l in + (field :: fields, rest) + +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + +let prepared_type_expr ppf ty = typexp Type ppf ty + +(* "Half-prepared" type expression: [ty] should have had its names reserved, but + should not have had its loops marked. *) +let type_expr_with_reserved_names ppf ty = + Aliases.reset (); + Aliases.mark_loops ty; + prepared_type_expr ppf ty + + +let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty + +(* Print one type declaration *) + +let tree_of_constraints params = + List.fold_right + (fun ty list -> + let ty' = unalias ty in + if proxy ty != proxy ty' then + let tr = tree_of_typexp Type_scheme ty in + (tr, tree_of_typexp Type_scheme ty') :: list + else list) + params [] + +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + if List.exists (eq_type ty) tyl + then newty2 ~level:generic_level (Ttuple [ty]) :: tyl + else ty :: tyl) + (* Two parameters might be identical due to a constraint but we need to + print them differently in order to make the output syntactically valid. + We use [Ttuple [ty]] because it is printed as [ty]. *) + (* Replacing fold_left by fold_right does not work! *) + [] tyl + in List.rev params + +let prepare_type_constructor_arguments = function + | Cstr_tuple l -> List.iter prepare_type l + | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l + +let tree_of_label l = + { + olab_name = Ident.name l.ld_id; + olab_mut = l.ld_mutable; + olab_type = tree_of_typexp Type l.ld_type; + } + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist Type l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let ret = Option.map (tree_of_typexp Type) cd.cd_res in + let args = tree_of_constructor_arguments cd.cd_args in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* When printing GADT constructor, we need to forget the naming decision we took + for the type parameters and constraints. Indeed, in + {[ + type 'a t = X: 'a -> 'b t + ]} + It is fine to print both the type parameter ['a] and the existentially + quantified ['a] in the definition of the constructor X as ['a] + *) +let tree_of_constructor_in_decl cd = + match cd.cd_res with + | None -> tree_of_single_constructor cd + | Some _ -> + Variable_names.with_local_names (fun () -> tree_of_single_constructor cd) + +let prepare_decl id decl = + let params = filter_params decl.type_params in + begin match decl.type_manifest with + | Some ty -> + let vars = free_variables ty in + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + params + | None -> () + end; + List.iter Aliases.add params; + List.iter prepare_type params; + List.iter (Aliases.add_printed ~non_gen:false) params; + let ty_manifest = + match decl.type_manifest with + | None -> None + | Some ty -> + let ty = + (* Special hack to hide variant name *) + match get_desc ty with + Tvariant row -> + begin match row_name row with + Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant (set_row_name row None)) + | _ -> ty + end + | _ -> ty + in + prepare_type ty; + Some ty + in + begin match decl.type_kind with + | Type_abstract _ -> () + | Type_variant (cstrs, _rep) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_open -> () + end; + ty_manifest, params + +let tree_of_type_decl id decl = + let ty_manifest, params = prepare_decl id decl in + let type_param ot_variance = + function + | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} + in + let type_defined decl = + let abstr = + match decl.type_kind with + Type_abstract _ -> + decl.type_manifest = None || decl.type_private = Private + | Type_record _ -> + decl.type_private = Private + | Type_variant (tll, _rep) -> + decl.type_private = Private || + List.exists (fun cd -> cd.cd_res <> None) tll + | Type_open -> + decl.type_manifest = None + in + let vari = + List.map2 + (fun ty v -> + let is_var = is_Tvar ty in + if abstr || not is_var then + let inj = + type_kind_is_abstract decl && Variance.mem Inj v && + match decl.type_manifest with + | None -> true + | Some ty -> (* only abstract or private row types *) + decl.type_private = Private && + Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty) + and (co, cn) = Variance.get_upper v in + (if not cn then Covariant else + if not co then Contravariant else NoVariance), + (if inj then Injective else NoInjectivity) + else (NoVariance, NoInjectivity)) + decl.type_params decl.type_variance + in + (Ident.name id, + List.map2 (fun ty cocn -> type_param cocn (tree_of_typexp Type ty)) + params vari) + in + let tree_of_manifest ty1 = + match ty_manifest with + | None -> ty1 + | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) + in + let (name, args) = type_defined decl in + let constraints = tree_of_constraints params in + let ty, priv, unboxed = + match decl.type_kind with + | Type_abstract _ -> + begin match ty_manifest with + | None -> (Otyp_abstract, Public, false) + | Some ty -> + tree_of_typexp Type ty, decl.type_private, false + end + | Type_variant (cstrs, rep) -> + tree_of_manifest + (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), + decl.type_private, + (rep = Variant_unboxed) + | Type_record(lbls, rep) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private, + (match rep with Record_unboxed _ -> true | _ -> false) + | Type_open -> + tree_of_manifest Otyp_open, + decl.type_private, + false + in + { otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_immediate = Type_immediacy.of_attributes decl.type_attributes; + otype_unboxed = unboxed; + otype_cstrs = constraints } + +let add_type_decl_to_preparation id decl = + ignore @@ prepare_decl id decl + +let tree_of_prepared_type_decl id decl = + tree_of_type_decl id decl + +let tree_of_type_decl id decl = + reset_except_conflicts(); + tree_of_type_decl id decl + +let add_constructor_to_preparation c = + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res + +let prepared_constructor ppf c = + !Oprint.out_constr ppf (tree_of_single_constructor c) + + +let tree_of_type_declaration id decl rs = + Osig_type (tree_of_type_decl id decl, tree_of_rec rs) + +let tree_of_prepared_type_declaration id decl rs = + Osig_type (tree_of_prepared_type_decl id decl, tree_of_rec rs) + +let add_type_declaration_to_preparation id decl = + add_type_decl_to_preparation id decl + +let prepared_type_declaration id ppf decl = + !Oprint.out_sig_item ppf + (tree_of_prepared_type_declaration id decl Trec_first) + + +(* When printing extension constructor, it is important to ensure that +after printing the constructor, we are still in the scope of the constructor. +For GADT constructor, this can be done by printing the type parameters inside +their own isolated scope. This ensures that in +{[ + type 'b t += A: 'b -> 'b any t +]} +the type parameter `'b` is not bound when printing the type variable `'b` from +the constructor definition from the type parameter. + +Contrarily, for non-gadt constructor, we must keep the same scope for +the type parameters and the constructor because a type constraint may +have changed the name of the type parameter: +{[ +type -'a t = .. constraint 'a> = 'a +(* the universal 'a is here to steal the name 'a from the type parameter *) +type 'a t = X of 'a +]} *) +let add_extension_constructor_to_preparation ext = + let ty_params = filter_params ext.ext_type_params in + List.iter Aliases.add ty_params; + List.iter prepare_type ty_params; + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type + +let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = + let ret = Option.map (tree_of_typexp Type) ext_ret_type in + let args = tree_of_constructor_arguments ext_args in + (args, ret) + +let prepared_tree_of_extension_constructor + id ext es + = + let ty_name = Path.name ext.ext_type_path in + let ty_params = filter_params ext.ext_type_params in + let type_param = + function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let param_scope f = + match ext.ext_ret_type with + | None -> + (* normal constructor: same scope for parameters and the constructor *) + f () + | Some _ -> + (* gadt constructor: isolated scope for the type parameters *) + Variable_names.with_local_names f + in + let ty_params = + param_scope + (fun () -> + List.iter (Aliases.add_printed ~non_gen:false) ty_params; + List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params + ) + in + let name = Ident.name id in + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type + in + let ext = + { oext_name = name; + oext_type_name = ty_name; + oext_type_params = ty_params; + oext_args = args; + oext_ret_type = ret; + oext_private = ext.ext_private } + in + let es = + match es with + Text_first -> Oext_first + | Text_next -> Oext_next + | Text_exception -> Oext_exception + in + Osig_typext (ext, es) + +let tree_of_extension_constructor id ext es = + reset_except_conflicts (); + add_extension_constructor_to_preparation ext; + prepared_tree_of_extension_constructor id ext es + +let prepared_extension_constructor id ppf ext = + !Oprint.out_sig_item ppf + (prepared_tree_of_extension_constructor id ext Text_first) + +(* Print a value declaration *) + +let tree_of_value_description id decl = + (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) + let id = Ident.name id in + let () = prepare_for_printing [decl.val_type] in + let ty = tree_of_typexp Type_scheme decl.val_type in + let vd = + { oval_name = id; + oval_type = ty; + oval_prims = []; + oval_attributes = [] } + in + let vd = + match decl.val_kind with + | Val_prim p -> Primitive.print p vd + | _ -> vd + in + Osig_value vd + +(* Print a class type *) + +let method_type priv ty = + match priv, get_desc ty with + | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) + | _ , _ -> (ty, []) + +let prepare_method _lab (priv, _virt, ty) = + let ty, _ = method_type priv ty in + prepare_type ty + +let tree_of_method mode (lab, priv, virt, ty) = + let (ty, tyl) = method_type priv ty in + let tty = tree_of_typexp mode ty in + Variable_names.remove_names (List.map Transient_expr.repr tyl); + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, tty) + +let rec prepare_class_type params = function + | Cty_constr (_p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !Aliases.visited_objects + || not (List.for_all is_Tvar params) + || List.exists (deep_occur row) tyl + then prepare_class_type params cty + else List.iter prepare_type tyl + | Cty_signature sign -> + (* Self may have a name *) + let px = proxy sign.csig_self_row in + if List.memq px !Aliases.visited_objects then Aliases.add_proxy px + else Aliases.(visited_objects := px :: !visited_objects); + Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; + Meths.iter prepare_method sign.csig_meths + | Cty_arrow (_, ty, cty) -> + prepare_type ty; + prepare_class_type params cty + +let rec tree_of_class_type mode params = + function + | Cty_constr (p', tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !Aliases.visited_objects + || not (List.for_all is_Tvar params) + then + tree_of_class_type mode params cty + else + let namespace = Namespace.best_class_namespace p' in + Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) + | Cty_signature sign -> + let px = proxy sign.csig_self_row in + let self_ty = + if Aliases.is_aliased_proxy px then + Some + (Otyp_var (false, Variable_names.(name_of_type new_name) px)) + else None + in + let csil = [] in + let csil = + List.fold_left + (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) + csil (tree_of_constraints params) + in + let all_vars = + Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] + in + (* Consequence of PR#3607: order of Map.fold has changed! *) + let all_vars = List.rev all_vars in + let csil = + List.fold_left + (fun csil (l, m, v, t) -> + Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) + :: csil) + csil all_vars + in + let all_meths = + Meths.fold + (fun l (p, v, t) all -> (l, p, v, t) :: all) + sign.csig_meths [] + in + let all_meths = List.rev all_meths in + let csil = + List.fold_left + (fun csil meth -> tree_of_method mode meth :: csil) + csil all_meths + in + Octy_signature (self_ty, List.rev csil) + | Cty_arrow (l, ty, cty) -> + let lab = + if !print_labels || is_optional l then l else Nolabel + in + let tr = + if is_optional l then + match get_desc ty with + | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty in + Octy_arrow (lab, tr, tree_of_class_type mode params cty) + + +let tree_of_class_param param variance = + let ot_variance = + if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in + match tree_of_typexp Type_scheme param with + Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} + +let class_variance = + let open Variance in let open Asttypes in + List.map (fun v -> + (if not (mem May_pos v) then Contravariant else + if not (mem May_neg v) then Covariant else NoVariance), + NoInjectivity) + +let tree_of_class_declaration id cl rs = + let params = filter_params cl.cty_params in + + reset_except_conflicts (); + List.iter Aliases.add params; + prepare_class_type params cl.cty_type; + let px = proxy (Btype.self_type_row cl.cty_type) in + List.iter prepare_type params; + + List.iter (Aliases.add_printed ~non_gen:false) params; + if Aliases.is_aliased_proxy px then + Aliases.add_printed_proxy ~non_gen:false px; + + let vir_flag = cl.cty_new = None in + Osig_class + (vir_flag, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.cty_variance), + tree_of_class_type Type_scheme params cl.cty_type, + tree_of_rec rs) + +let tree_of_cltype_declaration id cl rs = + let params = cl.clty_params in + + reset_except_conflicts (); + List.iter Aliases.add params; + prepare_class_type params cl.clty_type; + let px = proxy (Btype.self_type_row cl.clty_type) in + List.iter prepare_type params; + + List.iter (Aliases.add_printed ~non_gen:false) params; + Aliases.mark_as_printed px; + + let sign = Btype.signature_of_class_type cl.clty_type in + let has_virtual_vars = + Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_vars false + in + let has_virtual_meths = + Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_meths false + in + Osig_class_type + (has_virtual_vars || has_virtual_meths, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.clty_variance), + tree_of_class_type Type_scheme params cl.clty_type, + tree_of_rec rs) + +(* Print a module type *) + +let wrap_env fenv ftree arg = + (* We save the current value of the short-path cache *) + (* From keys *) + let env = !printing_env in + let old_pers = !printing_pers in + (* to data *) + let old_map = !printing_map in + let old_depth = !printing_depth in + let old_cont = !printing_cont in + set_printing_env (fenv env); + let tree = ftree arg in + if !Clflags.real_paths + || same_printing_env env then () + (* our cached key is still live in the cache, and we want to keep all + progress made on the computation of the [printing_map] *) + else begin + (* we restore the snapshotted cache before calling set_printing_env *) + printing_old := env; + printing_pers := old_pers; + printing_depth := old_depth; + printing_cont := old_cont; + printing_map := old_map + end; + set_printing_env env; + tree + +let dummy = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = None; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = Location.none; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + } + +(** we hide items being defined from short-path to avoid shortening + [type t = Path.To.t] into [type t = t]. +*) + +let ident_sigitem = function + | Types.Sig_type(ident,_,_,_) -> {hide=true;ident} + | Types.Sig_class(ident,_,_,_) + | Types.Sig_class_type (ident,_,_,_) + | Types.Sig_module(ident,_, _,_,_) + | Types.Sig_value (ident,_,_) + | Types.Sig_modtype (ident,_,_) + | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } + +let hide ids env = + let hide_id id env = + (* Global idents cannot be renamed *) + if id.hide && not (Ident.global id.ident) then + Env.add_type ~check:false (Ident.rename id.ident) dummy env + else env + in + List.fold_right hide_id ids env + +let with_hidden_items ids f = + let with_hidden_in_printing_env ids f = + wrap_env (hide ids) (Ident_names.with_hidden ids) f + in + if not !Clflags.real_paths then + with_hidden_in_printing_env ids f + else + Ident_names.with_hidden ids f + + +let add_sigitem env x = + Env.add_signature (Signature_group.flatten x) env + +let rec tree_of_modtype ?(ellipsis=false) = function + | Mty_ident p -> + Omty_ident (tree_of_path (Some Module_type) p) + | Mty_signature sg -> + Omty_signature (if ellipsis then [Osig_ellipsis] + else tree_of_signature sg) + | Mty_functor(param, ty_res) -> + let param, env = + tree_of_functor_parameter param + in + let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in + Omty_functor (param, res) + | Mty_alias p -> + Omty_alias (tree_of_path (Some Module) p) + | Mty_for_hole -> Omty_hole + +and tree_of_functor_parameter = function + | Unit -> + None, fun k -> k + | Named (param, ty_arg) -> + let name, env = + match param with + | None -> None, fun env -> env + | Some id -> + Some (Ident.name id), + Env.add_module ~arg:true id Mp_present ty_arg + in + Some (name, tree_of_modtype ~ellipsis:false ty_arg), env + +and tree_of_signature sg = + wrap_env (fun env -> env)(fun sg -> + let tree_groups = tree_of_signature_rec !printing_env sg in + List.concat_map (fun (_env,l) -> List.map snd l) tree_groups + ) sg + +and tree_of_signature_rec env' sg = + let structured = List.of_seq (Signature_group.seq sg) in + let collect_trees_of_rec_group group = + let env = !printing_env in + let env', group_trees = + trees_of_recursive_sigitem_group env group + in + set_printing_env env'; + (env, group_trees) in + set_printing_env env'; + List.map collect_trees_of_rec_group structured + +and trees_of_recursive_sigitem_group env + (syntactic_group: Signature_group.rec_group) = + let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in + let env = Env.add_signature syntactic_group.pre_ghosts env in + match syntactic_group.group with + | Not_rec x -> add_sigitem env x, [display x] + | Rec_group items -> + let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in + List.fold_left add_sigitem env items, + with_hidden_items ids (fun () -> List.map display items) + +and tree_of_sigitem = function + | Sig_value(id, decl, _) -> + tree_of_value_description id decl + | Sig_type(id, decl, rs, _) -> + tree_of_type_declaration id decl rs + | Sig_typext(id, ext, es, _) -> + tree_of_extension_constructor id ext es + | Sig_module(id, _, md, rs, _) -> + let ellipsis = + List.exists (function + | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true + | _ -> false) + md.md_attributes in + tree_of_module id md.md_type rs ~ellipsis + | Sig_modtype(id, decl, _) -> + tree_of_modtype_declaration id decl + | Sig_class(id, decl, rs, _) -> + tree_of_class_declaration id decl rs + | Sig_class_type(id, decl, rs, _) -> + tree_of_cltype_declaration id decl rs + +and tree_of_modtype_declaration id decl = + let mty = + match decl.mtd_type with + | None -> Omty_abstract + | Some mty -> tree_of_modtype mty + in + Osig_modtype (Ident.name id, mty) + +and tree_of_module id ?ellipsis mty rs = + Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) + +(* For the toplevel: merge with tree_of_signature? *) +let print_items showval env x = + Variable_names.refresh_weak(); + Ident_conflicts.reset (); + let extend_val env (sigitem,outcome) = outcome, showval env sigitem in + let post_process (env,l) = List.map (extend_val env) l in + List.concat_map post_process @@ tree_of_signature_rec env x + +let same_path t t' = + let open Types in + eq_type t t' || + match get_desc t, get_desc t' with + Tconstr(p,tl,_), Tconstr(p',tl',_) -> + let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in + begin match s1, s2 with + Nth n1, Nth n2 when n1 = n2 -> true + | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> + let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in + List.length tl = List.length tl' && + List.for_all2 eq_type tl tl' + | _ -> false + end + | _ -> + false + +type 'a diff = Same of 'a | Diff of 'a * 'a + +let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = + Aliases.reset (); + Aliases.mark_loops t; + if same_path t t' + then begin Aliases.add_delayed (proxy t); Same (tree_of_typexp mode t) end + else begin + Aliases.mark_loops t'; + let t' = if proxy t == proxy t' then unalias t' else t' in + (* beware order matter due to side effect, + e.g. when printing object types *) + let first = tree_of_typexp mode t in + let second = tree_of_typexp mode t' in + if first = second then Same first + else Diff(first,second) + end + +let pp_type ppf t = + Style.as_inline_code !Oprint.out_type ppf t + +let pp_type_expansion ppf = function + | Same t -> pp_type ppf t + | Diff(t,t') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + pp_type t + pp_type t' + +(* Hide variant name and var, to force printing the expanded type *) +let hide_variant_name t = + let open Types in + match get_desc t with + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + if name = None then t else + Btype.newty2 ~level:(get_level t) + (Tvariant + (create_row ~fields ~fixed ~closed ~name:None + ~more:(Ctype.newvar2 (get_level more)))) + | _ -> t + +let prepare_expansion Errortrace.{ty; expanded} = + let expanded = hide_variant_name expanded in + Variable_names.reserve ty; + if not (same_path ty expanded) then Variable_names.reserve expanded; + Errortrace.{ty; expanded} + + +(* Adapt functions to exposed interface *) +let namespaced_tree_of_path n = tree_of_path (Some n) +let tree_of_path ?disambiguation p = tree_of_path ?disambiguation None p +let tree_of_modtype = tree_of_modtype ~ellipsis:false +let tree_of_type_declaration ident td rs = + with_hidden_items [{hide=true; ident}] + (fun () -> tree_of_type_declaration ident td rs) + +let tree_of_class_type kind cty = tree_of_class_type kind [] cty +let prepare_class_type cty = prepare_class_type [] cty + +let tree_of_type_path p = + let (p', s) = best_type_path p in + let p'' = if (s = Id) then p' else p in + tree_of_best_type_path p p'' diff --git a/src/ocaml/typing/out_type.mli b/src/ocaml/typing/out_type.mli new file mode 100644 index 000000000..b134fa119 --- /dev/null +++ b/src/ocaml/typing/out_type.mli @@ -0,0 +1,259 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Functions for representing type expressions and module types as outcometree + (with [as 'a] aliases for cycles) and printing them. All functions below + depends on global contexts that keep track of + +- If labels are disabled +- Current printing environment +- Shortest equivalent paths + +- Conflicts for identifier names +- Names chosen for type variables +- Aliases used for representing cycles or row variables +- Uses of internal names + +Whenever possible, it is advised to use the simpler functions available in +{!Printtyp} which take care of setting up this naming context. The functions +below are needed when one needs to share a common naming context (or part of it) +between different calls to printing functions (or in order to implement +{!Printtyp}). +*) + +open Format_doc +open Types +open Outcometree + +(** {1 Wrapping functions}*) + +val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a +(** Call the function using the environment for type path shortening + This affects all the printing and tree cration functions functions below + Also, if [~error:true], then disable the loading of cmis *) + + +(** [with_labels false] disable labels in function types *) +val with_labels: bool -> (unit -> 'a) -> 'a + +(** {1 Printing idents and paths } *) + +val ident_name: Shape.Sig_component_kind.t option -> Ident.t -> out_name +val tree_of_path: ?disambiguation:bool -> Path.t -> out_ident +val namespaced_tree_of_path: Shape.Sig_component_kind.t -> Path.t -> out_ident +val tree_of_type_path: Path.t -> out_ident +(** Specialized functions for printing types with [short-paths] *) + +(** [same_path ty ty2] is true when there is an equation [ty]=[ty2] in the + short-path scope*) +val same_path: type_expr -> type_expr -> bool + +(** Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias + for Foo__bar. This pattern is used by the stdlib. *) +val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t + +(** {1 Printing type expressions} *) + +(** Printing type expressions requires to translate the internal graph based + representation into to an {!Outcometree} closer to the source syntax. In + order to do so, the printing is generally split in three phase: + - A preparation phase which in particular + - marks cycles + - chooses user-facing names for type variables + - An outcometree generation phase, where we emit an outcometree as a + ready-for-printing representation of trees (represented by the various + [tree_of_*] functions) + - Printing proper +*) + +(** [prepare_for_printing] resets the global naming environment, a la + {!reset_except_conflicts}, and prepares the types for printing by reserving + variable names and marking cycles. Any type variables that are shared + between multiple types in the input list will be given the same name when + printed with {!prepared_type_expr}. *) +val prepare_for_printing: type_expr list -> unit + +(** [add_type_to_preparation ty] extend a previous type expression preparation + to the type expression [ty] +*) +val add_type_to_preparation: type_expr -> unit + +(** In [Type_scheme] mode, non-generic types variables are printed as weakly + polymorphic type variables. *) +type type_or_scheme = Type | Type_scheme +val tree_of_typexp: type_or_scheme -> type_expr -> out_type +(** [tree_of_typexp] generate the [outcometree] for a prepared type + expression.*) + +val prepared_type_scheme: type_expr printer +val prepared_type_expr: type_expr printer +(** The printers [prepared_type_expr] and [prepared_type_scheme] should only be + used on prepared types. Types can be prepared by initially calling + {!prepare_for_printing} or adding them later to the preparation with + {!add_type_to_preparation}. + + Calling this function on non-prepared types may cause a stack overflow (see + #8860) due to cycles in the printed types. + + See {!Printtyp.type_expr} for a safer but less flexible printer. *) + +(** [type_expr_with_reserved_names] can print "half-prepared" type expression. A + "half-prepared" type expression should have had its names reserved (with + {!Variable_names.reserve}), but should not have had its cycles marked. *) +val type_expr_with_reserved_names: type_expr printer + +type 'a diff = Same of 'a | Diff of 'a * 'a +val trees_of_type_expansion: + type_or_scheme -> Errortrace.expanded_type -> out_type diff +val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type +val pp_type_expansion: out_type diff printer +val hide_variant_name: Types.type_expr -> Types.type_expr + + +(** {1: Label and constructors }*) +val prepare_type_constructor_arguments: constructor_arguments -> unit +val tree_of_constructor_arguments: constructor_arguments -> out_type list + +val tree_of_label: label_declaration -> out_label + +val add_constructor_to_preparation : constructor_declaration -> unit +val prepared_constructor : constructor_declaration printer + +val tree_of_extension_constructor: + Ident.t -> extension_constructor -> ext_status -> out_sig_item +val extension_constructor_args_and_ret_type_subtree: + constructor_arguments -> type_expr option -> out_type list * out_type option +val add_extension_constructor_to_preparation : + extension_constructor -> unit +val prepared_extension_constructor: + Ident.t -> extension_constructor printer + + +(** {1 Declarations }*) + +val tree_of_type_declaration: + Ident.t -> type_declaration -> rec_status -> out_sig_item +val add_type_declaration_to_preparation : + Ident.t -> type_declaration -> unit +val prepared_type_declaration: Ident.t -> type_declaration printer + +val tree_of_value_description: Ident.t -> value_description -> out_sig_item +val tree_of_modtype_declaration: + Ident.t -> modtype_declaration -> out_sig_item +val tree_of_class_declaration: + Ident.t -> class_declaration -> rec_status -> out_sig_item +val tree_of_cltype_declaration: + Ident.t -> class_type_declaration -> rec_status -> out_sig_item + +(** {1 Module types }*) + +val tree_of_module: + Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item +val tree_of_modtype: module_type -> out_module_type +val tree_of_signature: Types.signature -> out_sig_item list + +val tree_of_class_type: type_or_scheme -> class_type -> out_class_type +val prepare_class_type: class_type -> unit + +(** {1 Toplevel printing} *) +val print_items: (Env.t -> signature_item -> 'a option) -> + Env.t -> signature_item list -> (out_sig_item * 'a option) list + +(** {1 Naming contexts }*) + +(** Path name, which were mutable at some point *) +module Out_name: sig + val create: string -> out_name + val print: out_name -> string +end + +(** Disambiguation for identifiers, e.g. the two type constructors named [t] +in the type of [f] in +{[ + type t = A + module M = struct + type t = B + let f A = B + end +]} +should be disambiguated to [t/2->t] *) +module Ident_names: sig + val enable: bool -> unit + (** When contextual names are enabled, the mapping between identifiers + and names is ensured to be one-to-one. *) + + (** [with_fuzzy id f] locally disable ident disambiguation for [id] within + [f] *) + val with_fuzzy: Ident.t -> (unit -> 'a) -> 'a +end + +(** The [Ident_conflicts] module keeps track of conflicts arising when + attributing names to identifiers and provides functions that can print + explanations for these conflict in error messages *) +module Ident_conflicts: sig + val exists: unit -> bool + (** [exists()] returns true if the current naming context renamed + an identifier to avoid a name collision *) + + type explanation = + { kind: Shape.Sig_component_kind.t; + name:string; + root_name:string; + location:Location.t + } + + val list_explanations: unit -> explanation list +(** [list_explanations()] return the list of conflict explanations + collected up to this point, and reset the list of collected + explanations *) + + val print_located_explanations: explanation list printer + + val err_print: formatter -> unit + val err_msg: unit -> doc option + (** [err_msg ()] return an error message if there are pending conflict + explanations at this point. It is often important to check for conflicts + after all printing is done, thus the delayed nature of [err_msg]*) + + val reset: unit -> unit +end + +(** Naming choice for type variable names (['a], ['b], ...), for instance the + two classes of distinct type variables in + {[let repeat x y = x, y, y, x]} + should be printed printed as ['a -> 'b -> 'a * 'b * 'b * 'a]. +*) +module Variable_names: sig + + (** Add external type equalities*) + val add_subst: (type_expr * type_expr) list -> unit + + (** [reserve ty] registers the variable names appearing in [ty] *) + val reserve: type_expr -> unit +end + +(** Register internal typechecker names ([$0],[$a]) appearing in the + [outcometree] *) +module Internal_names: sig + val add: Path.t -> unit + val reset: unit -> unit + val print_explanations: Env.t -> formatter -> unit +end + +(** Reset all contexts *) +val reset: unit -> unit + +(** Reset all contexts except for conflicts *) +val reset_except_conflicts: unit -> unit diff --git a/src/ocaml/typing/persistent_env.ml b/src/ocaml/typing/persistent_env.ml index 596922c58..9a20ed6eb 100644 --- a/src/ocaml/typing/persistent_env.ml +++ b/src/ocaml/typing/persistent_env.ml @@ -279,14 +279,8 @@ let check_pers_struct ~allow_hidden penv f1 f2 ~loc name = | Not_found -> let warn = Warnings.No_cmi_file(name, None) in Location.prerr_warning loc warn -<<<<<<< | Magic_numbers.Cmi.Error err -> - let msg = Format.asprintf "%a" Magic_numbers.Cmi.report_error err in -======= - | Cmi_format.Error err -> - let msg = Format.asprintf "%a" - Cmi_format.report_error err in ->>>>>>> + let msg = Format_doc.asprintf "%a" Magic_numbers.Cmi.report_error err in let warn = Warnings.No_cmi_file(name, Some msg) in Location.prerr_warning loc warn | Error err -> @@ -415,13 +409,6 @@ let report_error_doc ppf = Style.inline_code import Style.inline_code "-rectypes" -let () = - Location.register_error_of_exn - (function - | Error err -> - Some (Location.error_of_printer_file report_error err) - | _ -> None - ) (* helper for merlin *) @@ -430,19 +417,19 @@ let with_cmis penv f x = [R (penv.can_load_cmis, Can_load_cmis)] (fun () -> f x)) -<<<<<<< let forall ~found ~missing t = Std.Hashtbl.forall t.persistent_structures (fun name -> function | Missing -> missing name | Found (pers_struct, a) -> found name pers_struct.ps_filename pers_struct.ps_name a -======= + ) + +let () = Location.register_error_of_exn (function | Error err -> Some (Location.error_of_printer_file report_error_doc err) | _ -> None ->>>>>>> ) let report_error = Format_doc.compat report_error_doc diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index 4b5e75451..785153ac0 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -10,8 +10,6 @@ (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) -<<<<<<< -======= (* *) (**************************************************************************) @@ -174,9 +172,6 @@ let printed_signature sourcefile ppf sg = Warnings.check_fatal () end; Fmt.compat print_signature ppf t ->>>>>>> -(* *) -(**************************************************************************) (* Printing functions *) diff --git a/src/ocaml/typing/printtyp.mli b/src/ocaml/typing/printtyp.mli index dcb60c19b..90d636da6 100644 --- a/src/ocaml/typing/printtyp.mli +++ b/src/ocaml/typing/printtyp.mli @@ -16,8 +16,10 @@ (** Printing functions *) +open Format open Types + type namespace := Shape.Sig_component_kind.t val namespaced_ident: namespace -> Ident.t -> string @@ -45,11 +47,57 @@ module type Printers := sig (** Print a type path taking account of [-short-paths]. Calls should be within [wrap_printing_env]. *) -<<<<<<< -val wrap_printing_env: ?error:bool -> Env.t -> (unit -> 'a) -> 'a - (* Call the function using the environment for type path shortening *) - (* This affects all the printing functions below *) - (* Also, if [~error:true], then disable the loading of cmis *) + (** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want + multiple types to use common names for type variables, see + {!Out_type.prepare_for_printing} and {!Out_type.prepared_type_expr}. *) + val type_expr: type_expr printer + + val type_scheme: type_expr printer + + val shared_type_scheme: type_expr printer + (** [shared_type_scheme] is very similar to [type_scheme], but does not + reset the printing context first. This is intended to be used in cases + where the printing should have a particularly wide context, such as + documentation generators; most use cases, such as error messages, have + narrower contexts for which [type_scheme] is better suited. *) + + val type_expansion: + Out_type.type_or_scheme -> Errortrace.expanded_type printer + + val label : label_declaration printer + + val constructor : constructor_declaration printer + val constructor_arguments: constructor_arguments printer + + val extension_constructor: + Ident.t -> extension_constructor printer + (** Prints extension constructor with the type signature: + type ('a, 'b) bar += A of float + *) + + val extension_only_constructor: + Ident.t -> extension_constructor printer + (** Prints only extension constructor without type signature: + A of float + *) + + + val value_description: Ident.t -> value_description printer + val type_declaration: Ident.t -> type_declaration printer + val modtype_declaration: Ident.t -> modtype_declaration printer + val class_declaration: Ident.t -> class_declaration printer + val cltype_declaration: Ident.t -> class_type_declaration printer + + + val modtype: module_type printer + val signature: signature printer + val class_type: class_type printer +end + + val shorten_type_path: Env.t -> Path.t -> Path.t val shorten_module_type_path: Env.t -> Path.t -> Path.t val shorten_module_path: Env.t -> Path.t -> Path.t @@ -91,86 +139,6 @@ module Conflicts: sig end -val reset: unit -> unit - -(** Print out a type. This will pick names for type variables, and will not - reuse names for common type variables shared across multiple type - expressions. (It will also reset the printing state, which matters for - other type formatters such as [prepared_type_expr].) If you want multiple - types to use common names for type variables, see [prepare_for_printing] and - [prepared_type_expr]. *) -val type_expr: formatter -> type_expr -> unit - -(** [prepare_for_printing] resets the global printing environment, a la [reset], - and prepares the types for printing by reserving names and marking loops. - Any type variables that are shared between multiple types in the input list - will be given the same name when printed with [prepared_type_expr]. *) -val prepare_for_printing: type_expr list -> unit - -(** [add_type_to_preparation ty] extend a previous type expression preparation - to the type expression [ty] -*) -val add_type_to_preparation: type_expr -> unit - -val prepared_type_expr: formatter -> type_expr -> unit -(** The function [prepared_type_expr] is a less-safe but more-flexible version - of [type_expr] that should only be called on [type_expr]s that have been - passed to [prepare_for_printing]. Unlike [type_expr], this function does no - extra work before printing a type; in particular, this means that any loops - in the type expression may cause a stack overflow (see #8860) since this - function does not mark any loops. The benefit of this is that if multiple - type expressions are prepared simultaneously and then printed with - [prepared_type_expr], they will use the same names for the same type - variables. *) - -val constructor_arguments: formatter -> constructor_arguments -> unit -val tree_of_type_scheme: type_expr -> out_type -val type_scheme: formatter -> type_expr -> unit -val prepared_type_scheme: formatter -> type_expr -> unit -val shared_type_scheme: formatter -> type_expr -> unit -(** [shared_type_scheme] is very similar to [type_scheme], but does not reset - the printing context first. This is intended to be used in cases where the - printing should have a particularly wide context, such as documentation - generators; most use cases, such as error messages, have narrower contexts - for which [type_scheme] is better suited. *) - -val tree_of_value_description: Ident.t -> value_description -> out_sig_item -val value_description: Ident.t -> formatter -> value_description -> unit -val label : formatter -> label_declaration -> unit -val add_constructor_to_preparation : constructor_declaration -> unit -val prepared_constructor : formatter -> constructor_declaration -> unit -val constructor : formatter -> constructor_declaration -> unit -val tree_of_type_declaration: - Ident.t -> type_declaration -> rec_status -> out_sig_item -val add_type_declaration_to_preparation : - Ident.t -> type_declaration -> unit -val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit -val type_declaration: Ident.t -> formatter -> type_declaration -> unit -val tree_of_extension_constructor: - Ident.t -> extension_constructor -> ext_status -> out_sig_item -val add_extension_constructor_to_preparation : - extension_constructor -> unit -val prepared_extension_constructor: - Ident.t -> formatter -> extension_constructor -> unit -val extension_constructor: - Ident.t -> formatter -> extension_constructor -> unit -(* Prints extension constructor with the type signature: - type ('a, 'b) bar += A of float -*) - -val extension_only_constructor: - Ident.t -> formatter -> extension_constructor -> unit -(* Prints only extension constructor without type signature: - A of float -*) - -val tree_of_module: - Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item -val modtype: formatter -> module_type -> unit -val signature: formatter -> signature -> unit -val tree_of_modtype: module_type -> out_module_type -val tree_of_modtype_declaration: - Ident.t -> modtype_declaration -> out_sig_item (** Print a list of functor parameters while adjusting the printing environment for each functor argument. @@ -187,53 +155,6 @@ val functor_parameters: ('b -> Format.formatter -> unit) -> (Ident.t option * 'b) list -> Format.formatter -> unit -type type_or_scheme = Type | Type_scheme - -val tree_of_signature: Types.signature -> out_sig_item list -val tree_of_typexp: type_or_scheme -> type_expr -> out_type -val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit -val class_type: formatter -> class_type -> unit -val tree_of_class_declaration: - Ident.t -> class_declaration -> rec_status -> out_sig_item -val class_declaration: Ident.t -> formatter -> class_declaration -> unit -val tree_of_cltype_declaration: - Ident.t -> class_type_declaration -> rec_status -> out_sig_item -val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit -val type_expansion : - type_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit -val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type -val report_ambiguous_type_error: - formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> - (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit - -val report_unification_error : - formatter -> - Env.t -> Errortrace.unification_error -> - ?type_expected_explanation:(formatter -> unit) -> - (formatter -> unit) -> (formatter -> unit) -> - unit - -val report_equality_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.equality_error -> - (formatter -> unit) -> (formatter -> unit) -> - unit - -val report_moregen_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.moregen_error -> - (formatter -> unit) -> (formatter -> unit) -> - unit - -val report_comparison_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.comparison_error -> - (formatter -> unit) -> (formatter -> unit) -> - unit - module Subtype : sig val report_error : formatter -> @@ -243,66 +164,6 @@ module Subtype : sig unit end -(* for toploop *) -val print_items: (Env.t -> signature_item -> 'a option) -> - Env.t -> signature_item list -> (out_sig_item * 'a option) list - -(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias - for Foo__bar. This pattern is used by the stdlib. *) -val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t -======= ->>>>>>> - - (** Print out a type. This will pick names for type variables, and will not - reuse names for common type variables shared across multiple type - expressions. (It will also reset the printing state, which matters for - other type formatters such as [prepared_type_expr].) If you want - multiple types to use common names for type variables, see - {!Out_type.prepare_for_printing} and {!Out_type.prepared_type_expr}. *) - val type_expr: type_expr printer - - val type_scheme: type_expr printer - - val shared_type_scheme: type_expr printer - (** [shared_type_scheme] is very similar to [type_scheme], but does not - reset the printing context first. This is intended to be used in cases - where the printing should have a particularly wide context, such as - documentation generators; most use cases, such as error messages, have - narrower contexts for which [type_scheme] is better suited. *) - - val type_expansion: - Out_type.type_or_scheme -> Errortrace.expanded_type printer - - val label : label_declaration printer - - val constructor : constructor_declaration printer - val constructor_arguments: constructor_arguments printer - - val extension_constructor: - Ident.t -> extension_constructor printer - (** Prints extension constructor with the type signature: - type ('a, 'b) bar += A of float - *) - - val extension_only_constructor: - Ident.t -> extension_constructor printer - (** Prints only extension constructor without type signature: - A of float - *) - - - val value_description: Ident.t -> value_description printer - val type_declaration: Ident.t -> type_declaration printer - val modtype_declaration: Ident.t -> modtype_declaration printer - val class_declaration: Ident.t -> class_declaration printer - val cltype_declaration: Ident.t -> class_type_declaration printer - - - val modtype: module_type printer - val signature: signature printer - val class_type: class_type printer - - end module Doc : Printers with type 'a printer := 'a Format_doc.printer diff --git a/src/ocaml/typing/rawprinttyp.ml b/src/ocaml/typing/rawprinttyp.ml new file mode 100644 index 000000000..00d94fc24 --- /dev/null +++ b/src/ocaml/typing/rawprinttyp.ml @@ -0,0 +1,147 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jacques Garrigue, Graduate School of Mathematics, Nagoya University *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +(* Print a raw type expression, with sharing *) + +open Format +open Types +open Asttypes +let longident = Pprintast.longident + +let raw_list pr ppf = function + [] -> fprintf ppf "[]" + | a :: l -> + fprintf ppf "@[<1>[%a%t]@]" pr a + (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) + +let kind_vars = ref [] +let kind_count = ref 0 + +let string_of_field_kind v = + match field_kind_repr v with + | Fpublic -> "Fpublic" + | Fabsent -> "Fabsent" + | Fprivate -> "Fprivate" + +let rec safe_repr v t = + match Transient_expr.coerce t with + {desc = Tlink t} when not (List.memq t v) -> + safe_repr (t::v) t + | t' -> t' + +let rec list_of_memo = function + Mnil -> [] + | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem + | Mlink rem -> list_of_memo !rem + +let print_name ppf = function + None -> fprintf ppf "None" + | Some name -> fprintf ppf "\"%s\"" name + +let path = Format_doc.compat Path.print + +let visited = ref [] +let rec raw_type ppf ty = + let ty = safe_repr [] ty in + if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin + visited := ty :: !visited; + fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;marks=%x;desc=@,%a}@]" + ty.id ty.level + (Transient_expr.get_scope ty) (Transient_expr.get_marks ty) + raw_type_desc ty.desc + end +and raw_type_list tl = raw_list raw_type tl +and raw_lid_type_list tl = + raw_list (fun ppf (lid, typ) -> + fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) + tl +and raw_type_desc ppf = function + Tvar name -> fprintf ppf "Tvar %a" print_name name + | Tarrow(l,t1,t2,c) -> + fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tconstr (p, tl, abbrev) -> + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p + raw_type_list tl + (raw_list path) (list_of_memo !abbrev) + | Tobject (t, nm) -> + fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t + (fun ppf -> + match !nm with None -> fprintf ppf " None" + | Some(p,tl) -> + fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) + | Tfield (f, k, t1, t2) -> + fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (string_of_field_kind k) + raw_type t1 raw_type t2 + | Tnil -> fprintf ppf "Tnil" + | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t + | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t + | Tsubst (t, Some t') -> + fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' + | Tunivar name -> fprintf ppf "Tunivar %a" print_name name + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + fprintf ppf + "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" + "row_fields=" + (raw_list (fun ppf (l, f) -> + fprintf ppf "@[%s,@ %a@]" l raw_field f)) + fields + "row_more=" raw_type more + "row_closed=" closed + "row_fixed=" raw_row_fixed fixed + "row_name=" + (fun ppf -> + match name with None -> fprintf ppf "None" + | Some(p,tl) -> + fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) + | Tpackage (p, fl) -> + fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl +and raw_row_fixed ppf = function +| None -> fprintf ppf "None" +| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" +| Some Types.Rigid -> fprintf ppf "Some Rigid" +| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t +| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p + +and raw_field ppf rf = + match_row_field + ~absent:(fun _ -> fprintf ppf "RFabsent") + ~present:(function + | None -> + fprintf ppf "RFpresent None" + | Some t -> + fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) + ~either:(fun c tl m (_,e) -> + fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c + raw_type_list tl m + (fun ppf -> + match e with None -> fprintf ppf " RFnone" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) + rf + +let type_expr ppf t = + visited := []; kind_vars := []; kind_count := 0; + raw_type ppf t; + visited := []; kind_vars := [] diff --git a/src/ocaml/typing/rawprinttyp.mli b/src/ocaml/typing/rawprinttyp.mli new file mode 100644 index 000000000..205bf299e --- /dev/null +++ b/src/ocaml/typing/rawprinttyp.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jacques Garrigue, Graduate School of Mathematics, Nagoya University *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module provides function(s) for printing the internal representation of + type expressions. It is targetted at internal use when debbuging the + compiler itself. *) + +val type_expr: Format.formatter -> Types.type_expr -> unit diff --git a/src/ocaml/typing/stypes.ml b/src/ocaml/typing/stypes.ml index 79bd94512..338b4b349 100644 --- a/src/ocaml/typing/stypes.ml +++ b/src/ocaml/typing/stypes.ml @@ -148,14 +148,8 @@ let print_info pp prev_loc ti = printtyp_reset_maybe loc; Format.pp_print_string Format.str_formatter " "; Printtyp.wrap_printing_env ~error:false env -<<<<<<< (fun () -> Printtyp.shared_type_scheme Format.str_formatter typ); (* (fun () -> Printtyp.shared_type_scheme Format.str_formatter typ); *) -======= - (fun () -> - Printtyp.shared_type_scheme Format.str_formatter typ - ); ->>>>>>> Format.pp_print_newline Format.str_formatter (); let s = Format.flush_str_formatter () in output_string pp s; diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml index c8ac1ec75..51b703090 100644 --- a/src/ocaml/typing/typeclass.ml +++ b/src/ocaml/typing/typeclass.ml @@ -1840,13 +1840,9 @@ let type_classes define_class approx kind env cls = )) cls in -<<<<<<< + let res, newenv = Ctype.with_local_level_for_class begin fun () -> -======= - let res, env = - Ctype.with_local_level_generalize_for_class begin fun () -> ->>>>>>> let (res, env) = List.fold_left (initial_env define_class approx) ([], env) cls in diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index a442ba616..f715aecc2 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -218,7 +218,8 @@ let deep_copy () = try TypeHash.find table ty with Not_found -> let ty' = - let {Types. level; id; desc; scope} = Transient_expr.repr ty in + let ({Types. level; id; desc; _} as texp) = Transient_expr.repr ty in + let scope = Transient_expr.get_scope texp in create_expr ~level ~id ~scope desc in TypeHash.add table ty ty'; @@ -1897,11 +1898,6 @@ and type_pat_aux let p = {p with ppat_loc=loc} in type_pat tps category p expected_ty (* TODO: record 'extra' to remember about interval *) -<<<<<<< - | Ppat_interval _ -> - raise (error (loc, !!penv, Invalid_interval)) -======= ->>>>>>> | Ppat_tuple spl -> assert (List.length spl >= 2); let expected_tys = @@ -3302,18 +3298,14 @@ let name_cases default lst = (* Typing of expressions *) -(** [sexp_for_hint] is used by error messages to report literals in their +(** [sdesc_for_hint] is used by error messages to report literals in their original formatting *) -let unify_exp ~sexp env exp expected_ty = +let unify_exp ?sdesc_for_hint env exp expected_ty = let loc = proper_exp_loc exp in try unify_exp_types loc env exp.exp_type expected_ty with Error(loc, env, Expr_type_clash(err, tfc, None)) -> -<<<<<<< raise (error(loc, env, Expr_type_clash(err, tfc, sdesc_for_hint))) -======= - raise (Error(loc, env, Expr_type_clash(err, tfc, Some sexp))) ->>>>>>> (* If [is_inferred e] is true, [e] will be typechecked without using the "expected type" provided by the context. *) @@ -3473,18 +3465,18 @@ and type_expect ?recarg env sexp ty_expected_explained = and type_expect_ ?(recarg=Rejected) - env sexp ty_expected_explained = + env sdesc_for_hint ty_expected_explained = let { ty = ty_expected; explanation } = ty_expected_explained in - let loc = sexp.pexp_loc in + let loc = sdesc_for_hint.pexp_loc in (* Record the expression type before unifying it with the expected type *) let with_explanation = with_explanation explanation in (* Unify the result with [ty_expected], enforcing the current level *) let rue exp = with_explanation (fun () -> - unify_exp ~sexp env (re exp) (instance ty_expected)); + unify_exp ~sdesc_for_hint env (re exp) (instance ty_expected)); exp in - match sexp.pexp_desc with + match sdesc_for_hint.pexp_desc with | Pexp_ident lid -> let path, desc = type_ident env ~recarg lid in let exp_desc = @@ -3509,7 +3501,7 @@ and type_expect_ rue { exp_desc; exp_loc = loc; exp_extra = []; exp_type = instance desc.val_type; - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env } | Pexp_constant({pconst_desc = Pconst_string (str, _, _); _} as cst) -> ( let cst = constant_or_raise env loc cst in @@ -3529,14 +3521,14 @@ and type_expect_ in if is_format then let format_parsetree = - { (type_format loc str env) with pexp_loc = sexp.pexp_loc } in + { (type_format loc str env) with pexp_loc = sdesc_for_hint.pexp_loc } in type_expect env format_parsetree ty_expected_explained else rue { exp_desc = Texp_constant cst; exp_loc = loc; exp_extra = []; exp_type = instance Predef.type_string; - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env } ) | Pexp_constant cst -> @@ -3545,7 +3537,7 @@ and type_expect_ exp_desc = Texp_constant cst; exp_loc = loc; exp_extra = []; exp_type = type_constant cst; - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env } | Pexp_let(Nonrecursive, [{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody) @@ -3553,7 +3545,7 @@ and type_expect_ (* TODO: allow non-empty attributes? *) let sval = vb_exp_constraint vb in type_expect env - {sexp with + {sdesc_for_hint with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} ty_expected_explained | Pexp_let(rec_flag, spat_sexp_list, sbody) -> @@ -3617,13 +3609,13 @@ and type_expect_ end ~before_generalize:(fun (_pat_exp_list, body, new_env) -> (* The "body" component of the scope escape check. *) - unify_exp ~sexp new_env body (newvar ())) + unify_exp ~sdesc_for_hint new_env body (newvar ())) in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); exp_loc = loc; exp_extra = []; exp_type = body.exp_type; - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env } | Pexp_function (params, body_constraint, body) -> let in_function = ty_expected_explained, loc in @@ -3676,7 +3668,7 @@ and type_expect_ exp_extra = List.map (fun (id, txt_loc, uid) -> Texp_newtype' (id, txt_loc, uid), txt_loc.loc, []) newtypes; exp_type; - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env; } | Pexp_apply(sfunct, sargs) -> @@ -3725,7 +3717,7 @@ and type_expect_ exp_desc = Texp_apply(funct, args); exp_loc = loc; exp_extra = []; exp_type = ty_res; - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env } end | Pexp_match(sarg, caselist) -> @@ -3765,7 +3757,7 @@ and type_expect_ exp_desc = Texp_match(arg, val_cases, eff_cases, partial); exp_loc = loc; exp_extra = []; exp_type = instance ty_expected; - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env } | Pexp_try(sbody, caselist) -> let body = type_expect env sbody ty_expected_explained in @@ -3795,7 +3787,7 @@ and type_expect_ exp_desc = Texp_try(body, exn_cases, eff_cases); exp_loc = loc; exp_extra = []; exp_type = body.exp_type; - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env } | Pexp_tuple sexpl -> assert (List.length sexpl >= 2); @@ -3812,10 +3804,10 @@ and type_expect_ exp_loc = loc; exp_extra = []; (* Keep sharing *) exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); - exp_attributes = sexp.pexp_attributes; + exp_attributes = sdesc_for_hint.pexp_attributes; exp_env = env } | Pexp_construct(lid, sarg) -> - type_construct env ~sexp lid sarg ty_expected_explained + type_construct env ~sexp:sdesc_for_hint lid sarg ty_expected_explained | Pexp_variant(l, sarg) -> (* Keep sharing *) let ty_expected1 = protect_expansion env ty_expected in @@ -4162,31 +4154,25 @@ and type_expect_ let (obj,meth,typ) = with_local_level_generalize_structure_if_principal (fun () -> type_send env loc explanation e met) -<<<<<<< ~post:(fun (_,_,typ) -> generalize_structure typ) -======= in let typ = match get_desc typ with ->>>>>>> - in - let typ = - match get_desc typ with - | Tpoly (ty, []) -> - instance ty - | Tpoly (ty, tl) -> - if !Clflags.principal && get_level typ <> generic_level then - Location.prerr_warning loc - (Warnings.Not_principal "this use of a polymorphic method"); - snd (instance_poly ~fixed:false tl ty) - | Tvar _ -> - let ty' = newvar () in - unify env (instance typ) (newty(Tpoly(ty',[]))); - (* if not !Clflags.nolabels then - Location.prerr_warning loc (Warnings.Unknown_method met); *) - ty' - | _ -> - assert false + | Tpoly (ty, []) -> + instance ty + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this use of a polymorphic method"); + snd (instance_poly ~fixed:false tl ty) + | Tvar _ -> + let ty' = newvar () in + unify env (instance typ) (newty(Tpoly(ty',[]))); + (* if not !Clflags.nolabels then + Location.prerr_warning loc (Warnings.Unknown_method met); *) + ty' + | _ -> + assert false in rue { exp_desc = Texp_send(obj, meth); @@ -4439,35 +4425,8 @@ and type_expect_ generalize_and_check_univars env "method" exp ty_expected vars end in -<<<<<<< - { exp with exp_type = instance ty } -======= - | Tpoly (ty, tl) -> - if !Clflags.principal && get_level typ <> generic_level then - Location.prerr_warning loc - (not_principal "this use of a polymorphic method"); - snd (instance_poly ~fixed:false tl ty) ->>>>>>> - | Tvar _ -> -<<<<<<< -======= - { exp with exp_type = instance ty } - | Tpoly (ty', tl) -> - (* One more level to generalize locally *) - let (exp, vars) = - with_local_level_generalize begin fun () -> - let vars, ty'' = - with_local_level_generalize_structure_if_principal - (fun () -> instance_poly ~fixed:true tl ty') - in - let exp = type_expect env sbody (mk_expected ty'') in - (exp, vars) - end - in - check_univars env "method" exp ty_expected vars; { exp with exp_type = instance ty } | Tvar _ -> ->>>>>>> let exp = type_exp env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in unify_exp ~sexp env exp ty; @@ -4476,13 +4435,8 @@ and type_expect_ in re { exp with exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } -<<<<<<< | Pexp_newtype({txt=name} as label_loc, sbody) -> let body, ety, id, uid = type_newtype loc env name (fun env -> -======= - | Pexp_newtype(name, sbody) -> - let body, ety = type_newtype env name (fun env -> ->>>>>>> let expr = type_exp env sbody in expr, expr.exp_type) in @@ -4490,12 +4444,7 @@ and type_expect_ any new extra node in the typed AST. *) rue { body with exp_loc = loc; exp_type = ety; exp_extra = -<<<<<<< (Texp_newtype' (id, label_loc, uid), loc, sexp.pexp_attributes) :: body.exp_extra } -======= - (Texp_newtype name.txt, loc, sexp.pexp_attributes) :: body.exp_extra - } ->>>>>>> | Pexp_pack m -> let (p, fl) = match get_desc (Ctype.expand_head env (instance ty_expected)) with @@ -4791,13 +4740,8 @@ and type_constraint_expect nodes for the newtype properly linked. *) and type_newtype -<<<<<<< : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr * Ident.t * Uid.t = fun loc env name type_body -> -======= - : type a. _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr = - fun env { txt = name; loc = name_loc } type_body -> ->>>>>>> let ty = if Typetexp.valid_tyvar_name name then newvar ~name () @@ -4949,13 +4893,8 @@ and type_function match params_suffix with | { pparam_desc = Pparam_newtype newtype; pparam_loc = _ } :: rest -> (* Check everything else in the scope of (type a). *) -<<<<<<< let (params, body, newtypes, contains_gadt), exp_type, nt_id, nt_uid = type_newtype loc env newtype.txt (fun env -> -======= - let (params, body, newtypes, contains_gadt), exp_type = - type_newtype env newtype (fun env -> ->>>>>>> let exp_type, params, body, newtypes, contains_gadt = (* mimic the typing of Pexp_newtype by minting a new type var, like [type_exp]. @@ -5460,15 +5399,10 @@ and type_label_exp create env loc ty_expected if create then raise (error(loc, env, Private_type ty_expected)) else -<<<<<<< raise (error(lid.loc, env, Private_label(lid.txt, ty_expected))); let snap = if vars = [] then None else Some (Btype.snapshot ()) in let arg = type_argument env sarg ty_arg (instance ty_arg) in (vars, ty_arg, snap, arg) -======= - raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); - (vars, type_argument env sarg ty_arg (instance ty_arg)) ->>>>>>> end ~before_generalize:(fun (_,arg) -> may_lower_contravariant env arg) in @@ -5803,7 +5737,7 @@ and type_application env funct sargs = let ty = funct.exp_type in type_args [] ty (instance ty) sargs -and type_construct env ~sexp lid sarg ty_expected_explained = +and type_construct env loc lid sarg ty_expected_explained attrs = let { ty = ty_expected; explanation } = ty_expected_explained in let expected_type = match extract_concrete_variant env ty_expected with @@ -5813,13 +5747,8 @@ and type_construct env ~sexp lid sarg ty_expected_explained = | Not_a_variant_type -> let srt = wrong_kind_sort_of_constructor lid.txt in let ctx = Expression explanation in -<<<<<<< let err = Wrong_expected_kind(srt, ctx, ty_expected) in raise (error (loc, env, err)) -======= - let error = Wrong_expected_kind(srt, ctx, ty_expected) in - raise (Error (sexp.pexp_loc, env, error)) ->>>>>>> in let constrs = Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env @@ -5833,41 +5762,37 @@ and type_construct env ~sexp lid sarg ty_expected_explained = match sarg with None -> [] | Some {pexp_desc = Pexp_tuple sel} when - constr.cstr_arity > 1 - || Builtin_attributes.explicit_arity sexp.pexp_attributes + constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs -> sel | Some se -> [se] in if List.length sargs <> constr.cstr_arity then -<<<<<<< raise(error(loc, env, Constructor_arity_mismatch (lid.txt, constr.cstr_arity, List.length sargs))); -======= - raise(Error(sexp.pexp_loc, env, - Constructor_arity_mismatch - (lid.txt, constr.cstr_arity, List.length sargs))); ->>>>>>> let separate = !Clflags.principal || Env.has_local_constraints env in let ty_args, ty_res, texp = - with_local_level_generalize_structure_if separate begin fun () -> + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> let ty_args, ty_res, texp = - with_local_level_generalize_structure_if separate begin fun () -> + with_local_level_if separate begin fun () -> let (ty_args, ty_res, _) = instance_constructor Keep_existentials_flexible constr in let texp = re { exp_desc = Texp_construct(lid, constr, []); - exp_loc = sexp.pexp_loc; exp_extra = []; + exp_loc = loc; exp_extra = []; exp_type = ty_res; - exp_attributes = sexp.pexp_attributes; + exp_attributes = attrs; exp_env = env } in (ty_args, ty_res, texp) end + ~post: begin fun (_, ty_res, texp) -> + generalize_structure ty_res; + with_explanation explanation (fun () -> + unify_exp env {texp with exp_type = instance ty_res} + (instance ty_expected)); + end in - with_explanation explanation (fun () -> - unify_exp ~sexp env {texp with exp_type = instance ty_res} - (instance ty_expected)); - (ty_args, ty_res, texp) + ((ty_args, ty_res, texp), ty_res::ty_args) end in let ty_args0, ty_res = @@ -5876,7 +5801,7 @@ and type_construct env ~sexp lid sarg ty_expected_explained = | _ -> assert false in let texp = {texp with exp_type = ty_res} in - if not separate then unify_exp ~sexp env texp (instance ty_expected); + if not separate then unify_exp env texp (instance ty_expected); let recarg = match constr.cstr_inlined with | None -> Rejected @@ -5889,11 +5814,7 @@ and type_construct env ~sexp lid sarg ty_expected_explained = Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> Required | _ -> -<<<<<<< raise (error(loc, env, Inlined_record_expected)) -======= - raise (Error(sexp.pexp_loc, env, Inlined_record_expected)) ->>>>>>> end in let args = @@ -5902,17 +5823,9 @@ and type_construct env ~sexp lid sarg ty_expected_explained = if constr.cstr_private = Private then begin match constr.cstr_tag with | Cstr_extension _ -> -<<<<<<< raise_error (error(loc, env, Private_constructor (constr, ty_res))) -======= - raise(Error(sexp.pexp_loc, env, Private_constructor (constr, ty_res))) ->>>>>>> | Cstr_constant _ | Cstr_block _ | Cstr_unboxed -> -<<<<<<< raise_error (error(loc, env, Private_type ty_res)); -======= - raise (Error(sexp.pexp_loc, env, Private_type ty_res)); ->>>>>>> end; (* NOTE: shouldn't we call "re" on this final expression? -- AF *) { texp with @@ -5937,7 +5850,6 @@ and type_statement ?explanation env sexp = | _ -> false in (* Raise the current level to detect non-returning functions *) -<<<<<<< let exp = with_local_level (fun () -> type_exp env sexp) in let subexp = final_subexpression exp in let ty = expand_head env exp.exp_type in @@ -5956,26 +5868,6 @@ and type_statement ?explanation env sexp = if not !has_errors then check_partial_application ~statement:true exp; enforce_current_level env ty; exp -======= - with_local_level_generalize (fun () -> type_exp env sexp) - ~before_generalize: begin fun exp -> - let subexp = final_subexpression exp in - let ty = expand_head env exp.exp_type in - if is_Tvar ty - && get_level ty > get_current_level () - && not (allow_polymorphic subexp) then - Location.prerr_warning - subexp.exp_loc - Warnings.Nonreturning_statement; - if !Clflags.strict_sequence then - let expected_ty = instance Predef.type_unit in - with_explanation explanation (fun () -> - unify_exp ~sexp env exp expected_ty) - else begin - check_partial_application ~statement:true exp; - enforce_current_level env ty - end ->>>>>>> end (* Most of the arguments are the same as [type_cases]. diff --git a/src/ocaml/typing/typecore.ml.rej b/src/ocaml/typing/typecore.ml.rej new file mode 100644 index 000000000..a9dfc06da --- /dev/null +++ b/src/ocaml/typing/typecore.ml.rej @@ -0,0 +1,39 @@ +--- typecore.ml 2024-06-27 15:42:08.730793912 +0200 ++++ typecore.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -4247,7 +4389,7 @@ + | Pexp_letmodule(name, smodl, sbody) -> + let lv = get_current_level () in + let (id, pres, modl, _, body) = +- with_local_level begin fun () -> ++ with_local_level_generalize begin fun () -> + let modl, pres, id, new_env = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let modl, md_shape = !type_module env smodl in +@@ -4258,7 +4400,7 @@ + | _ -> Mp_present + in + let scope = create_scope () in +- let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in ++ let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let md_shape = Shape.set_uid_if_none md_shape md_uid in + let md = + { md_type = modl.mod_type; md_attributes = []; +@@ -4286,7 +4428,7 @@ + let body = type_expect new_env sbody ty_expected_explained in + (id, pres, modl, new_env, body) + end +- ~post: begin fun (_id, _pres, _modl, new_env, body) -> ++ ~before_generalize: begin fun (_id, _pres, _modl, new_env, body) -> + (* Ensure that local definitions do not leak. *) + (* required for implicit unpack *) + enforce_current_level new_env body.exp_type +@@ -4355,8 +4497,7 @@ + } + | Pexp_poly(sbody, sty) -> + let ty, cty = +- with_local_level_if_principal +- ~post:(fun (ty,_) -> generalize_structure ty) ++ with_local_level_generalize_structure_if_principal + begin fun () -> + match sty with None -> protect_expansion env ty_expected, None + | Some sty -> diff --git a/src/ocaml/typing/typecore.mli b/src/ocaml/typing/typecore.mli index caca733b4..298a080bc 100644 --- a/src/ocaml/typing/typecore.mli +++ b/src/ocaml/typing/typecore.mli @@ -139,12 +139,9 @@ val option_some: Env.t -> Typedtree.expression -> Typedtree.expression val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression val extract_option_type: Env.t -> type_expr -> type_expr val generalizable: int -> type_expr -> bool -<<<<<<< val generalize_structure_exp: Typedtree.expression -> unit type delayed_check val delayed_checks: delayed_check list ref -======= ->>>>>>> val reset_delayed_checks: unit -> unit val force_delayed_checks: unit -> unit diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index 1c9df8b95..a3fe48b32 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -1901,12 +1901,8 @@ let explain_unbound_gen ppf tv tl typ kwd pr = fprintf ppf ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" kwd (Style.as_inline_code pr) ti -<<<<<<< - (Style.as_inline_code Printtyp.prepared_type_expr) tv - (* kwd pr ti Printtyp.prepared_type_expr tv *) -======= (Style.as_inline_code Out_type.prepared_type_expr) tv ->>>>>>> + (* kwd pr ti Printtyp.prepared_type_expr tv *) with Not_found -> () let explain_unbound ppf tv tl typ kwd lab = diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml index bbea6f43c..792b04cd5 100644 --- a/src/ocaml/typing/typedtree.ml +++ b/src/ocaml/typing/typedtree.ml @@ -892,12 +892,6 @@ let split_pattern pat = let vals1, exns1 = split_pattern cp1 in let vals2, exns2 = split_pattern cp2 in combine_opts (into cpat) vals1 vals2, -<<<<<<< -======= - combine_opts (into cpat) exns1 exns2 - in - split_pattern pat ->>>>>>> (* We could change the pattern type for exception patterns to [Predef.exn], but it doesn't really matter. *) combine_opts (into cpat) exns1 exns2 diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli index 44db63a2d..26d39471c 100644 --- a/src/ocaml/typing/typedtree.mli +++ b/src/ocaml/typing/typedtree.mli @@ -927,7 +927,6 @@ val pat_bound_idents_full: (** Splits an or pattern into its value (left) and exception (right) parts. *) val split_pattern: computation general_pattern -> pattern option * pattern option -<<<<<<< (** Whether an expression looks nice as the subject of a sentence in a error message. *) @@ -937,5 +936,3 @@ val exp_is_nominal : expression -> bool val unpack_functor_me : module_expr -> functor_parameter * module_expr val unpack_functor_mty : module_type -> functor_parameter * module_type -======= ->>>>>>> diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index e14848ce5..39f5afcb1 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -1412,12 +1412,7 @@ and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr = ((path, lid, tcstr) :: rev_tcstrs, sg) - -<<<<<<< and transl_signature ?(keep_warnings = false) ?(toplevel = false) env sg = -======= -and transl_signature env sg = ->>>>>>> let names = Signature_names.create () in let rec transl_sig env sg = match sg with diff --git a/src/ocaml/typing/typetexp.ml b/src/ocaml/typing/typetexp.ml index c6d045543..eeb912b91 100644 --- a/src/ocaml/typing/typetexp.ml +++ b/src/ocaml/typing/typetexp.ml @@ -793,15 +793,12 @@ let rec make_fixed_univars mark ty = | _ -> Btype.iter_type_expr (make_fixed_univars mark) ty end -<<<<<<< -======= let make_fixed_univars ty = with_type_mark (fun mark -> make_fixed_univars mark ty) let transl_type env policy styp = transl_type env ~policy ~row_context:[] styp ->>>>>>> let transl_simple_type env ?univars ~closed styp = TyVarEnv.reset_locals ?univars (); diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml index 8bb0532f6..c3eb54677 100644 --- a/src/ocaml/utils/clflags.ml +++ b/src/ocaml/utils/clflags.ml @@ -31,246 +31,117 @@ let opaque = ref false let unboxed_types = ref false let locations = ref true -<<<<<<< -======= -let dump_parsetree = ref false (* -dparsetree *) -and dump_typedtree = ref false (* -dtypedtree *) -and dump_shape = ref false (* -dshape *) -and dump_matchcomp = ref false (* -dmatchcomp *) -and dump_rawlambda = ref false (* -drawlambda *) -and dump_lambda = ref false (* -dlambda *) -and dump_rawclambda = ref false (* -drawclambda *) ->>>>>>> -<<<<<<< -======= -and dump_cmm = ref false (* -dcmm *) -let dump_selection = ref false (* -dsel *) -let dump_combine = ref false (* -dcombine *) -let dump_cse = ref false (* -dcse *) -let dump_live = ref false (* -dlive *) -let dump_spill = ref false (* -dspill *) -let dump_split = ref false (* -dsplit *) -let dump_interf = ref false (* -dinterf *) -let dump_prefer = ref false (* -dprefer *) -let dump_interval = ref false (* -dinterval *) -let dump_regalloc = ref false (* -dalloc *) -let dump_reload = ref false (* -dreload *) -let dump_scheduling = ref false (* -dscheduling *) -let dump_linear = ref false (* -dlinear *) -let keep_startup_file = ref false (* -dstartup *) -let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *) +(* This is used by the -save-ir-after option. *) +module Compiler_ir = struct + type t = Linear -let native_code = ref false (* set to true under ocamlopt *) ->>>>>>> -<<<<<<< -======= -let dlcode = ref true (* not -nodynlink *) + let all = [ + Linear; + ] -let pic_code = ref (match Config.architecture with (* -fPIC *) - | "amd64" | "s390x" -> true - | _ -> false) - -let runtime_variant = ref "" - ->>>>>>> -<<<<<<< -======= - in - save_ir_after := new_passes + let extension t = + let ext = + match t with + | Linear -> "linear" + in + ".cmir-" ^ ext + + (** [extract_extension_with_pass filename] returns the IR whose extension + is a prefix of the extension of [filename], and the suffix, + which can be used to distinguish different passes on the same IR. + For example, [extract_extension_with_pass "foo.cmir-linear123"] + returns [Some (Linear, "123")]. *) + let extract_extension_with_pass filename = + let ext = Filename.extension filename in + let ext_len = String.length ext in + if ext_len <= 0 then None + else begin + let is_prefix ir = + let s = extension ir in + let s_len = String.length s in + s_len <= ext_len && s = String.sub ext 0 s_len + in + let drop_prefix ir = + let s = extension ir in + let s_len = String.length s in + String.sub ext s_len (ext_len - s_len) + in + let ir = List.find_opt is_prefix all in + match ir with + | None -> None + | Some ir -> Some (ir, drop_prefix ir) + end +end -module Dump_option = struct - type t = - | Source - | Parsetree - | Typedtree - | Shape - | Match_comp - | Raw_lambda - | Lambda - | Instr - | Raw_clambda - | Clambda - | Raw_flambda - | Flambda - | Cmm - | Selection - | Combine - | CSE - | Live - | Spill - | Split - | Interf - | Prefer - | Regalloc - | Scheduling - | Linear - | Interval - let compare (op1 : t) op2 = - Stdlib.compare op1 op2 +(* This is used by the -stop-after option. *) +module Compiler_pass = struct + (* If you add a new pass, the following must be updated: + - the variable `passes` below + - the manpages in man/ocaml{c,opt}.m + - the manual manual/src/cmds/unified-options.etex + *) + type t = Parsing | Typing | Lambda | Scheduling | Emit let to_string = function - | Source -> "source" - | Parsetree -> "parsetree" - | Typedtree -> "typedtree" - | Shape -> "shape" - | Match_comp -> "matchcomp" - | Raw_lambda -> "rawlambda" + | Parsing -> "parsing" + | Typing -> "typing" | Lambda -> "lambda" - | Instr -> "instr" - | Raw_clambda -> "rawclambda" - | Clambda -> "clambda" - | Raw_flambda -> "rawflambda" - | Flambda -> "flambda" - | Cmm -> "cmm" - | Selection -> "selection" - | Combine -> "combine" - | CSE -> "cse" - | Live -> "live" - | Spill -> "spill" - | Split -> "split" - | Interf -> "interf" - | Prefer -> "prefer" - | Regalloc -> "regalloc" | Scheduling -> "scheduling" - | Linear -> "linear" - | Interval -> "interval" + | Emit -> "emit" let of_string = function - | "source" -> Some Source - | "parsetree" -> Some Parsetree - | "typedtree" -> Some Typedtree - | "shape" -> Some Shape - | "matchcomp" -> Some Match_comp - | "rawlambda" -> Some Raw_lambda + | "parsing" -> Some Parsing + | "typing" -> Some Typing | "lambda" -> Some Lambda - | "instr" -> Some Instr - | "rawclambda" -> Some Raw_clambda - | "clambda" -> Some Clambda - | "rawflambda" -> Some Raw_flambda - | "flambda" -> Some Flambda - | "cmm" -> Some Cmm - | "selection" -> Some Selection - | "combine" -> Some Combine - | "cse" -> Some CSE - | "live" -> Some Live - | "spill" -> Some Spill - | "split" -> Some Split - | "interf" -> Some Interf - | "prefer" -> Some Prefer - | "regalloc" -> Some Regalloc | "scheduling" -> Some Scheduling - | "linear" -> Some Linear - | "interval" -> Some Interval + | "emit" -> Some Emit | _ -> None - let flag = function - | Source -> dump_source - | Parsetree -> dump_parsetree - | Typedtree -> dump_typedtree - | Shape -> dump_shape - | Match_comp -> dump_matchcomp - | Raw_lambda -> dump_rawlambda - | Lambda -> dump_lambda - | Instr -> dump_instr - | Raw_clambda -> dump_rawclambda - | Clambda -> dump_clambda - | Raw_flambda -> dump_rawflambda - | Flambda -> dump_flambda - | Cmm -> dump_cmm - | Selection -> dump_selection - | Combine -> dump_combine - | CSE -> dump_cse - | Live -> dump_live - | Spill -> dump_spill - | Split -> dump_split - | Interf -> dump_interf - | Prefer -> dump_prefer - | Regalloc -> dump_regalloc - | Scheduling -> dump_scheduling - | Linear -> dump_linear - | Interval -> dump_interval - - type middle_end = - | Flambda - | Any - | Closure - - type class_ = - | Frontend - | Bytecode - | Middle of middle_end - | Backend - - let _ = - (* no Closure-specific dump option for now, silence a warning *) - Closure - - let classify : t -> class_ = function - | Source - | Parsetree - | Typedtree - | Shape - | Match_comp - | Raw_lambda - | Lambda - -> Frontend - | Instr - -> Bytecode - | Raw_clambda - | Clambda - -> Middle Any - | Raw_flambda - | Flambda - -> Middle Flambda - | Cmm - | Selection - | Combine - | CSE - | Live - | Spill - | Split - | Interf - | Prefer - | Regalloc - | Scheduling - | Linear - | Interval - -> Backend - - let available (option : t) : (unit, string) result = - let pass = Result.ok () in - let ( let* ) = Result.bind in - let fail descr = - Error ( - Printf.sprintf - "this compiler does not support %s-specific options" - descr - ) in - let guard descr cond = - if cond then pass - else fail descr in - let check_bytecode = guard "bytecode" (not !native_code) in - let check_native = guard "native" !native_code in - let check_middle_end = function - | Flambda -> guard "flambda" Config.flambda - | Closure -> guard "closure" (not Config.flambda) - | Any -> pass - in - match classify option with - | Frontend -> - pass - | Bytecode -> - check_bytecode - | Middle middle_end -> - let* () = check_native in - check_middle_end middle_end - | Backend -> - check_native + let rank = function + | Parsing -> 0 + | Typing -> 1 + | Lambda -> 2 + | Scheduling -> 50 + | Emit -> 60 + + let passes = [ + Parsing; + Typing; + Lambda; + Scheduling; + Emit; + ] + let is_compilation_pass _ = true + let is_native_only = function + | Scheduling -> true + | Emit -> true + | _ -> false + + let enabled is_native t = not (is_native_only t) || is_native + let can_save_ir_after = function + | Scheduling -> true + | _ -> false + + let available_pass_names ~filter ~native = + passes + |> List.filter (enabled native) + |> List.filter filter + |> List.map to_string + + let compare a b = + compare (rank a) (rank b) + + let to_output_filename t ~prefix = + match t with + | Scheduling -> prefix ^ Compiler_ir.(extension Linear) + | _ -> Misc.fatal_error "Not supported" + + let of_input_filename name = + match Compiler_ir.extract_extension_with_pass name with + | Some (Linear, _) -> Some Emit + | None -> None end -module String = Misc.Stdlib.String - -let arg_spec = ref [] ->>>>>>> +let stop_after = ref None diff --git a/src/ocaml/utils/clflags.mli b/src/ocaml/utils/clflags.mli index 790c81e10..e7f99638c 100644 --- a/src/ocaml/utils/clflags.mli +++ b/src/ocaml/utils/clflags.mli @@ -39,67 +39,17 @@ val opaque : bool ref val unboxed_types : bool ref val locations : bool ref -<<<<<<< -======= -val dump_parsetree : bool ref -val dump_typedtree : bool ref -val dump_shape : bool ref -val dump_matchcomp : bool ref -val dump_rawlambda : bool ref -val dump_lambda : bool ref -val dump_rawclambda : bool ref ->>>>>>> -<<<<<<< -======= - val to_output_filename: t -> prefix:string -> string - val of_input_filename: string -> t option -end - -val stop_after : Compiler_pass.t option ref -val should_stop_after : Compiler_pass.t -> bool -val set_save_ir_after : Compiler_pass.t -> bool -> unit -val should_save_ir_after : Compiler_pass.t -> bool - -module Dump_option : sig - type t = - | Source - | Parsetree - | Typedtree - | Shape - | Match_comp - | Raw_lambda - | Lambda - | Instr - | Raw_clambda - | Clambda - | Raw_flambda - | Flambda - (* Note: no support for [-dflambda-let ] for now. *) - | Cmm - | Selection - | Combine - | CSE - | Live - | Spill - | Split - | Interf - | Prefer - | Regalloc - | Scheduling - | Linear - | Interval - - val compare : t -> t -> int +module Compiler_pass : sig + type t = Parsing | Typing | Lambda | Scheduling | Emit val of_string : string -> t option val to_string : t -> string - - val flag : t -> bool ref - - val available : t -> (unit, string) Result.t + val is_compilation_pass : t -> bool + val available_pass_names : filter:(t -> bool) -> native:bool -> string list + val can_save_ir_after : t -> bool + val compare : t -> t -> int + val to_output_filename: t -> prefix:string -> string + val of_input_filename: string -> t option end -val arg_spec : (string * Arg.spec * string) list ref - -(* [add_arguments __LOC__ args] will add the arguments from [args] at ->>>>>>> +val stop_after : Compiler_pass.t option ref diff --git a/src/ocaml/utils/compression.ml b/src/ocaml/utils/compression.ml new file mode 100644 index 000000000..384afb3b4 --- /dev/null +++ b/src/ocaml/utils/compression.ml @@ -0,0 +1,31 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, Collège de France and Inria project Cambium *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +external zstd_initialize: unit -> bool = "caml_zstd_initialize" + +let compression_supported = zstd_initialize () + +type [@warning "-unused-constructor"] extern_flags = + No_sharing (** Don't preserve sharing *) + | Closures (** Send function closures *) + | Compat_32 (** Ensure 32-bit compatibility *) + | Compression (** Optional compression *) + +external to_channel: out_channel -> 'a -> extern_flags list -> unit + = "caml_output_value" + +let output_value ch v = to_channel ch v [Compression] + +let input_value = Stdlib.input_value diff --git a/src/ocaml/utils/compression.mli b/src/ocaml/utils/compression.mli new file mode 100644 index 000000000..bdfb63da7 --- /dev/null +++ b/src/ocaml/utils/compression.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, Collège de France and Inria project Cambium *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val output_value : out_channel -> 'a -> unit +(** [Compression.output_value chan v] writes the representation + of [v] on channel [chan]. + If compression is supported, the marshaled data + representing value [v] is compressed before being written to + channel [chan]. + If compression is not supported, this function behaves like + {!Stdlib.output_value}. *) + +val input_value : in_channel -> 'a +(** [Compression.input_value chan] reads from channel [chan] the + byte representation of a structured value, as produced by + [Compression.output_value], and reconstructs and + returns the corresponding value. + If compression is not supported, this function behaves like + {!Stdlib.input_value}. *) + +val compression_supported : bool +(** Reports whether compression is supported. *) diff --git a/src/ocaml/utils/config.common.ml.in b/src/ocaml/utils/config.common.ml.in new file mode 100644 index 000000000..3603fe6c6 --- /dev/null +++ b/src/ocaml/utils/config.common.ml.in @@ -0,0 +1,163 @@ +(* @configure_input@ *) +#3 "utils/config.common.ml.in" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Portions of the Config module common to both the boot and main compiler. *) + +(* The main OCaml version string has moved to ../build-aux/ocaml_version.m4 *) +let version = Sys.ocaml_version + +let standard_library = + try + Sys.getenv "OCAMLLIB" + with Not_found -> + try + Sys.getenv "CAMLLIB" + with Not_found -> + standard_library_default + +let exec_magic_number = {magic|@EXEC_MAGIC_NUMBER@|magic} + (* exec_magic_number is duplicated in runtime/caml/exec.h *) +and cmi_magic_number = {magic|@CMI_MAGIC_NUMBER@|magic} +and cmo_magic_number = {magic|@CMO_MAGIC_NUMBER@|magic} +and cma_magic_number = {magic|@CMA_MAGIC_NUMBER@|magic} +and cmx_magic_number = {magic|@CMX_MAGIC_NUMBER@|magic} +and cmxa_magic_number = {magic|@CMXA_MAGIC_NUMBER@|magic} +and ast_impl_magic_number = {magic|@AST_IMPL_MAGIC_NUMBER@|magic} +and ast_intf_magic_number = {magic|@AST_INTF_MAGIC_NUMBER@|magic} +and cmxs_magic_number = {magic|@CMXS_MAGIC_NUMBER@|magic} +and cmt_magic_number = {magic|@CMT_MAGIC_NUMBER@|magic} +and linear_magic_number = {magic|@LINEAR_MAGIC_NUMBER@|magic} + +let safe_string = true +let default_safe_string = true +let naked_pointers = false + +let interface_suffix = ref ".mli" + +let max_tag = 243 +(* This is normally the same as in obj.ml, but we have to define it + separately because it can differ when we're in the middle of a + bootstrapping phase. *) +let lazy_tag = 246 + +let max_young_wosize = 256 +let stack_threshold = 32 (* see runtime/caml/config.h *) +let stack_safety_margin = 6 +let default_executable_name = + match Sys.os_type with + "Unix" -> "a.out" + | "Win32" | "Cygwin" -> "camlprog.exe" + | _ -> "camlprog" +type configuration_value = + | String of string + | Int of int + | Bool of bool + +let configuration_variables () = + let p x v = (x, String v) in + let p_int x v = (x, Int v) in + let p_bool x v = (x, Bool v) in +[ + p "version" version; + p "standard_library_default" standard_library_default; + p "standard_library" standard_library; + p "ccomp_type" ccomp_type; + p "c_compiler" c_compiler; + p "bytecode_cflags" bytecode_cflags; + p "ocamlc_cflags" bytecode_cflags; + p "bytecode_cppflags" bytecode_cppflags; + p "ocamlc_cppflags" bytecode_cppflags; + p "native_cflags" native_cflags; + p "ocamlopt_cflags" native_cflags; + p "native_cppflags" native_cppflags; + p "ocamlopt_cppflags" native_cppflags; + p "bytecomp_c_compiler" bytecomp_c_compiler; + p "native_c_compiler" native_c_compiler; + p "bytecomp_c_libraries" bytecomp_c_libraries; + p "native_c_libraries" native_c_libraries; + p "native_ldflags" native_ldflags; + p "native_pack_linker" native_pack_linker; + p_bool "native_compiler" native_compiler; + p "architecture" architecture; + p "model" model; + p_int "int_size" Sys.int_size; + p_int "word_size" Sys.word_size; + p "system" system; + p "asm" asm; + p_bool "asm_cfi_supported" asm_cfi_supported; + p_bool "with_frame_pointers" with_frame_pointers; + p "ext_exe" ext_exe; + p "ext_obj" ext_obj; + p "ext_asm" ext_asm; + p "ext_lib" ext_lib; + p "ext_dll" ext_dll; + p "os_type" Sys.os_type; + p "default_executable_name" default_executable_name; + p_bool "systhread_supported" systhread_supported; + p "host" host; + p "target" target; + p_bool "flambda" flambda; + p_bool "safe_string" safe_string; + p_bool "default_safe_string" default_safe_string; + p_bool "flat_float_array" flat_float_array; + p_bool "function_sections" function_sections; + p_bool "afl_instrument" afl_instrument; + p_bool "tsan" tsan; + p_bool "windows_unicode" windows_unicode; + p_bool "supports_shared_libraries" supports_shared_libraries; + p_bool "native_dynlink" native_dynlink; + p_bool "naked_pointers" naked_pointers; + + p "exec_magic_number" exec_magic_number; + p "cmi_magic_number" cmi_magic_number; + p "cmo_magic_number" cmo_magic_number; + p "cma_magic_number" cma_magic_number; + p "cmx_magic_number" cmx_magic_number; + p "cmxa_magic_number" cmxa_magic_number; + p "ast_impl_magic_number" ast_impl_magic_number; + p "ast_intf_magic_number" ast_intf_magic_number; + p "cmxs_magic_number" cmxs_magic_number; + p "cmt_magic_number" cmt_magic_number; + p "linear_magic_number" linear_magic_number; +] + +let print_config_value oc = function + | String s -> + Printf.fprintf oc "%s" s + | Int n -> + Printf.fprintf oc "%d" n + | Bool p -> + Printf.fprintf oc "%B" p + +let print_config oc = + let print (x, v) = + Printf.fprintf oc "%s: %a\n" x print_config_value v in + List.iter print (configuration_variables ()); + flush oc + +let config_var x = + match List.assoc_opt x (configuration_variables()) with + | None -> None + | Some v -> + let s = match v with + | String s -> s + | Int n -> Int.to_string n + | Bool b -> string_of_bool b + in + Some s + +let merlin = false diff --git a/src/ocaml/utils/config.fixed.ml b/src/ocaml/utils/config.fixed.ml new file mode 100644 index 000000000..25f09e380 --- /dev/null +++ b/src/ocaml/utils/config.fixed.ml @@ -0,0 +1,13 @@ +<<<<<<< +======= +let c_output_obj = "" +let c_has_debug_prefix_map = false +let as_has_debug_prefix_map = false +let bytecode_cflags = "" +let bytecode_cppflags = "" +let native_cflags = "" +let native_cppflags = "" +let bytecomp_c_libraries = "" +let bytecomp_c_compiler = "" +let native_c_compiler = c_compiler +>>>>>>> diff --git a/src/ocaml/utils/config.generated.ml.in b/src/ocaml/utils/config.generated.ml.in new file mode 100644 index 000000000..aa0345540 --- /dev/null +++ b/src/ocaml/utils/config.generated.ml.in @@ -0,0 +1,94 @@ +(* @configure_input@ *) +#2 "utils/config.generated.ml.in" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* This file is included in config_main.ml during the build rather + than compiled on its own *) + +let bindir = {@QS@|@ocaml_bindir@|@QS@} + +let standard_library_default = {@QS@|@ocaml_libdir@|@QS@} + +let ccomp_type = {@QS@|@ccomptype@|@QS@} +let c_compiler = {@QS@|@CC@|@QS@} +let c_output_obj = {@QS@|@outputobj@|@QS@} +let c_has_debug_prefix_map = @cc_has_debug_prefix_map@ +let as_has_debug_prefix_map = @as_has_debug_prefix_map@ +let bytecode_cflags = {@QS@|@bytecode_cflags@|@QS@} +let bytecode_cppflags = {@QS@|@bytecode_cppflags@|@QS@} +let native_cflags = {@QS@|@native_cflags@|@QS@} +let native_cppflags = {@QS@|@native_cppflags@|@QS@} + +let bytecomp_c_libraries = {@QS@|@zstd_libs@ @cclibs@|@QS@} +(* bytecomp_c_compiler and native_c_compiler have been supported for a + long time and are retained for backwards compatibility. + For programs that don't need compatibility with older OCaml releases + the recommended approach is to use the constituent variables + c_compiler, {bytecode,native}_c[pp]flags etc. directly. +*) +let bytecomp_c_compiler = + c_compiler ^ " " ^ bytecode_cflags ^ " " ^ bytecode_cppflags +let native_c_compiler = + c_compiler ^ " " ^ native_cflags ^ " " ^ native_cppflags +let native_c_libraries = {@QS@|@cclibs@|@QS@} +let native_ldflags = {@QS@|@native_ldflags@|@QS@} +let native_pack_linker = {@QS@|@PACKLD@|@QS@} +let default_rpath = {@QS@|@rpath@|@QS@} +let mksharedlibrpath = {@QS@|@mksharedlibrpath@|@QS@} +let ar = {@QS@|@AR@|@QS@} +let supports_shared_libraries = @supports_shared_libraries@ +let native_dynlink = @natdynlink@ +let mkdll = {@QS@|@mkdll_exp@|@QS@} +let mkexe = {@QS@|@mkexe_exp@|@QS@} +let mkmaindll = {@QS@|@mkmaindll_exp@|@QS@} + +let flambda = @flambda@ +let with_flambda_invariants = @flambda_invariants@ +let with_cmm_invariants = @cmm_invariants@ +let windows_unicode = @windows_unicode@ != 0 + +let flat_float_array = @flat_float_array@ + +let function_sections = @function_sections@ +let afl_instrument = @afl@ + +let native_compiler = @native_compiler@ + +let architecture = {@QS@|@arch@|@QS@} +let model = {@QS@|@model@|@QS@} +let system = {@QS@|@system@|@QS@} + +let asm = {@QS@|@AS@|@QS@} +let asm_cfi_supported = @asm_cfi_supported@ +let with_frame_pointers = @frame_pointers@ +let reserved_header_bits = @reserved_header_bits@ + +let ext_exe = {@QS@|@exeext@|@QS@} +let ext_obj = "." ^ {@QS@|@OBJEXT@|@QS@} +let ext_asm = "." ^ {@QS@|@S@|@QS@} +let ext_lib = "." ^ {@QS@|@libext@|@QS@} +let ext_dll = "." ^ {@QS@|@SO@|@QS@} + +let host = {@QS@|@host@|@QS@} +let target = {@QS@|@target@|@QS@} + +let systhread_supported = @systhread_support@ + +let flexdll_dirs = [@flexdll_dir@] + +let ar_supports_response_files = @ar_supports_response_files@ + +let tsan = @tsan@ diff --git a/src/ocaml/utils/config.mli b/src/ocaml/utils/config.mli index 6a9cd2bcd..e789006c5 100644 --- a/src/ocaml/utils/config.mli +++ b/src/ocaml/utils/config.mli @@ -46,33 +46,25 @@ val cmt_magic_number: string val index_magic_number: string (* Magic number for index files *) -<<<<<<< + val max_tag: int (* Biggest tag that can be stored in the header of a regular block. *) -======= + val bytecode_cflags : string (** The flags ocamlc should pass to the C compiler *) ->>>>>>> -<<<<<<< val flat_float_array: bool -======= + val bytecode_cppflags : string (** The flags ocamlc should pass to the C preprocessor *) ->>>>>>> -<<<<<<< (**/**) -======= val native_cflags : string (** The flags ocamlopt should pass to the C compiler *) ->>>>>>> -<<<<<<< val merlin : bool -======= + val native_cppflags : string (** The flags ocamlopt should pass to the C preprocessor *) ->>>>>>> (**/**) diff --git a/src/ocaml/utils/domainstate.ml.c b/src/ocaml/utils/domainstate.ml.c new file mode 100644 index 000000000..6dbae1d07 --- /dev/null +++ b/src/ocaml/utils/domainstate.ml.c @@ -0,0 +1,38 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* KC Sivaramakrishnan, Indian Institute of Technology, Madras */ +/* Stephen Dolan, University of Cambridge */ +/* */ +/* Copyright 2019 Indian Institute of Technology, Madras */ +/* Copyright 2019 University of Cambridge */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_CONFIG_H_NO_TYPEDEFS +#include "config.h" +let stack_ctx_words = Stack_ctx_words + +type t = +#define DOMAIN_STATE(type, name) | Domain_##name +#include "domain_state.tbl" +#undef DOMAIN_STATE + +let idx_of_field = + let curr = 0 in +#define DOMAIN_STATE(type, name) \ + let idx__##name = curr in \ + let curr = curr + 1 in +#include "domain_state.tbl" +#undef DOMAIN_STATE + let _ = curr in + function +#define DOMAIN_STATE(type, name) \ + | Domain_##name -> idx__##name +#include "domain_state.tbl" +#undef DOMAIN_STATE diff --git a/src/ocaml/utils/domainstate.mli.c b/src/ocaml/utils/domainstate.mli.c new file mode 100644 index 000000000..66a4750d4 --- /dev/null +++ b/src/ocaml/utils/domainstate.mli.c @@ -0,0 +1,24 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* KC Sivaramakrishnan, Indian Institute of Technology, Madras */ +/* Stephen Dolan, University of Cambridge */ +/* */ +/* Copyright 2019 Indian Institute of Technology, Madras */ +/* Copyright 2019 University of Cambridge */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +val stack_ctx_words : int + +type t = +#define DOMAIN_STATE(type, name) | Domain_##name +#include "domain_state.tbl" +#undef DOMAIN_STATE + +val idx_of_field : t -> int diff --git a/src/ocaml/utils/linkdeps.ml b/src/ocaml/utils/linkdeps.ml new file mode 100644 index 000000000..824c898e0 --- /dev/null +++ b/src/ocaml/utils/linkdeps.ml @@ -0,0 +1,142 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Hugo Heuzard *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Style = Misc.Style + +type compunit = string + +type filename = string + +type compunit_and_source = { + compunit : compunit; + filename : filename; +} + +module Compunit_and_source = struct + type t = compunit_and_source + module Set = Set.Make(struct type nonrec t = t let compare = compare end) +end + +type refs = Compunit_and_source.Set.t + +type t = { + complete : bool; + missing_compunits : (compunit, refs) Hashtbl.t; + provided_compunits : (compunit, filename list) Hashtbl.t; + badly_ordered_deps : (Compunit_and_source.t, refs) Hashtbl.t; +} + +type error = + | Missing_implementations of (compunit * compunit_and_source list) list + | Wrong_link_order of (compunit_and_source * compunit_and_source list) list + | Multiple_definitions of (compunit * filename list) list + +let create ~complete = { + complete; + missing_compunits = Hashtbl.create 17; + provided_compunits = Hashtbl.create 17; + badly_ordered_deps = Hashtbl.create 17; +} + +let required t compunit = Hashtbl.mem t.missing_compunits compunit + +let update t k f = + let v = Hashtbl.find_opt t k in + Hashtbl.replace t k (f v) + +let add_required t by (name : string) = + let add s = + Compunit_and_source.Set.add by + (Option.value s ~default:Compunit_and_source.Set.empty) in + (try + let filename = List.hd (Hashtbl.find t.provided_compunits name) in + update t.badly_ordered_deps {compunit = name; filename } add + with Not_found -> ()); + update t.missing_compunits name add + +let add t ~filename ~compunit ~provides ~requires = + List.iter (add_required t {compunit; filename}) requires; + List.iter (fun p -> + Hashtbl.remove t.missing_compunits p; + let l = Option.value ~default:[] + (Hashtbl.find_opt t.provided_compunits p) in + Hashtbl.replace t.provided_compunits p (filename :: l)) provides + +let check t = + let of_seq s = + Seq.map (fun (k,v) -> k, Compunit_and_source.Set.elements v) s + |> List.of_seq + in + let missing = of_seq (Hashtbl.to_seq t.missing_compunits) in + let badly_ordered_deps = of_seq (Hashtbl.to_seq t.badly_ordered_deps) in + let duplicated = + Hashtbl.to_seq t.provided_compunits + |> Seq.filter (fun (_, files) -> List.compare_length_with files 1 > 0) + |> List.of_seq + in + match duplicated, badly_ordered_deps, missing with + | [], [], [] -> None + | [], [], l -> + if t.complete + then Some (Missing_implementations l) + else None + | [], l, _ -> + Some (Wrong_link_order l) + | l, _, _ -> + Some (Multiple_definitions l) + +(* Error report *) + +open Format_doc + +let print_reference print_fname ppf {compunit; filename} = + fprintf ppf "%a (%a)" Style.inline_code compunit print_fname filename + +let pp_list_comma f = + pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") f + +let report_error_doc ~print_filename ppf = function + | Missing_implementations l -> + let print_modules ppf = + List.iter + (fun (md, rq) -> + fprintf ppf "@ @[%a referenced from %a@]" + Style.inline_code md + (pp_list_comma (print_reference print_filename)) rq) + in + fprintf ppf + "@[No implementation provided for the following modules:%a@]" + print_modules l + | Wrong_link_order l -> + let depends_on ppf (dep, depending) = + fprintf ppf "@ @[%a depends on %a@]" + (pp_list_comma (print_reference print_filename)) depending + (print_reference print_filename) dep + in + fprintf ppf "@[Wrong link order:%a@]" + (pp_list_comma depends_on) l + | Multiple_definitions l -> + let print ppf (compunit, files) = + fprintf ppf + "@ @[Multiple definitions of module %a in files %a@]" + Style.inline_code compunit + (pp_list_comma (Style.as_inline_code print_filename)) files + + in + fprintf ppf "@[ Duplicated implementations:%a@]" + (pp_list_comma print) l + +let report_error ~print_filename = + Format_doc.compat (report_error_doc ~print_filename) diff --git a/src/ocaml/utils/linkdeps.mli b/src/ocaml/utils/linkdeps.mli new file mode 100644 index 000000000..070b0e538 --- /dev/null +++ b/src/ocaml/utils/linkdeps.mli @@ -0,0 +1,64 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Hugo Heuzard *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t +(** The state of the linking check. + It keeps track of compilation units provided and required so far. *) + +type compunit = string + +type filename = string + +val create : complete:bool -> t +(** [create ~complete] returns an empty state. If [complete] is + [true], missing compilation units will be treated as errors. *) + +val add : t + -> filename:filename -> compunit:compunit + -> provides:compunit list -> requires:compunit list -> unit +(** [add t ~filename ~compunit ~provides ~requires] registers the + compilation unit [compunit] found in [filename] to [t]. + - [provides] are units and sub-units provided by [compunit] + - [requires] are units required by [compunit] + + [add] should be called in reverse topological order. *) + +val required : t -> compunit -> bool +(** [required t compunit] returns [true] if [compunit] is a dependency of + previously added compilation units. *) + +type compunit_and_source = { + compunit : compunit; + filename : filename; +} + +type error = + | Missing_implementations of (compunit * compunit_and_source list) list + | Wrong_link_order of (compunit_and_source * compunit_and_source list) list + | Multiple_definitions of (compunit * filename list) list + +val check : t -> error option +(** [check t] should be called once all the compilation units to be linked + have been added. It returns some error if: + - There are some missing implementations + and [complete] is [true] + - Some implementation appear + before their dependencies *) + + +val report_error : + print_filename:string Format_doc.printer -> error Format_doc.format_printer +val report_error_doc : + print_filename:string Format_doc.printer -> error Format_doc.printer diff --git a/src/ocaml/utils/load_path.ml b/src/ocaml/utils/load_path.ml index 8e6c0a8a5..2707339ba 100644 --- a/src/ocaml/utils/load_path.ml +++ b/src/ocaml/utils/load_path.ml @@ -106,16 +106,15 @@ let get_hidden_path_list () = List.rev_map Dir.path !hidden_dirs order. *) let prepend_add dir = List.iter (fun base -> - Result.iter (fun filename -> - let fn = Filename.concat dir.Dir.path base in - if dir.Dir.hidden then begin - STbl.replace !hidden_files base fn; - STbl.replace !hidden_files_uncap filename fn - end else begin - STbl.replace !visible_files base fn; - STbl.replace !visible_files_uncap filename fn - end) - (Misc.normalized_unit_filename base) + let fn = Filename.concat dir.Dir.path base in + let filename = Misc.normalized_unit_filename base in + if dir.Dir.hidden then begin + STbl.replace !hidden_files base fn; + STbl.replace !hidden_files_uncap filename fn + end else begin + STbl.replace !visible_files base fn; + STbl.replace !visible_files_uncap filename fn + end ) dir.Dir.files let init ~auto_include ~visible ~hidden = @@ -185,13 +184,10 @@ let add (dir : Dir.t) = in List.iter (fun base -> - Result.iter (fun ubase -> - let fn = Filename.concat dir.Dir.path base in - update base fn visible_files hidden_files; - update ubase fn visible_files_uncap hidden_files_uncap - ) - (Misc.normalized_unit_filename base) - ) + let fn = Filename.concat dir.Dir.path base in + update base fn visible_files hidden_files; + let ubase = Misc.normalized_unit_filename base in + update ubase fn visible_files_uncap hidden_files_uncap) dir.files; if dir.hidden then hidden_dirs := dir :: !hidden_dirs @@ -254,12 +250,9 @@ let find fn = let find_normalized_with_visibility fn = assert (not Config.merlin || Local_store.is_bound ()); - match Misc.normalized_unit_filename fn with - | Error _ -> raise Not_found - | Ok fn_uncap -> try if is_basename fn && not !Sys.interactive then - find_file_in_cache fn_uncap + find_file_in_cache (Misc.normalized_unit_filename fn) visible_files_uncap hidden_files_uncap else try @@ -268,6 +261,7 @@ let find_normalized_with_visibility fn = | Not_found -> (Misc.find_in_path_normalized (get_hidden_path_list ()) fn, Hidden) with Not_found -> + let fn_uncap = Misc.normalized_unit_filename fn in (!auto_include_callback Dir.find_normalized fn_uncap, Visible) let find_normalized fn = fst (find_normalized_with_visibility fn) diff --git a/src/utils/format_doc.ml b/src/utils/format_doc.ml new file mode 100644 index 000000000..1530c69da --- /dev/null +++ b/src/utils/format_doc.ml @@ -0,0 +1,481 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Doc = struct + + type box_type = + | H + | V + | HV + | HoV + | B + + type stag = Format.stag + + type element = + | Text of string + | With_size of int + | Open_box of { kind: box_type ; indent:int } + | Close_box + | Open_tag of Format.stag + | Close_tag + | Open_tbox + | Tab_break of { width : int; offset : int } + | Set_tab + | Close_tbox + | Simple_break of { spaces : int; indent: int } + | Break of { fits : string * int * string as 'a; breaks : 'a } + | Flush of { newline:bool } + | Newline + | If_newline + + | Deprecated of (Format.formatter -> unit) + + type t = { rev:element list } [@@unboxed] + + let empty = { rev = [] } + + let to_list doc = List.rev doc.rev + let add doc x = { rev = x :: doc.rev } + let fold f acc doc = List.fold_left f acc (to_list doc) + let append left right = { rev = right.rev @ left.rev } + + let format_open_box_gen ppf kind indent = + match kind with + | H-> Format.pp_open_hbox ppf () + | V -> Format.pp_open_vbox ppf indent + | HV -> Format.pp_open_hvbox ppf indent + | HoV -> Format.pp_open_hovbox ppf indent + | B -> Format.pp_open_box ppf indent + + let interpret_elt ppf = function + | Text x -> Format.pp_print_string ppf x + | Open_box { kind; indent } -> format_open_box_gen ppf kind indent + | Close_box -> Format.pp_close_box ppf () + | Open_tag tag -> Format.pp_open_stag ppf tag + | Close_tag -> Format.pp_close_stag ppf () + | Open_tbox -> Format.pp_open_tbox ppf () + | Tab_break {width;offset} -> Format.pp_print_tbreak ppf width offset + | Set_tab -> Format.pp_set_tab ppf () + | Close_tbox -> Format.pp_close_tbox ppf () + | Simple_break {spaces;indent} -> Format.pp_print_break ppf spaces indent + | Break {fits;breaks} -> Format.pp_print_custom_break ppf ~fits ~breaks + | Flush {newline=true} -> Format.pp_print_newline ppf () + | Flush {newline=false} -> Format.pp_print_flush ppf () + | Newline -> Format.pp_force_newline ppf () + | If_newline -> Format.pp_print_if_newline ppf () + | With_size _ -> () + | Deprecated pr -> pr ppf + + let rec interpret ppf = function + | [] -> () + | With_size size :: Text text :: l -> + Format.pp_print_as ppf size text; + interpret ppf l + | x :: l -> + interpret_elt ppf x; + interpret ppf l + + let format ppf doc = interpret ppf (to_list doc) + + + + let open_box kind indent doc = add doc (Open_box {kind;indent}) + let close_box doc = add doc Close_box + + let string s doc = add doc (Text s) + let bytes b doc = add doc (Text (Bytes.to_string b)) + let with_size size doc = add doc (With_size size) + + let int n doc = add doc (Text (string_of_int n)) + let float f doc = add doc (Text (string_of_float f)) + let char c doc = add doc (Text (String.make 1 c)) + let bool c doc = add doc (Text (Bool.to_string c)) + + let break ~spaces ~indent doc = add doc (Simple_break {spaces; indent}) + let space doc = break ~spaces:1 ~indent:0 doc + let cut = break ~spaces:0 ~indent:0 + + let custom_break ~fits ~breaks doc = add doc (Break {fits;breaks}) + + let force_newline doc = add doc Newline + let if_newline doc = add doc If_newline + + let flush doc = add doc (Flush {newline=false}) + let force_stop doc = add doc (Flush {newline=true}) + + let open_tbox doc = add doc Open_tbox + let set_tab doc = add doc Set_tab + let tab_break ~width ~offset doc = add doc (Tab_break {width;offset}) + let tab doc = tab_break ~width:0 ~offset:0 doc + let close_tbox doc = add doc Close_tbox + + let open_tag stag doc = add doc (Open_tag stag) + let close_tag doc = add doc Close_tag + + let iter ?(sep=Fun.id) ~iter:iterator elt l doc = + let first = ref true in + let rdoc = ref doc in + let print x = + if !first then (first := false; rdoc := elt x !rdoc) + else rdoc := !rdoc |> sep |> elt x + in + iterator print l; + !rdoc + + let rec list ?(sep=Fun.id) elt l doc = match l with + | [] -> doc + | [a] -> elt a doc + | a :: ((_ :: _) as q) -> + doc |> elt a |> sep |> list ~sep elt q + + let array ?sep elt a doc = iter ?sep ~iter:Array.iter elt a doc + let seq ?sep elt s doc = iter ?sep ~iter:Seq.iter elt s doc + + let option ?(none=Fun.id) elt o doc = match o with + | None -> none doc + | Some x -> elt x doc + + let either ~left ~right x doc = match x with + | Either.Left x -> left x doc + | Either.Right x -> right x doc + + let result ~ok ~error x doc = match x with + | Ok x -> ok x doc + | Error x -> error x doc + + (* To format free-flowing text *) + let rec subtext len left right s doc = + let flush doc = + doc |> string (String.sub s left (right - left)) + in + let after_flush doc = subtext len (right+1) (right+1) s doc in + if right = len then + if left <> len then flush doc else doc + else + match s.[right] with + | '\n' -> + doc |> flush |> force_newline |> after_flush + | ' ' -> + doc |> flush |> space |> after_flush + (* there is no specific support for '\t' + as it is unclear what a right semantics would be *) + | _ -> subtext len left (right + 1) s doc + + let text s doc = + subtext (String.length s) 0 0 s doc + + type ('a,'b) fmt = ('a, t, t, 'b) format4 + type printer0 = t -> t + type 'a printer = 'a -> printer0 + + let output_formatting_lit fmting_lit doc = + let open CamlinternalFormatBasics in + match fmting_lit with + | Close_box -> close_box doc + | Close_tag -> close_tag doc + | Break (_, width, offset) -> break ~spaces:width ~indent:offset doc + | FFlush -> flush doc + | Force_newline -> force_newline doc + | Flush_newline -> force_stop doc + | Magic_size (_, n) -> with_size n doc + | Escaped_at -> char '@' doc + | Escaped_percent -> char '%' doc + | Scan_indic c -> doc |> char '@' |> char c + + let to_string doc = + let b = Buffer.create 20 in + let convert = function + | Text s -> Buffer.add_string b s + | _ -> () + in + fold (fun () x -> convert x) () doc; + Buffer.contents b + + let box_type = + let open CamlinternalFormatBasics in + function + | Pp_fits -> H + | Pp_hbox -> H + | Pp_vbox -> V + | Pp_hovbox -> HoV + | Pp_hvbox -> HV + | Pp_box -> B + + let rec compose_acc acc doc = + let open CamlinternalFormat in + match acc with + | CamlinternalFormat.Acc_formatting_lit (p, f) -> + doc |> compose_acc p |> output_formatting_lit f + | Acc_formatting_gen (p, Acc_open_tag acc') -> + let tag = to_string (compose_acc acc' empty) in + let doc = compose_acc p doc in + doc |> open_tag (Format.String_tag tag) + | Acc_formatting_gen (p, Acc_open_box acc') -> + let doc = compose_acc p doc in + let box = to_string (compose_acc acc' empty) in + let (indent, bty) = CamlinternalFormat.open_box_of_string box in + doc |> open_box (box_type bty) indent + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> + doc |> compose_acc p |> string s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> doc |> compose_acc p |> char c + | Acc_delay (p, f) -> doc |> compose_acc p |> f + | Acc_flush p -> doc |> compose_acc p |> flush + | Acc_invalid_arg (_p, msg) -> invalid_arg msg; + | End_of_acc -> doc + + let kprintf k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc doc -> doc |> compose_acc acc |> k ) + End_of_acc fmt + + let printf doc = kprintf Fun.id doc + let kmsg k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> k (compose_acc acc empty)) + End_of_acc fmt + + let msg fmt = kmsg Fun.id fmt + +end + +(** Compatibility interface *) + +type doc = Doc.t +type t = doc +type formatter = doc ref +type 'a printer = formatter -> 'a -> unit + +let formatter d = d + +(** {1 Primitive functions }*) + +let pp_print_string ppf s = ppf := Doc.string s !ppf + +let pp_print_as ppf size s = + ppf := !ppf |> Doc.with_size size |> Doc.string s + +let pp_print_substring ~pos ~len ppf s = + ppf := Doc.string (String.sub s pos len) !ppf + +let pp_print_substring_as ~pos ~len ppf size s = + ppf := + !ppf + |> Doc.with_size size + |> Doc.string (String.sub s pos len) + +let pp_print_bytes ppf s = ppf := Doc.string (Bytes.to_string s) !ppf +let pp_print_text ppf s = ppf := Doc.text s !ppf +let pp_print_char ppf c = ppf := Doc.char c !ppf +let pp_print_int ppf c = ppf := Doc.int c !ppf +let pp_print_float ppf f = ppf := Doc.float f !ppf +let pp_print_bool ppf b = ppf := Doc.bool b !ppf +let pp_print_nothing _ _ = () + +let pp_close_box ppf () = ppf := Doc.close_box !ppf +let pp_close_stag ppf () = ppf := Doc.close_tag !ppf + +let pp_print_break ppf spaces indent = ppf := Doc.break ~spaces ~indent !ppf + +let pp_print_custom_break ppf ~fits ~breaks = + ppf := Doc.custom_break ~fits ~breaks !ppf + +let pp_print_space ppf () = pp_print_break ppf 1 0 +let pp_print_cut ppf () = pp_print_break ppf 0 0 + +let pp_print_flush ppf () = ppf := Doc.flush !ppf +let pp_force_newline ppf () = ppf := Doc.force_newline !ppf +let pp_print_newline ppf () = ppf := Doc.force_stop !ppf +let pp_print_if_newline ppf () =ppf := Doc.if_newline !ppf + +let pp_open_stag ppf stag = ppf := !ppf |> Doc.open_tag stag + +let pp_open_box_gen ppf indent bxty = + let box_type = Doc.box_type bxty in + ppf := !ppf |> Doc.open_box box_type indent + +let pp_open_box ppf indent = pp_open_box_gen ppf indent Pp_box + + +let pp_open_tbox ppf () = ppf := !ppf |> Doc.open_tbox + +let pp_close_tbox ppf () = ppf := !ppf |> Doc.close_tbox + +let pp_set_tab ppf () = ppf := !ppf |> Doc.set_tab + +let pp_print_tab ppf () = ppf := !ppf |> Doc.tab + +let pp_print_tbreak ppf width offset = + ppf := !ppf |> Doc.tab_break ~width ~offset + +let pp_doc ppf doc = ppf := Doc.append !ppf doc + +module Driver = struct + (* Interpret a formatting entity on a formatter. *) + let output_formatting_lit ppf + (fmting_lit:CamlinternalFormatBasics.formatting_lit) + = match fmting_lit with + | Close_box -> pp_close_box ppf () + | Close_tag -> pp_close_stag ppf () + | Break (_, width, offset) -> pp_print_break ppf width offset + | FFlush -> pp_print_flush ppf () + | Force_newline -> pp_force_newline ppf () + | Flush_newline -> pp_print_newline ppf () + | Magic_size (_, _) -> () + | Escaped_at -> pp_print_char ppf '@' + | Escaped_percent -> pp_print_char ppf '%' + | Scan_indic c -> pp_print_char ppf '@'; pp_print_char ppf c + + + + let compute_tag output tag_acc = + let buf = Buffer.create 16 in + let buf_fmt = Format.formatter_of_buffer buf in + let ppf = ref Doc.empty in + output ppf tag_acc; + pp_print_flush ppf (); + Doc.format buf_fmt !ppf; + let len = Buffer.length buf in + if len < 2 then Buffer.contents buf + else Buffer.sub buf 1 (len - 2) + + (* Recursively output an "accumulator" containing a reversed list of + printing entities (string, char, flus, ...) in an output_stream. *) + (* Differ from Printf.output_acc by the interpretation of formatting. *) + (* Used as a continuation of CamlinternalFormat.make_printf. *) + let rec output_acc ppf (acc: _ CamlinternalFormat.acc) = + match acc with + | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s) + | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> + output_acc ppf p; + pp_print_as ppf size s; + | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c) + | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> + output_acc ppf p; + pp_print_as ppf size (String.make 1 c); + | Acc_formatting_lit (p, f) -> + output_acc ppf p; + output_formatting_lit ppf f; + | Acc_formatting_gen (p, Acc_open_tag acc') -> + output_acc ppf p; + pp_open_stag ppf (Format.String_tag (compute_tag output_acc acc')) + | Acc_formatting_gen (p, Acc_open_box acc') -> + output_acc ppf p; + let (indent, bty) = + let box_info = compute_tag output_acc acc' in + CamlinternalFormat.open_box_of_string box_info + in + pp_open_box_gen ppf indent bty + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> output_acc ppf p; pp_print_string ppf s; + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> output_acc ppf p; pp_print_char ppf c; + | Acc_delay (p, f) -> output_acc ppf p; f ppf; + | Acc_flush p -> output_acc ppf p; pp_print_flush ppf (); + | Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg; + | End_of_acc -> () +end + +let kfprintf k ppf (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> Driver.output_acc ppf acc; k ppf) + End_of_acc fmt +let fprintf doc fmt = kfprintf ignore doc fmt + + +let kdprintf k (CamlinternalFormatBasics.Format (fmt, _)) = + CamlinternalFormat.make_printf + (fun acc -> k (fun ppf -> Driver.output_acc ppf acc)) + End_of_acc fmt + +let dprintf fmt = kdprintf (fun i -> i) fmt + +let doc_printf fmt = + let ppf = ref Doc.empty in + kfprintf (fun _ -> let doc = !ppf in ppf := Doc.empty; doc) ppf fmt + +let kdoc_printf k fmt = + let ppf = ref Doc.empty in + kfprintf (fun ppf -> + let doc = !ppf in + ppf := Doc.empty; + k doc + ) + ppf fmt + +let doc_printer f x doc = + let r = ref doc in + f r x; + !r + +type 'a format_printer = Format.formatter -> 'a -> unit + +let format_printer f ppf x = + let doc = doc_printer f x Doc.empty in + Doc.format ppf doc +let compat = format_printer +let compat1 f p1 = compat (f p1) +let compat2 f p1 p2 = compat (f p1 p2) + +let kasprintf k fmt = + kdoc_printf (fun doc -> k (Format.asprintf "%a" Doc.format doc)) fmt +let asprintf fmt = kasprintf Fun.id fmt + +let pp_print_iter ?(pp_sep=pp_print_cut) iter elt ppf c = + let sep = doc_printer pp_sep () in + ppf:= Doc.iter ~sep ~iter (doc_printer elt) c !ppf + +let pp_print_list ?(pp_sep=pp_print_cut) elt ppf l = + ppf := Doc.list ~sep:(doc_printer pp_sep ()) (doc_printer elt) l !ppf + +let pp_print_array ?pp_sep elt ppf a = + pp_print_iter ?pp_sep Array.iter elt ppf a +let pp_print_seq ?pp_sep elt ppf s = pp_print_iter ?pp_sep Seq.iter elt ppf s + +let pp_print_option ?(none=fun _ () -> ()) elt ppf o = + ppf := Doc.option ~none:(doc_printer none ()) (doc_printer elt) o !ppf + +let pp_print_result ~ok ~error ppf r = + ppf := Doc.result ~ok:(doc_printer ok) ~error:(doc_printer error) r !ppf + +let pp_print_either ~left ~right ppf e = + ppf := Doc.either ~left:(doc_printer left) ~right:(doc_printer right) e !ppf + +let comma ppf () = fprintf ppf ",@ " + +let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) = + let left_column_size = + List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines in + let lines_nb = List.length lines in + let ellipsed_first, ellipsed_last = + match max_lines with + | Some max_lines when lines_nb > max_lines -> + let printed_lines = max_lines - 1 in (* the ellipsis uses one line *) + let lines_before = printed_lines / 2 + printed_lines mod 2 in + let lines_after = printed_lines / 2 in + (lines_before, lines_nb - lines_after - 1) + | _ -> (-1, -1) + in + fprintf ppf "@["; + List.iteri (fun k (line_l, line_r) -> + if k = ellipsed_first then fprintf ppf "...@,"; + if ellipsed_first <= k && k <= ellipsed_last then () + else fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r + ) lines; + fprintf ppf "@]" + +let deprecated_printer pr ppf = ppf := Doc.add !ppf (Doc.Deprecated pr) diff --git a/src/utils/format_doc.mli b/src/utils/format_doc.mli new file mode 100644 index 000000000..77d9d11cc --- /dev/null +++ b/src/utils/format_doc.mli @@ -0,0 +1,297 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2024 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Composable document for the {!Format} formatting engine. *) + +(** This module introduces a pure and immutable document type which represents a + sequence of formatting instructions to be printed by a formatting engine at + later point. At the same time, it also provides format string interpreter + which produces this document type from format string and their associated + printers. + + The module is designed to be source compatible with code defining format + printers: replacing `Format` by `Format_doc` in your code will convert + `Format` printers to `Format_doc` printers. +*) + +(** Definitions and immutable API for composing documents *) +module Doc: sig + + (** {2 Type definitions and core functions }*) + + (** Format box types *) + type box_type = + | H + | V + | HV + | HoV + | B + + type stag = Format.stag + + (** Base formatting instruction recognized by {!Format} *) + type element = + | Text of string + | With_size of int + | Open_box of { kind: box_type ; indent:int } + | Close_box + | Open_tag of Format.stag + | Close_tag + | Open_tbox + | Tab_break of { width : int; offset : int } + | Set_tab + | Close_tbox + | Simple_break of { spaces : int; indent : int } + | Break of { fits : string * int * string as 'a; breaks : 'a } + | Flush of { newline:bool } + | Newline + | If_newline + + | Deprecated of (Format.formatter -> unit) + (** Escape hatch: a {!Format} printer used to provide backward-compatibility + for user-defined printer (from the [#install_printer] toplevel directive + for instance). *) + + (** Immutable document type*) + type t + + type ('a,'b) fmt = ('a, t, t,'b) format4 + + type printer0 = t -> t + type 'a printer = 'a -> printer0 + + + (** Empty document *) + val empty: t + + (** [format ppf doc] sends the format instruction of [doc] to the Format's + formatter [doc]. *) + val format: Format.formatter -> t -> unit + + (** Fold over a document as a sequence of instructions *) + val fold: ('acc -> element -> 'acc) -> 'acc -> t -> 'acc + + (** {!msg} and {!kmsg} produce a document from a format string and its + argument *) + val msg: ('a,t) fmt -> 'a + val kmsg: (t -> 'b) -> ('a,'b) fmt -> 'a + + (** {!printf} and {!kprintf} produce a printer from a format string and its + argument*) + val printf: ('a, printer0) fmt -> 'a + val kprintf: (t -> 'b) -> ('a, t -> 'b) fmt -> 'a + + (** The functions below mirror {!Format} printers, without the [pp_print_] + prefix naming convention *) + val open_box: box_type -> int -> printer0 + val close_box: printer0 + + val text: string printer + val string: string printer + val bytes: bytes printer + val with_size: int printer + + val int: int printer + val float: float printer + val char: char printer + val bool: bool printer + + val space: printer0 + val cut: printer0 + val break: spaces:int -> indent:int -> printer0 + + val custom_break: + fits:(string * int * string as 'a) -> breaks:'a -> printer0 + val force_newline: printer0 + val if_newline: printer0 + + val flush: printer0 + val force_stop: printer0 + + val open_tbox: printer0 + val set_tab: printer0 + val tab: printer0 + val tab_break: width:int -> offset:int -> printer0 + val close_tbox: printer0 + + val open_tag: stag printer + val close_tag: printer0 + + val list: ?sep:printer0 -> 'a printer -> 'a list printer + val iter: + ?sep:printer0 -> iter:(('a -> unit) -> 'b -> unit) -> 'a printer + ->'b printer + val array: ?sep:printer0 -> 'a printer -> 'a array printer + val seq: ?sep:printer0 -> 'a printer -> 'a Seq.t printer + + val option: ?none:printer0 -> 'a printer -> 'a option printer + val result: ok:'a printer -> error:'e printer -> ('a,'e) result printer + val either: left:'a printer -> right:'b printer -> ('a,'b) Either.t printer + +end + +(** {1 Compatibility API} *) + +(** The functions and types below provides source compatibility with format +printers and conversion function from {!Format_doc} printers to {!Format} +printers. The reverse direction is implemented using an escape hatch in the +formatting instruction and should only be used to preserve backward +compatibility. *) + +type doc = Doc.t +type t = doc +type formatter +type 'a printer = formatter -> 'a -> unit + +val formatter: doc ref -> formatter +(** [formatter rdoc] creates a {!formatter} that updates the [rdoc] reference *) + +(** Translate a {!Format_doc} printer to a {!Format} one. *) +type 'a format_printer = Format.formatter -> 'a -> unit +val compat: 'a printer -> 'a format_printer +val compat1: ('p1 -> 'a printer) -> ('p1 -> 'a format_printer) +val compat2: ('p1 -> 'p2 -> 'a printer) -> ('p1 -> 'p2 -> 'a format_printer) + +(** If necessary, embbed a {!Format} printer inside a formatting instruction + stream. This breaks every guarantees provided by {!Format_doc}. *) +val deprecated_printer: (Format.formatter -> unit) -> formatter -> unit + + +(** {2 Format string interpreters }*) + +val fprintf : formatter -> ('a, formatter,unit) format -> 'a +val kfprintf: + (formatter -> 'a) -> formatter -> + ('b, formatter, unit, 'a) format4 -> 'b + +val asprintf : ('a, formatter, unit, string) format4 -> 'a +val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b + + +val dprintf : ('a, formatter, unit, formatter -> unit) format4 -> 'a +val kdprintf: + ((formatter -> unit) -> 'a) -> + ('b, formatter, unit, 'a) format4 -> 'b + +(** {!doc_printf} and {!kdoc_printf} creates a document directly *) +val doc_printf: ('a, formatter, unit, doc) format4 -> 'a +val kdoc_printf: (doc -> 'r) -> ('a, formatter, unit, 'r) format4 -> 'a + +(** {2 Compatibility with {!Doc} }*) + +val doc_printer: 'a printer -> 'a Doc.printer +val pp_doc: doc printer + +(** {2 Source compatibility with Format}*) + +(** {3 String printers } *) + +val pp_print_string: string printer +val pp_print_substring: pos:int -> len:int -> string printer +val pp_print_text: string printer +val pp_print_bytes: bytes printer + +val pp_print_as: formatter -> int -> string -> unit +val pp_print_substring_as: + pos:int -> len:int -> formatter -> int -> string -> unit + +(** {3 Primitive type printers }*) + +val pp_print_char: char printer +val pp_print_int: int printer +val pp_print_float: float printer +val pp_print_bool: bool printer +val pp_print_nothing: unit printer + +(** {3 Printer combinators }*) + +val pp_print_iter: + ?pp_sep:unit printer -> (('a -> unit) -> 'b -> unit) -> + 'a printer -> 'b printer + +val pp_print_list: ?pp_sep:unit printer -> 'a printer -> 'a list printer +val pp_print_array: ?pp_sep:unit printer -> 'a printer -> 'a array printer +val pp_print_seq: ?pp_sep:unit printer -> 'a printer -> 'a Seq.t printer + +val pp_print_option: ?none:unit printer -> 'a printer -> 'a option printer +val pp_print_result: ok:'a printer -> error:'e printer -> ('a,'e) result printer +val pp_print_either: + left:'a printer -> right:'b printer -> ('a,'b) Either.t printer + + +(** {3 Boxes and tags }*) + +val pp_open_stag: Format.stag printer +val pp_close_stag: unit printer + +val pp_open_box: int printer +val pp_close_box: unit printer + +(** {3 Break hints} *) + +val pp_print_space: unit printer +val pp_print_cut: unit printer +val pp_print_break: formatter -> int -> int -> unit +val pp_print_custom_break: + formatter -> fits:(string * int * string as 'c) -> breaks:'c -> unit + +(** {3 Tabulations }*) + +val pp_open_tbox: unit printer +val pp_close_tbox: unit printer +val pp_set_tab: unit printer +val pp_print_tab: unit printer +val pp_print_tbreak: formatter -> int -> int -> unit + +(** {3 Newlines and flushing }*) + +val pp_print_if_newline: unit printer +val pp_force_newline: unit printer +val pp_print_flush: unit printer +val pp_print_newline: unit printer + +(** {1 Compiler specific functions }*) + +(** {2 Separators }*) + +val comma: unit printer + +(** {2 Compiler output} *) + +val pp_two_columns : + ?sep:string -> ?max_lines:int -> + formatter -> (string * string) list -> unit +(** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two + columns separated by [sep] ("|" by default). [max_lines] can be used to + indicate a maximum number of lines to print -- an ellipsis gets inserted at + the middle if the input has too many lines. + + Example: + + {v pp_two_columns ~max_lines:3 Format.std_formatter [ + "abc", "hello"; + "def", "zzz"; + "a" , "bllbl"; + "bb" , "dddddd"; + ] v} + + prints + + {v + abc | hello + ... + bb | dddddd + v} +*) diff --git a/src/utils/misc.ml b/src/utils/misc.ml index 063539e2b..665cd8642 100644 --- a/src/utils/misc.ml +++ b/src/utils/misc.ml @@ -83,6 +83,238 @@ let protect_refs = | x -> set_refs backup; x | exception e -> set_refs backup; raise e + +(** {1 Minimal support for Unicode characters in identifiers} *) + +module Utf8_lexeme = struct + + type t = string + + (* Non-ASCII letters that are allowed in identifiers (currently: Latin-9) *) + + type case = Upper of Uchar.t | Lower of Uchar.t + let known_chars : (Uchar.t, case) Hashtbl.t = Hashtbl.create 32 + + let _ = + List.iter + ~f:(fun (upper, lower) -> + let upper = Uchar.of_int upper and lower = Uchar.of_int lower in + Hashtbl.add known_chars upper (Upper lower); + Hashtbl.add known_chars lower (Lower upper)) + [ + (0xc0, 0xe0); (* À, à *) (0xc1, 0xe1); (* Á, á *) + (0xc2, 0xe2); (* Â, â *) (0xc3, 0xe3); (* Ã, ã *) + (0xc4, 0xe4); (* Ä, ä *) (0xc5, 0xe5); (* Å, å *) + (0xc6, 0xe6); (* Æ, æ *) (0xc7, 0xe7); (* Ç, ç *) + (0xc8, 0xe8); (* È, è *) (0xc9, 0xe9); (* É, é *) + (0xca, 0xea); (* Ê, ê *) (0xcb, 0xeb); (* Ë, ë *) + (0xcc, 0xec); (* Ì, ì *) (0xcd, 0xed); (* Í, í *) + (0xce, 0xee); (* Î, î *) (0xcf, 0xef); (* Ï, ï *) + (0xd0, 0xf0); (* Ð, ð *) (0xd1, 0xf1); (* Ñ, ñ *) + (0xd2, 0xf2); (* Ò, ò *) (0xd3, 0xf3); (* Ó, ó *) + (0xd4, 0xf4); (* Ô, ô *) (0xd5, 0xf5); (* Õ, õ *) + (0xd6, 0xf6); (* Ö, ö *) (0xd8, 0xf8); (* Ø, ø *) + (0xd9, 0xf9); (* Ù, ù *) (0xda, 0xfa); (* Ú, ú *) + (0xdb, 0xfb); (* Û, û *) (0xdc, 0xfc); (* Ü, ü *) + (0xdd, 0xfd); (* Ý, ý *) (0xde, 0xfe); (* Þ, þ *) + (0x160, 0x161); (* Š, š *) (0x17d, 0x17e); (* Ž, ž *) + (0x152, 0x153); (* Œ, œ *) (0x178, 0xff); (* Ÿ, ÿ *) + (0x1e9e, 0xdf); (* ẞ, ß *) + ] + + (* NFD to NFC conversion table for the letters above *) + + let known_pairs : (Uchar.t * Uchar.t, Uchar.t) Hashtbl.t = Hashtbl.create 32 + + let _ = + List.iter + ~f:(fun (c1, n2, n) -> + Hashtbl.add known_pairs + (Uchar.of_char c1, Uchar.of_int n2) (Uchar.of_int n)) + [ + ('A', 0x300, 0xc0); (* À *) ('A', 0x301, 0xc1); (* Á *) + ('A', 0x302, 0xc2); (*  *) ('A', 0x303, 0xc3); (* à *) + ('A', 0x308, 0xc4); (* Ä *) ('A', 0x30a, 0xc5); (* Å *) + ('C', 0x327, 0xc7); (* Ç *) ('E', 0x300, 0xc8); (* È *) + ('E', 0x301, 0xc9); (* É *) ('E', 0x302, 0xca); (* Ê *) + ('E', 0x308, 0xcb); (* Ë *) ('I', 0x300, 0xcc); (* Ì *) + ('I', 0x301, 0xcd); (* Í *) ('I', 0x302, 0xce); (* Î *) + ('I', 0x308, 0xcf); (* Ï *) ('N', 0x303, 0xd1); (* Ñ *) + ('O', 0x300, 0xd2); (* Ò *) ('O', 0x301, 0xd3); (* Ó *) + ('O', 0x302, 0xd4); (* Ô *) ('O', 0x303, 0xd5); (* Õ *) + ('O', 0x308, 0xd6); (* Ö *) + ('U', 0x300, 0xd9); (* Ù *) ('U', 0x301, 0xda); (* Ú *) + ('U', 0x302, 0xdb); (* Û *) ('U', 0x308, 0xdc); (* Ü *) + ('Y', 0x301, 0xdd); (* Ý *) ('Y', 0x308, 0x178); (* Ÿ *) + ('S', 0x30c, 0x160); (* Š *) ('Z', 0x30c, 0x17d); (* Ž *) + ('a', 0x300, 0xe0); (* à *) ('a', 0x301, 0xe1); (* á *) + ('a', 0x302, 0xe2); (* â *) ('a', 0x303, 0xe3); (* ã *) + ('a', 0x308, 0xe4); (* ä *) ('a', 0x30a, 0xe5); (* å *) + ('c', 0x327, 0xe7); (* ç *) ('e', 0x300, 0xe8); (* è *) + ('e', 0x301, 0xe9); (* é *) ('e', 0x302, 0xea); (* ê *) + ('e', 0x308, 0xeb); (* ë *) ('i', 0x300, 0xec); (* ì *) + ('i', 0x301, 0xed); (* í *) ('i', 0x302, 0xee); (* î *) + ('i', 0x308, 0xef); (* ï *) ('n', 0x303, 0xf1); (* ñ *) + ('o', 0x300, 0xf2); (* ò *) ('o', 0x301, 0xf3); (* ó *) + ('o', 0x302, 0xf4); (* ô *) ('o', 0x303, 0xf5); (* õ *) + ('o', 0x308, 0xf6); (* ö *) + ('u', 0x300, 0xf9); (* ù *) ('u', 0x301, 0xfa); (* ú *) + ('u', 0x302, 0xfb); (* û *) ('u', 0x308, 0xfc); (* ü *) + ('y', 0x301, 0xfd); (* ý *) ('y', 0x308, 0xff); (* ÿ *) + ('s', 0x30c, 0x161); (* š *) ('z', 0x30c, 0x17e); (* ž *) + ] + + let normalize_generic ~keep_ascii transform s = + let rec norm check buf prev i = + if i >= String.length s then begin + Buffer.add_utf_8_uchar buf (transform prev) + end else begin + let d = String.get_utf_8_uchar s i in + let u = Uchar.utf_decode_uchar d in + check d u; + let i' = i + Uchar.utf_decode_length d in + match Hashtbl.find_opt known_pairs (prev, u) with + | Some u' -> + norm check buf u' i' + | None -> + Buffer.add_utf_8_uchar buf (transform prev); + norm check buf u i' + end in + let ascii_limit = 128 in + if s = "" + || keep_ascii && String.for_all (fun x -> Char.code x < ascii_limit) s + then Ok s + else + let buf = Buffer.create (String.length s) in + let valid = ref true in + let check d u = + valid := !valid && Uchar.utf_decode_is_valid d && u <> Uchar.rep + in + let d = String.get_utf_8_uchar s 0 in + let u = Uchar.utf_decode_uchar d in + check d u; + norm check buf u (Uchar.utf_decode_length d); + let contents = Buffer.contents buf in + if !valid then + Ok contents + else + Error contents + + let normalize s = + normalize_generic ~keep_ascii:true (fun u -> u) s + + (* Capitalization *) + + let uchar_is_uppercase u = + let c = Uchar.to_int u in + if c < 0x80 then c >= 65 && c <= 90 else + match Hashtbl.find_opt known_chars u with + | Some(Upper _) -> true + | _ -> false + + let uchar_lowercase u = + let c = Uchar.to_int u in + if c < 0x80 then + if c >= 65 && c <= 90 then Uchar.of_int (c + 32) else u + else + match Hashtbl.find_opt known_chars u with + | Some(Upper u') -> u' + | _ -> u + + let uchar_uppercase u = + let c = Uchar.to_int u in + if c < 0x80 then + if c >= 97 && c <= 122 then Uchar.of_int (c - 32) else u + else + match Hashtbl.find_opt known_chars u with + | Some(Lower u') -> u' + | _ -> u + + let capitalize s = + let first = ref true in + normalize_generic ~keep_ascii:false + (fun u -> if !first then (first := false; uchar_uppercase u) else u) + s + + let uncapitalize s = + let first = ref true in + normalize_generic ~keep_ascii:false + (fun u -> if !first then (first := false; uchar_lowercase u) else u) + s + + let is_capitalized s = + s <> "" && + uchar_is_uppercase (Uchar.utf_decode_uchar (String.get_utf_8_uchar s 0)) + + (* Characters allowed in identifiers after normalization is applied. + Currently: + - ASCII letters, underscore + - Latin-9 letters, represented in NFC + - ASCII digits, single quote (but not as first character) + - dot if [with_dot] = true + *) + let uchar_valid_in_identifier ~with_dot u = + let c = Uchar.to_int u in + if c < 0x80 then + c >= 97 (* a *) && c <= 122 (* z *) + || c >= 65 (* A *) && c <= 90 (* Z *) + || c >= 48 (* 0 *) && c <= 57 (* 9 *) + || c = 95 (* underscore *) + || c = 39 (* single quote *) + || (with_dot && c = 46) (* dot *) + else + Hashtbl.mem known_chars u + + let uchar_not_identifier_start u = + let c = Uchar.to_int u in + c >= 48 (* 0 *) && c <= 57 (* 9 *) + || c = 39 (* single quote *) + + (* Check whether a normalized string is a valid OCaml identifier. *) + + type validation_result = + | Valid + | Invalid_character of Uchar.t (** Character not allowed *) + | Invalid_beginning of Uchar.t (** Character not allowed as first char *) + + let validate_identifier ?(with_dot=false) s = + let rec check i = + if i >= String.length s then Valid else begin + let d = String.get_utf_8_uchar s i in + let u = Uchar.utf_decode_uchar d in + let i' = i + Uchar.utf_decode_length d in + if not (uchar_valid_in_identifier ~with_dot u) then + Invalid_character u + else if i = 0 && uchar_not_identifier_start u then + Invalid_beginning u + else + check i' + end + in check 0 + + let is_valid_identifier s = + validate_identifier s = Valid + + let starts_like_a_valid_identifier s = + s <> "" && + (let u = Uchar.utf_decode_uchar (String.get_utf_8_uchar s 0) in + uchar_valid_in_identifier ~with_dot:false u + && not (uchar_not_identifier_start u)) + + let is_lowercase s = + let rec is_lowercase_at len s n = + if n >= len then true + else + let d = String.get_utf_8_uchar s n in + let u = Uchar.utf_decode_uchar d in + (uchar_valid_in_identifier ~with_dot:false u) + && not (uchar_is_uppercase u) + && is_lowercase_at len s (n+Uchar.utf_decode_length d) + in + is_lowercase_at (String.length s) s 0 +end + + (* List functions *) let map_end f l1 l2 = List.map_end ~f l1 l2 @@ -643,11 +875,12 @@ module Style = struct | _ -> raise Not_found let as_inline_code printer ppf x = + let open Format_doc in Format.pp_open_stag ppf (Format.String_tag "inline_code"); printer ppf x; Format.pp_close_stag ppf () - let inline_code ppf s = as_inline_code Format.pp_print_string ppf s + let inline_code ppf s = as_inline_code Format_doc.pp_print_string ppf s (* either prints the tag of [s] or delegates to [or_else] *) let mark_open_tag ~or_else s = diff --git a/src/utils/misc.mli b/src/utils/misc.mli index 249f8b668..86dab4236 100644 --- a/src/utils/misc.mli +++ b/src/utils/misc.mli @@ -400,8 +400,8 @@ module Style : sig inline_code: tag_style; } - val as_inline_code: (Format.formatter -> 'a -> unit as 'printer) -> 'printer - val inline_code: Format.formatter -> string -> unit + val as_inline_code: 'a Format_doc.printer -> 'a Format_doc.printer + val inline_code: string Format_doc.printer val default_styles: styles val get_styles: unit -> styles @@ -416,5 +416,58 @@ module Style : sig (* adds functions to support color tags to the given formatter. *) end -val print_see_manual : Format.formatter -> int list -> unit +val print_see_manual : int list Format_doc.printer (** See manual section *) + + +module Utf8_lexeme: sig + type t = string + + val normalize: string -> (t,t) Result.t + (** Normalize the given UTF-8 encoded string. + Invalid UTF-8 sequences results in a error and are replaced + by U+FFFD. + Identifier characters are put in NFC normalized form. + Other Unicode characters are left unchanged. *) + + val capitalize: string -> (t,t) Result.t + (** Like [normalize], but if the string starts with a lowercase identifier + character, it is replaced by the corresponding uppercase character. + Subsequent characters are not changed. *) + + val uncapitalize: string -> (t,t) Result.t + (** Like [normalize], but if the string starts with an uppercase identifier + character, it is replaced by the corresponding lowercase character. + Subsequent characters are not changed. *) + + val is_capitalized: t -> bool + (** Returns [true] if the given normalized string starts with an + uppercase identifier character, [false] otherwise. May return + wrong results if the string is not normalized. *) + + val is_valid_identifier: t -> bool + (** Check whether the given normalized string is a valid OCaml identifier: + - all characters are identifier characters + - it does not start with a digit or a single quote + *) + + val is_lowercase: t -> bool + (** Returns [true] if the given normalized string only contains lowercase + identifier character, [false] otherwise. May return wrong results if the + string is not normalized. *) + + type validation_result = + | Valid + | Invalid_character of Uchar.t (** Character not allowed *) + | Invalid_beginning of Uchar.t (** Character not allowed as first char *) + + val validate_identifier: ?with_dot:bool -> t -> validation_result + (** Like [is_valid_identifier], but returns a more detailed error code. Dots + can be allowed to extend support to path-like identifiers. *) + + val starts_like_a_valid_identifier: t -> bool + (** Checks whether the given normalized string starts with an identifier + character other than a digit or a single quote. Subsequent characters + are not checked. *) +end + diff --git a/upstream/patches_503/file_formats/cmi_format.ml.patch b/upstream/patches_503/file_formats/cmi_format.ml.patch new file mode 100644 index 000000000..d7d41d171 --- /dev/null +++ b/upstream/patches_503/file_formats/cmi_format.ml.patch @@ -0,0 +1,36 @@ +--- ocaml_502/file_formats/cmi_format.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/file_formats/cmi_format.ml 2024-09-17 00:43:06.487446485 +0200 +@@ -94,25 +94,26 @@ + + (* Error report *) + +-open Format +-module Style = Misc.Style ++open Format_doc + +-let report_error ppf = function ++let report_error_doc ppf = function + | Not_an_interface filename -> + fprintf ppf "%a@ is not a compiled interface" +- (Style.as_inline_code Location.print_filename) filename ++ Location.Doc.quoted_filename filename + | Wrong_version_interface (filename, older_newer) -> + fprintf ppf + "%a@ is not a compiled interface for this version of OCaml.@.\ + It seems to be for %s version of OCaml." +- (Style.as_inline_code Location.print_filename) filename older_newer ++ Location.Doc.quoted_filename filename older_newer + | Corrupted_interface filename -> + fprintf ppf "Corrupted compiled interface@ %a" +- (Style.as_inline_code Location.print_filename) filename ++ Location.Doc.quoted_filename filename + + let () = + Location.register_error_of_exn + (function +- | Error err -> Some (Location.error_of_printer_file report_error err) ++ | Error err -> Some (Location.error_of_printer_file report_error_doc err) + | _ -> None + ) ++ ++let report_error = Format_doc.compat report_error_doc diff --git a/upstream/patches_503/file_formats/cmi_format.mli.patch b/upstream/patches_503/file_formats/cmi_format.mli.patch new file mode 100644 index 000000000..f20a663b9 --- /dev/null +++ b/upstream/patches_503/file_formats/cmi_format.mli.patch @@ -0,0 +1,11 @@ +--- ocaml_502/file_formats/cmi_format.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/file_formats/cmi_format.mli 2024-09-17 00:43:20.804104437 +0200 +@@ -45,6 +45,5 @@ + + exception Error of error + +-open Format +- +-val report_error: formatter -> error -> unit ++val report_error: error Format_doc.format_printer ++val report_error_doc: error Format_doc.printer diff --git a/upstream/patches_503/parsing/ast_helper.ml.patch b/upstream/patches_503/parsing/ast_helper.ml.patch new file mode 100644 index 000000000..5836f02a5 --- /dev/null +++ b/upstream/patches_503/parsing/ast_helper.ml.patch @@ -0,0 +1,47 @@ +--- ocaml_502/parsing/ast_helper.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/ast_helper.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -33,15 +33,20 @@ + Misc.protect_refs [Misc.R (default_loc, l)] f + + module Const = struct +- let integer ?suffix i = Pconst_integer (i, suffix) +- let int ?suffix i = integer ?suffix (Int.to_string i) +- let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) +- let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) +- let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) +- let float ?suffix f = Pconst_float (f, suffix) +- let char c = Pconst_char c ++ let mk ?(loc = !default_loc) d = ++ {pconst_desc = d; ++ pconst_loc = loc} ++ ++ let integer ?loc ?suffix i = mk ?loc (Pconst_integer (i, suffix)) ++ let int ?loc ?suffix i = integer ?loc ?suffix (Int.to_string i) ++ let int32 ?loc ?(suffix='l') i = integer ?loc ~suffix (Int32.to_string i) ++ let int64 ?loc ?(suffix='L') i = integer ?loc ~suffix (Int64.to_string i) ++ let nativeint ?loc ?(suffix='n') i = ++ integer ?loc ~suffix (Nativeint.to_string i) ++ let float ?loc ?suffix f = mk ?loc (Pconst_float (f, suffix)) ++ let char ?loc c = mk ?loc (Pconst_char c) + let string ?quotation_delimiter ?(loc= !default_loc) s = +- Pconst_string (s, loc, quotation_delimiter) ++ mk ~loc (Pconst_string (s, loc, quotation_delimiter)) + end + + module Attr = struct +@@ -167,6 +172,7 @@ + let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) + let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) ++ let effect_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_effect(a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) + end + +@@ -602,7 +608,6 @@ + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + } +- + end + + module Csig = struct diff --git a/upstream/patches_503/parsing/ast_helper.mli.patch b/upstream/patches_503/parsing/ast_helper.mli.patch new file mode 100644 index 000000000..3a3af5cd6 --- /dev/null +++ b/upstream/patches_503/parsing/ast_helper.mli.patch @@ -0,0 +1,34 @@ +--- ocaml_502/parsing/ast_helper.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/ast_helper.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -44,15 +44,16 @@ + (** {1 Constants} *) + + module Const : sig +- val char : char -> constant ++ val mk : ?loc:loc -> constant_desc -> constant ++ val char : ?loc:loc -> char -> constant + val string : + ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant +- val integer : ?suffix:char -> string -> constant +- val int : ?suffix:char -> int -> constant +- val int32 : ?suffix:char -> int32 -> constant +- val int64 : ?suffix:char -> int64 -> constant +- val nativeint : ?suffix:char -> nativeint -> constant +- val float : ?suffix:char -> string -> constant ++ val integer : ?loc:loc -> ?suffix:char -> string -> constant ++ val int : ?loc:loc -> ?suffix:char -> int -> constant ++ val int32 : ?loc:loc -> ?suffix:char -> int32 -> constant ++ val int64 : ?loc:loc -> ?suffix:char -> int64 -> constant ++ val nativeint : ?loc:loc -> ?suffix:char -> nativeint -> constant ++ val float : ?loc:loc -> ?suffix:char -> string -> constant + end + + (** {1 Attributes} *) +@@ -124,6 +125,7 @@ + val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern + val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern + val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern ++ val effect_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern + val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern + end + diff --git a/upstream/patches_503/parsing/ast_invariants.ml.patch b/upstream/patches_503/parsing/ast_invariants.ml.patch new file mode 100644 index 000000000..c85b69b93 --- /dev/null +++ b/upstream/patches_503/parsing/ast_invariants.ml.patch @@ -0,0 +1,19 @@ +--- ocaml_502/parsing/ast_invariants.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/ast_invariants.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -23,6 +23,8 @@ + let no_args loc = err loc "Function application with no argument." + let empty_let loc = err loc "Let with no bindings." + let empty_type loc = err loc "Type declarations cannot be empty." ++let empty_poly_binder loc = ++ err loc "Explicit universal type quantification cannot be empty." + let complex_id loc = err loc "Functor application not allowed here." + let module_type_substitution_missing_rhs loc = + err loc "Module type substitution with no right hand side" +@@ -53,6 +55,7 @@ + | Ptyp_tuple ([] | [_]) -> invalid_tuple loc + | Ptyp_package (_, cstrs) -> + List.iter (fun (id, _) -> simple_longident id) cstrs ++ | Ptyp_poly([],_) -> empty_poly_binder loc + | _ -> () + in + let pat self pat = diff --git a/upstream/patches_503/parsing/ast_iterator.ml.patch b/upstream/patches_503/parsing/ast_iterator.ml.patch new file mode 100644 index 000000000..20aea8bc0 --- /dev/null +++ b/upstream/patches_503/parsing/ast_iterator.ml.patch @@ -0,0 +1,10 @@ +--- ocaml_502/parsing/ast_iterator.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/ast_iterator.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -493,6 +493,7 @@ + | Ppat_type s -> iter_loc sub s + | Ppat_lazy p -> sub.pat sub p + | Ppat_unpack s -> iter_loc sub s ++ | Ppat_effect (p1,p2) -> sub.pat sub p1; sub.pat sub p2 + | Ppat_exception p -> sub.pat sub p + | Ppat_extension x -> sub.extension sub x + | Ppat_open (lid, p) -> diff --git a/upstream/patches_503/parsing/ast_mapper.ml.patch b/upstream/patches_503/parsing/ast_mapper.ml.patch new file mode 100644 index 000000000..a1bfde842 --- /dev/null +++ b/upstream/patches_503/parsing/ast_mapper.ml.patch @@ -0,0 +1,74 @@ +--- ocaml_502/parsing/ast_mapper.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/ast_mapper.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -95,14 +95,18 @@ + module C = struct + (* Constants *) + +- let map sub c = match c with +- | Pconst_integer _ +- | Pconst_char _ +- | Pconst_float _ +- -> c +- | Pconst_string (s, loc, quotation_delimiter) -> +- let loc = sub.location sub loc in +- Const.string ~loc ?quotation_delimiter s ++ let map sub { pconst_desc; pconst_loc } = ++ let loc = sub.location sub pconst_loc in ++ let desc = ++ match pconst_desc with ++ | Pconst_integer _ ++ | Pconst_char _ ++ | Pconst_float _ -> ++ pconst_desc ++ | Pconst_string (s, loc, quotation_delimiter) -> ++ Pconst_string (s, sub.location sub loc, quotation_delimiter) ++ in ++ Const.mk ~loc desc + end + + module T = struct +@@ -549,6 +553,8 @@ + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) ++ | Ppat_effect(p1, p2) -> ++ effect_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) + end + +@@ -828,21 +834,21 @@ + let extension_of_error {kind; main; sub} = + if kind <> Location.Report_error then + raise (Invalid_argument "extension_of_error: expected kind Report_error"); +- let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in ++ let str_of_msg msg = Format.asprintf "%a" Format_doc.Doc.format msg in + let extension_of_sub sub = + { loc = sub.loc; txt = "ocaml.error" }, + PStr ([Str.eval (Exp.constant +- (Pconst_string (str_of_pp sub.txt, sub.loc, None)))]) ++ (Const.string ~loc:sub.loc (str_of_msg sub.txt)))]) + in + { loc = main.loc; txt = "ocaml.error" }, + PStr (Str.eval (Exp.constant +- (Pconst_string (str_of_pp main.txt, main.loc, None))) :: ++ (Const.string ~loc:main.loc (str_of_msg main.txt))) :: + List.map (fun msg -> Str.extension (extension_of_sub msg)) sub) + + let attribute_of_warning loc s = + Attr.mk + {loc; txt = "ocaml.ppwarning" } +- (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) ++ (PStr ([Str.eval ~loc (Exp.constant (Const.string ~loc s))])) + + let cookies = ref String.Map.empty + +@@ -935,7 +941,8 @@ + let restore fields = + let field name payload = + let rec get_string = function +- | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str ++ | {pexp_desc = Pexp_constant ++ {pconst_desc = Pconst_string (str, _, None); _}} -> str + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] string syntax" name + and get_bool pexp = diff --git a/upstream/patches_503/parsing/asttypes.ml.patch b/upstream/patches_503/parsing/asttypes.ml.patch new file mode 100644 index 000000000..c412e59a8 --- /dev/null +++ b/upstream/patches_503/parsing/asttypes.ml.patch @@ -0,0 +1,75 @@ +--- ocaml_502/parsing/asttypes.ml 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/parsing/asttypes.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -0,0 +1,72 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) ++(* *) ++(* Copyright 1996 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(** Auxiliary AST types used by parsetree and typedtree. ++ ++ {b Warning:} this module is unstable and part of ++ {{!Compiler_libs}compiler-libs}. ++ ++*) ++ ++type constant = ++ Const_int of int ++ | Const_char of char ++ | Const_string of string * Location.t * string option ++ | Const_float of string ++ | Const_int32 of int32 ++ | Const_int64 of int64 ++ | Const_nativeint of nativeint ++ ++type rec_flag = Nonrecursive | Recursive ++ ++type direction_flag = Upto | Downto ++ ++(* Order matters, used in polymorphic comparison *) ++type private_flag = Private | Public ++ ++type mutable_flag = Immutable | Mutable ++ ++type virtual_flag = Virtual | Concrete ++ ++type override_flag = Override | Fresh ++ ++type closed_flag = Closed | Open ++ ++type label = string ++ ++type arg_label = ++ Nolabel ++ | Labelled of string (** [label:T -> ...] *) ++ | Optional of string (** [?label:T -> ...] *) ++ ++type 'a loc = 'a Location.loc = { ++ txt : 'a; ++ loc : Location.t; ++} ++ ++ ++type variance = ++ | Covariant ++ | Contravariant ++ | NoVariance ++ ++type injectivity = ++ | Injective ++ | NoInjectivity ++ ++let string_of_label = function ++ Nolabel -> "" ++ | Labelled s -> s ++ | Optional s -> "?"^s diff --git a/upstream/patches_503/parsing/asttypes.mli.patch b/upstream/patches_503/parsing/asttypes.mli.patch new file mode 100644 index 000000000..ea359239c --- /dev/null +++ b/upstream/patches_503/parsing/asttypes.mli.patch @@ -0,0 +1,8 @@ +--- ocaml_502/parsing/asttypes.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/asttypes.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -65,3 +65,5 @@ + type injectivity = + | Injective + | NoInjectivity ++ ++val string_of_label: arg_label -> string diff --git a/upstream/patches_503/parsing/attr_helper.ml.patch b/upstream/patches_503/parsing/attr_helper.ml.patch new file mode 100644 index 000000000..439b66ccd --- /dev/null +++ b/upstream/patches_503/parsing/attr_helper.ml.patch @@ -0,0 +1,25 @@ +--- ocaml_502/parsing/attr_helper.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/attr_helper.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -39,9 +39,9 @@ + | None -> false + | Some _ -> true + +-open Format ++open Format_doc + +-let report_error ppf = function ++let report_error_doc ppf = function + | Multiple_attributes name -> + fprintf ppf "Too many %a attributes" Style.inline_code name + | No_payload_expected name -> +@@ -51,7 +51,9 @@ + Location.register_error_of_exn + (function + | Error (loc, err) -> +- Some (Location.error_of_printer ~loc report_error err) ++ Some (Location.error_of_printer ~loc report_error_doc err) + | _ -> + None + ) ++ ++let report_error = Format_doc.compat report_error_doc diff --git a/upstream/patches_503/parsing/attr_helper.mli.patch b/upstream/patches_503/parsing/attr_helper.mli.patch new file mode 100644 index 000000000..4adbc5237 --- /dev/null +++ b/upstream/patches_503/parsing/attr_helper.mli.patch @@ -0,0 +1,9 @@ +--- ocaml_502/parsing/attr_helper.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/attr_helper.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -35,4 +35,5 @@ + + exception Error of Location.t * error + +-val report_error: Format.formatter -> error -> unit ++val report_error: error Format_doc.format_printer ++val report_error_doc: error Format_doc.printer diff --git a/upstream/patches_503/parsing/builtin_attributes.ml.patch b/upstream/patches_503/parsing/builtin_attributes.ml.patch new file mode 100644 index 000000000..bf40f4d78 --- /dev/null +++ b/upstream/patches_503/parsing/builtin_attributes.ml.patch @@ -0,0 +1,168 @@ +--- ocaml_502/parsing/builtin_attributes.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/builtin_attributes.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -36,12 +36,22 @@ + | 0 -> Int.compare a1.loc.loc_start.pos_cnum a2.loc.loc_start.pos_cnum + | n -> n + ++let compiler_stops_before_attributes_consumed () = ++ let stops_before_lambda = ++ match !Clflags.stop_after with ++ | None -> false ++ | Some pass -> Clflags.Compiler_pass.(compare pass Lambda) < 0 ++ in ++ stops_before_lambda || !Clflags.print_types ++ + let warn_unused () = + let keys = List.of_seq (Attribute_table.to_seq_keys unused_attrs) in +- let keys = List.sort attr_order keys in +- List.iter (fun sloc -> +- Location.prerr_warning sloc.loc (Warnings.Misplaced_attribute sloc.txt)) +- keys ++ Attribute_table.clear unused_attrs; ++ if not (compiler_stops_before_attributes_consumed ()) then ++ let keys = List.sort attr_order keys in ++ List.iter (fun sloc -> ++ Location.prerr_warning sloc.loc (Warnings.Misplaced_attribute sloc.txt)) ++ keys + + (* These are the attributes that are tracked in the builtin_attrs table for + misplaced attribute warnings. *) +@@ -93,7 +103,8 @@ + if is_builtin_attr name.txt then + Attribute_table.replace unused_attrs name () + +-let string_of_cst = function ++let string_of_cst const = ++ match const.pconst_desc with + | Pconst_string(s, _, _) -> Some s + | _ -> None + +@@ -107,37 +118,39 @@ + | Some s -> s + | None -> "" + ++module Style = Misc.Style + let error_of_extension ext = + let submessage_from main_loc main_txt = function + | {pstr_desc=Pstr_extension + (({txt = ("ocaml.error"|"error"); loc}, p), _)} -> + begin match p with + | PStr([{pstr_desc=Pstr_eval +- ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)} ++ ({pexp_desc=Pexp_constant ++ {pconst_desc=Pconst_string(msg, _, _); _}}, _)} + ]) -> +- { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg } ++ Location.msg ~loc "%a" Format_doc.pp_print_text msg + | _ -> +- { Location.loc; txt = fun ppf -> +- Format.fprintf ppf +- "Invalid syntax for sub-message of extension '%s'." main_txt } ++ Location.msg ~loc "Invalid syntax for sub-message of extension %a." ++ Style.inline_code main_txt + end + | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} -> +- { Location.loc; txt = fun ppf -> +- Format.fprintf ppf "Uninterpreted extension '%s'." txt } ++ Location.msg ~loc "Uninterpreted extension '%a'." ++ Style.inline_code txt + | _ -> +- { Location.loc = main_loc; txt = fun ppf -> +- Format.fprintf ppf +- "Invalid syntax for sub-message of extension '%s'." main_txt } ++ Location.msg ~loc:main_loc ++ "Invalid syntax for sub-message of extension %a." ++ Style.inline_code main_txt + in + match ext with + | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> + begin match p with + | PStr [] -> raise Location.Already_displayed_error + | PStr({pstr_desc=Pstr_eval +- ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}:: ++ ({pexp_desc=Pexp_constant ++ {pconst_desc=Pconst_string(msg, _, _)}}, _)}:: + inner) -> + let sub = List.map (submessage_from loc txt) inner in +- Location.error_of_printer ~loc ~sub Format.pp_print_text msg ++ Location.error_of_printer ~loc ~sub Format_doc.pp_print_text msg + | _ -> + Location.errorf ~loc "Invalid syntax for extension '%s'." txt + end +@@ -185,7 +198,8 @@ + Pstr_eval + ({pexp_desc=Pexp_apply + ({pexp_desc=Pexp_ident{txt=Longident.Lident id}}, +- [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_,_))}]) ++ [Nolabel,{pexp_desc=Pexp_constant ++ {pconst_desc=Pconst_string(s,_,_); _}}]) + },_)}] -> + Some (id, s) + | PStr[ +@@ -264,7 +278,10 @@ + | _ -> + [] + +-let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg) ++let alerts_of_sig ~mark sg = ++ let a = attrs_of_sig sg in ++ if mark then mark_alerts_used a; ++ alerts_of_attrs a + + let rec attrs_of_str = function + | {pstr_desc = Pstr_attribute a} :: tl -> +@@ -272,7 +289,10 @@ + | _ -> + [] + +-let alerts_of_str str = alerts_of_attrs (attrs_of_str str) ++let alerts_of_str ~mark str = ++ let a = attrs_of_str str in ++ if mark then mark_alerts_used a; ++ alerts_of_attrs a + + let warn_payload loc txt msg = + Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)) +@@ -293,7 +313,7 @@ + let process_alert loc name = function + | PStr[{pstr_desc= + Pstr_eval( +- {pexp_desc=Pexp_constant(Pconst_string(s,_,_))}, ++ {pexp_desc=Pexp_constant {pconst_desc=Pconst_string(s,_,_); _}}, + _) + }] -> + begin +@@ -302,15 +322,19 @@ + with Arg.Bad msg -> warn_payload loc name.txt msg + end + | k -> +- (* Don't [mark_used] in the [Some] cases - that happens in [Env] or +- [type_mod] if they are in a valid place. Do [mark_used] in the +- [None] case, which is just malformed and covered by the "Invalid +- payload" warning. *) + match kind_and_message k with + | Some ("all", _) -> + warn_payload loc name.txt "The alert name 'all' is reserved" +- | Some _ -> () ++ | Some _ -> ++ (* Do [mark_used] in the [Some] case only if Warning 53 is ++ disabled. Later, they will be marked used (provided they are in a ++ valid place) in [compile_common], when they are extracted to be ++ persisted inside the [.cmi] file. *) ++ if not (Warnings.is_active (Misplaced_attribute "")) ++ then mark_used name + | None -> begin ++ (* Do [mark_used] in the [None] case, which is just malformed and ++ covered by the "Invalid payload" warning. *) + mark_used name; + warn_payload loc name.txt "Invalid payload" + end +@@ -326,7 +350,7 @@ + begin match attr_payload with + | PStr [{ pstr_desc= + Pstr_eval({pexp_desc=Pexp_constant +- (Pconst_string (s, _, _))},_); ++ {pconst_desc=Pconst_string (s, _, _); _}},_); + pstr_loc }] -> + (mark_used attr_name; + Location.prerr_warning pstr_loc (Warnings.Preprocessor s)) diff --git a/upstream/patches_503/parsing/builtin_attributes.mli.patch b/upstream/patches_503/parsing/builtin_attributes.mli.patch new file mode 100644 index 000000000..7a340dafe --- /dev/null +++ b/upstream/patches_503/parsing/builtin_attributes.mli.patch @@ -0,0 +1,32 @@ +--- ocaml_502/parsing/builtin_attributes.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/builtin_attributes.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -75,7 +75,8 @@ + val mark_payload_attrs_used : Parsetree.payload -> unit + + (** Issue misplaced attribute warnings for all attributes created with +- [mk_internal] but not yet marked used. *) ++ [mk_internal] but not yet marked used. Does nothing if compilation ++ is stopped before lambda due to command-line flags. *) + val warn_unused : unit -> unit + + (** {3 Warning 53 helpers for environment attributes} +@@ -115,8 +116,8 @@ + def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> + Parsetree.attributes -> string -> unit + val alerts_of_attrs: Parsetree.attributes -> Misc.alerts +-val alerts_of_sig: Parsetree.signature -> Misc.alerts +-val alerts_of_str: Parsetree.structure -> Misc.alerts ++val alerts_of_sig: mark:bool -> Parsetree.signature -> Misc.alerts ++val alerts_of_str: mark:bool -> Parsetree.structure -> Misc.alerts + + val check_deprecated_mutable: + Location.t -> Parsetree.attributes -> string -> unit +@@ -172,7 +173,7 @@ + (** [attr_equals_builtin attr s] is true if the name of the attribute is [s] or + ["ocaml." ^ s]. This is useful for manually inspecting attribute names, but + note that doing so will not result in marking the attribute used for the +- purpose of warning 53, so it is usually preferrable to use [has_attribute] ++ purpose of warning 53, so it is usually preferable to use [has_attribute] + or [select_attributes]. *) + val attr_equals_builtin : Parsetree.attribute -> string -> bool + diff --git a/upstream/patches_503/parsing/depend.ml.patch b/upstream/patches_503/parsing/depend.ml.patch new file mode 100644 index 000000000..08614541e --- /dev/null +++ b/upstream/patches_503/parsing/depend.ml.patch @@ -0,0 +1,10 @@ +--- ocaml_502/parsing/depend.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/depend.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -191,6 +191,7 @@ + Option.iter + (fun name -> pattern_bv := String.Map.add name bound !pattern_bv) id.txt + | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p ++ | Ppat_effect(p1, p2) -> add_pattern bv p1; add_pattern bv p2 + | Ppat_exception p -> add_pattern bv p + | Ppat_extension e -> handle_extension e + diff --git a/upstream/patches_503/parsing/docstrings.ml.patch b/upstream/patches_503/parsing/docstrings.ml.patch new file mode 100644 index 000000000..3fa1409a4 --- /dev/null +++ b/upstream/patches_503/parsing/docstrings.ml.patch @@ -0,0 +1,24 @@ +--- ocaml_502/parsing/docstrings.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/docstrings.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -91,8 +91,9 @@ + let open Parsetree in + let body = ds.ds_body in + let loc = ds.ds_loc in ++ let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in + let exp = +- { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); ++ { pexp_desc = Pexp_constant const; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; } +@@ -143,8 +144,9 @@ + let open Parsetree in + let body = ds.ds_body in + let loc = ds.ds_loc in ++ let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in + let exp = +- { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); ++ { pexp_desc = Pexp_constant const; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; } diff --git a/upstream/patches_503/parsing/lexer.mli.patch b/upstream/patches_503/parsing/lexer.mli.patch new file mode 100644 index 000000000..b540a60d7 --- /dev/null +++ b/upstream/patches_503/parsing/lexer.mli.patch @@ -0,0 +1,16 @@ +--- ocaml_502/parsing/lexer.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/lexer.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -33,8 +33,13 @@ + | Unterminated_string_in_comment of Location.t * Location.t + | Empty_character_literal + | Keyword_as_label of string ++ | Capitalized_label of string + | Invalid_literal of string + | Invalid_directive of string * string option ++ | Invalid_encoding of string ++ | Invalid_char_in_ident of Uchar.t ++ | Non_lowercase_delimiter of string ++ | Capitalized_raw_identifier of string + + exception Error of error * Location.t + diff --git a/upstream/patches_503/parsing/lexer.mll.patch b/upstream/patches_503/parsing/lexer.mll.patch new file mode 100644 index 000000000..4aebe5cfe --- /dev/null +++ b/upstream/patches_503/parsing/lexer.mll.patch @@ -0,0 +1,277 @@ +--- ocaml_502/parsing/lexer.mll 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/lexer.mll 2024-09-17 01:16:30.152541842 +0200 +@@ -29,8 +29,13 @@ + | Unterminated_string_in_comment of Location.t * Location.t + | Empty_character_literal + | Keyword_as_label of string ++ | Capitalized_label of string + | Invalid_literal of string + | Invalid_directive of string * string option ++ | Invalid_encoding of string ++ | Invalid_char_in_ident of Uchar.t ++ | Non_lowercase_delimiter of string ++ | Capitalized_raw_identifier of string + + exception Error of error * Location.t + +@@ -47,6 +52,7 @@ + "do", DO; + "done", DONE; + "downto", DOWNTO; ++ "effect", EFFECT; + "else", ELSE; + "end", END; + "exception", EXCEPTION; +@@ -255,10 +261,46 @@ + illegal_escape lexbuf + (Printf.sprintf "%X is not a Unicode scalar value" cp) + ++let validate_encoding lexbuf raw_name = ++ match Utf8_lexeme.normalize raw_name with ++ | Error _ -> error lexbuf (Invalid_encoding raw_name) ++ | Ok name -> name ++ ++let ident_for_extended lexbuf raw_name = ++ let name = validate_encoding lexbuf raw_name in ++ match Utf8_lexeme.validate_identifier name with ++ | Utf8_lexeme.Valid -> name ++ | Utf8_lexeme.Invalid_character u -> error lexbuf (Invalid_char_in_ident u) ++ | Utf8_lexeme.Invalid_beginning _ -> ++ assert false (* excluded by the regexps *) ++ ++let validate_delim lexbuf raw_name = ++ let name = validate_encoding lexbuf raw_name in ++ if Utf8_lexeme.is_lowercase name then name ++ else error lexbuf (Non_lowercase_delimiter name) ++ ++let validate_ext lexbuf name = ++ let name = validate_encoding lexbuf name in ++ match Utf8_lexeme.validate_identifier ~with_dot:true name with ++ | Utf8_lexeme.Valid -> name ++ | Utf8_lexeme.Invalid_character u -> error lexbuf (Invalid_char_in_ident u) ++ | Utf8_lexeme.Invalid_beginning _ -> ++ assert false (* excluded by the regexps *) ++ ++let lax_delim raw_name = ++ match Utf8_lexeme.normalize raw_name with ++ | Error _ -> None ++ | Ok name -> ++ if Utf8_lexeme.is_lowercase name then Some name ++ else None ++ + let is_keyword name = Hashtbl.mem keyword_table name + +-let check_label_name lexbuf name = +- if is_keyword name then error lexbuf (Keyword_as_label name) ++let check_label_name ?(raw_escape=false) lexbuf name = ++ if Utf8_lexeme.is_capitalized name then ++ error lexbuf (Capitalized_label name); ++ if not raw_escape && is_keyword name then ++ error lexbuf (Keyword_as_label name) + + (* Update the current location with file name and line number. *) + +@@ -278,13 +320,6 @@ + + let escaped_newlines = ref false + +-(* Warn about Latin-1 characters used in idents *) +- +-let warn_latin1 lexbuf = +- Location.deprecated +- (Location.curr lexbuf) +- "ISO-Latin1 characters in identifiers" +- + let handle_docstrings = ref true + let comment_list = ref [] + +@@ -301,7 +336,7 @@ + + (* Error report *) + +-open Format ++open Format_doc + + let prepare_error loc = function + | Illegal_character c -> +@@ -335,6 +370,10 @@ + | Keyword_as_label kwd -> + Location.errorf ~loc + "%a is a keyword, it cannot be used as label name" Style.inline_code kwd ++ | Capitalized_label lbl -> ++ Location.errorf ~loc ++ "%a cannot be used as label name, \ ++ it must start with a lowercase letter" Style.inline_code lbl + | Invalid_literal s -> + Location.errorf ~loc "Invalid literal %s" s + | Invalid_directive (dir, explanation) -> +@@ -342,6 +381,20 @@ + (fun ppf -> match explanation with + | None -> () + | Some expl -> fprintf ppf ": %s" expl) ++ | Invalid_encoding s -> ++ Location.errorf ~loc "Invalid encoding of identifier %s." s ++ | Invalid_char_in_ident u -> ++ Location.errorf ~loc "Invalid character U+%X in identifier" ++ (Uchar.to_int u) ++ | Capitalized_raw_identifier lbl -> ++ Location.errorf ~loc ++ "%a cannot be used as a raw identifier, \ ++ it must start with a lowercase letter" Style.inline_code lbl ++ | Non_lowercase_delimiter name -> ++ Location.errorf ~loc ++ "%a cannot be used as a quoted string delimiter,@ \ ++ it must contain only lowercase letters." ++ Style.inline_code name + + let () = + Location.register_error_of_exn +@@ -358,12 +411,11 @@ + let blank = [' ' '\009' '\012'] + let lowercase = ['a'-'z' '_'] + let uppercase = ['A'-'Z'] ++let identstart = lowercase | uppercase + let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] +-let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +-let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222'] +-let identchar_latin1 = +- ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +-(* This should be kept in sync with the [is_identchar] function in [env.ml] *) ++let utf8 = ['\192'-'\255'] ['\128'-'\191']* ++let identstart_ext = identstart | utf8 ++let identchar_ext = identchar | utf8 + + let symbolchar = + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] +@@ -375,7 +427,8 @@ + ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|'] + + let ident = (lowercase | uppercase) identchar* +-let extattrident = ident ('.' ident)* ++let ident_ext = identstart_ext identchar_ext* ++let extattrident = ident_ext ('.' ident_ext)* + + let decimal_literal = + ['0'-'9'] ['0'-'9' '_']* +@@ -418,35 +471,39 @@ + | ".~" + { error lexbuf + (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } +- | "~" raw_ident_escape (lowercase identchar * as name) ':' +- { LABEL name } +- | "~" (lowercase identchar * as name) ':' ++ | "~" (identstart identchar * as name) ':' + { check_label_name lexbuf name; + LABEL name } +- | "~" (lowercase_latin1 identchar_latin1 * as name) ':' +- { warn_latin1 lexbuf; ++ | "~" (raw_ident_escape? as escape) (ident_ext as raw_name) ':' ++ { let name = ident_for_extended lexbuf raw_name in ++ check_label_name ~raw_escape:(escape<>"") lexbuf name; + LABEL name } + | "?" + { QUESTION } +- | "?" raw_ident_escape (lowercase identchar * as name) ':' +- { OPTLABEL name } + | "?" (lowercase identchar * as name) ':' + { check_label_name lexbuf name; + OPTLABEL name } +- | "?" (lowercase_latin1 identchar_latin1 * as name) ':' +- { warn_latin1 lexbuf; +- OPTLABEL name } +- | raw_ident_escape (lowercase identchar * as name) +- { LIDENT name } ++ | "?" (raw_ident_escape? as escape) (ident_ext as raw_name) ':' ++ { let name = ident_for_extended lexbuf raw_name in ++ check_label_name ~raw_escape:(escape<>"") lexbuf name; ++ OPTLABEL name ++ } + | lowercase identchar * as name + { try Hashtbl.find keyword_table name + with Not_found -> LIDENT name } +- | lowercase_latin1 identchar_latin1 * as name +- { warn_latin1 lexbuf; LIDENT name } + | uppercase identchar * as name + { UIDENT name } (* No capitalized keywords *) +- | uppercase_latin1 identchar_latin1 * as name +- { warn_latin1 lexbuf; UIDENT name } ++ | (raw_ident_escape? as escape) (ident_ext as raw_name) ++ { let name = ident_for_extended lexbuf raw_name in ++ if Utf8_lexeme.is_capitalized name then begin ++ if escape="" then UIDENT name ++ else ++ (* we don't have capitalized keywords, and thus no needs for ++ capitalized raw identifiers. *) ++ error lexbuf (Capitalized_raw_identifier name) ++ end else ++ LIDENT name ++ } (* No non-ascii keywords *) + | int_literal as lit { INT (lit, None) } + | (int_literal as lit) (literal_modifier as modif) + { INT (lit, Some modif) } +@@ -459,26 +516,34 @@ + | "\"" + { let s, loc = wrap_string_lexer string lexbuf in + STRING (s, loc, None) } +- | "{" (lowercase* as delim) "|" +- { let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in +- STRING (s, loc, Some delim) } +- | "{%" (extattrident as id) "|" ++ | "{" (ident_ext? as raw_name) '|' ++ { let delim = validate_delim lexbuf raw_name in ++ let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in ++ STRING (s, loc, Some delim) ++ } ++ | "{%" (extattrident as raw_id) "|" + { let orig_loc = Location.curr lexbuf in ++ let id = validate_ext lexbuf raw_id in + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in + let idloc = compute_quoted_string_idloc orig_loc 2 id in + QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") } +- | "{%" (extattrident as id) blank+ (lowercase* as delim) "|" ++ | "{%" (extattrident as raw_id) blank+ (ident_ext as raw_delim) "|" + { let orig_loc = Location.curr lexbuf in ++ let id = validate_ext lexbuf raw_id in ++ let delim = validate_delim lexbuf raw_delim in + let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in + let idloc = compute_quoted_string_idloc orig_loc 2 id in + QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) } +- | "{%%" (extattrident as id) "|" ++ | "{%%" (extattrident as raw_id) "|" + { let orig_loc = Location.curr lexbuf in ++ let id = validate_ext lexbuf raw_id in + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in + let idloc = compute_quoted_string_idloc orig_loc 3 id in + QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") } +- | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|" ++ | "{%%" (extattrident as raw_id) blank+ (ident_ext as raw_delim) "|" + { let orig_loc = Location.curr lexbuf in ++ let id = validate_ext lexbuf raw_id in ++ let delim = validate_delim lexbuf raw_delim in + let s, loc = wrap_string_lexer (quoted_string delim) lexbuf in + let idloc = compute_quoted_string_idloc orig_loc 3 id in + QUOTED_STRING_ITEM (id, idloc, s, loc, Some delim) } +@@ -665,8 +730,10 @@ + is_in_string := false; + store_string_char '\"'; + comment lexbuf } +- | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|" +- { ++ | "{" ('%' '%'? extattrident blank*)? (ident_ext? as raw_delim) "|" ++ { match lax_delim raw_delim with ++ | None -> store_lexeme lexbuf; comment lexbuf ++ | Some delim -> + string_start_loc := Location.curr lexbuf; + store_lexeme lexbuf; + is_in_string := true; +@@ -780,8 +847,9 @@ + | eof + { is_in_string := false; + error_loc !string_start_loc Unterminated_string } +- | "|" (lowercase* as edelim) "}" ++ | "|" (ident_ext? as raw_edelim) "}" + { ++ let edelim = validate_encoding lexbuf raw_edelim in + if delim = edelim then lexbuf.lex_start_p + else (store_lexeme lexbuf; quoted_string delim lexbuf) + } diff --git a/upstream/patches_503/parsing/location.ml.patch b/upstream/patches_503/parsing/location.ml.patch new file mode 100644 index 000000000..af86dd726 --- /dev/null +++ b/upstream/patches_503/parsing/location.ml.patch @@ -0,0 +1,374 @@ +--- ocaml_502/parsing/location.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/location.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -118,13 +118,6 @@ + print_newline (); + incr num_loc_lines + +-(* This is used by the toplevel and the report printers below. *) +-let separate_new_message ppf = +- if not (is_first_message ()) then begin +- Format.pp_print_newline ppf (); +- incr num_loc_lines +- end +- + (* Code printing errors and warnings must be wrapped using this function, in + order to update [num_loc_lines]. + +@@ -146,6 +139,8 @@ + pp_print_flush ppf (); + pp_set_formatter_out_functions ppf out_functions + ++(** {1 Printing setup }*) ++ + let setup_tags () = + Misc.Style.setup !Clflags.color + +@@ -204,8 +199,18 @@ + let show_filename file = + if !Clflags.absname then absolute_path file else file + +-let print_filename ppf file = +- Format.pp_print_string ppf (show_filename file) ++module Fmt = Format_doc ++module Doc = struct ++ ++ (* This is used by the toplevel and the report printers below. *) ++ let separate_new_message ppf () = ++ if not (is_first_message ()) then begin ++ Fmt.pp_print_newline ppf (); ++ incr num_loc_lines ++ end ++ ++ let filename ppf file = ++ Fmt.pp_print_string ppf (show_filename file) + + (* Best-effort printing of the text describing a location, of the form + 'File "foo.ml", line 3, characters 10-12'. +@@ -213,65 +218,73 @@ + Some of the information (filename, line number or characters numbers) in the + location might be invalid; in which case we do not print it. + *) +-let print_loc ppf loc = +- setup_tags (); +- let file_valid = function +- | "_none_" -> +- (* This is a dummy placeholder, but we print it anyway to please editors +- that parse locations in error messages (e.g. Emacs). *) +- true +- | "" | "//toplevel//" -> false +- | _ -> true +- in +- let line_valid line = line > 0 in +- let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in +- +- let file = +- (* According to the comment in location.mli, if [pos_fname] is "", we must +- use [!input_name]. *) +- if loc.loc_start.pos_fname = "" then !input_name +- else loc.loc_start.pos_fname +- in +- let startline = loc.loc_start.pos_lnum in +- let endline = loc.loc_end.pos_lnum in +- let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in +- let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in +- +- let first = ref true in +- let capitalize s = +- if !first then (first := false; String.capitalize_ascii s) +- else s in +- let comma () = +- if !first then () else Format.fprintf ppf ", " in +- +- Format.fprintf ppf "@{"; +- +- if file_valid file then +- Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file; +- +- (* Print "line 1" in the case of a dummy line number. This is to please the +- existing setup of editors that parse locations in error messages (e.g. +- Emacs). *) +- comma (); +- let startline = if line_valid startline then startline else 1 in +- let endline = if line_valid endline then endline else startline in +- begin if startline = endline then +- Format.fprintf ppf "%s %i" (capitalize "line") startline +- else +- Format.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline +- end; ++ let loc ppf loc = ++ setup_tags (); ++ let file_valid = function ++ | "_none_" -> ++ (* This is a dummy placeholder, but we print it anyway to please ++ editors that parse locations in error messages (e.g. Emacs). *) ++ true ++ | "" | "//toplevel//" -> false ++ | _ -> true ++ in ++ let line_valid line = line > 0 in ++ let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in + +- if chars_valid ~startchar ~endchar then ( ++ let file = ++ (* According to the comment in location.mli, if [pos_fname] is "", we must ++ use [!input_name]. *) ++ if loc.loc_start.pos_fname = "" then !input_name ++ else loc.loc_start.pos_fname ++ in ++ let startline = loc.loc_start.pos_lnum in ++ let endline = loc.loc_end.pos_lnum in ++ let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in ++ let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in ++ ++ let first = ref true in ++ let capitalize s = ++ if !first then (first := false; String.capitalize_ascii s) ++ else s in ++ let comma () = ++ if !first then () else Fmt.fprintf ppf ", " in ++ ++ Fmt.fprintf ppf "@{"; ++ ++ if file_valid file then ++ Fmt.fprintf ppf "%s \"%a\"" (capitalize "file") filename file; ++ ++ (* Print "line 1" in the case of a dummy line number. This is to please the ++ existing setup of editors that parse locations in error messages (e.g. ++ Emacs). *) + comma (); +- Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar +- ); ++ let startline = if line_valid startline then startline else 1 in ++ let endline = if line_valid endline then endline else startline in ++ begin if startline = endline then ++ Fmt.fprintf ppf "%s %i" (capitalize "line") startline ++ else ++ Fmt.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline ++ end; + +- Format.fprintf ppf "@}" ++ if chars_valid ~startchar ~endchar then ( ++ comma (); ++ Fmt.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar ++ ); ++ ++ Fmt.fprintf ppf "@}" ++ ++ (* Print a comma-separated list of locations *) ++ let locs ppf locs = ++ Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.fprintf ppf ",@ ") ++ loc ppf locs ++ let quoted_filename ppf f = Misc.Style.as_inline_code filename ppf f + +-(* Print a comma-separated list of locations *) +-let print_locs ppf locs = +- Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") +- print_loc ppf locs ++end ++ ++let print_filename = Fmt.compat Doc.filename ++let print_loc = Fmt.compat Doc.loc ++let print_locs = Fmt.compat Doc.locs ++let separate_new_message ppf = Fmt.compat Doc.separate_new_message ppf () + + (******************************************************************************) + (* An interval set structure; additionally, it stores user-provided information +@@ -497,13 +510,13 @@ + Option.fold ~some:Int.to_string ~none:"" lnum, + start_pos)) + in +- Format.fprintf ppf "@["; ++ Fmt.fprintf ppf "@["; + begin match lines with + | [] | [("", _, _)] -> () + | [(line, line_nb, line_start_cnum)] -> + (* Single-line error *) +- Format.fprintf ppf "%s | %s@," line_nb line; +- Format.fprintf ppf "%*s " (String.length line_nb) ""; ++ Fmt.fprintf ppf "%s | %s@," line_nb line; ++ Fmt.fprintf ppf "%*s " (String.length line_nb) ""; + (* Iterate up to [rightmost], which can be larger than the length of + the line because we may point to a location after the end of the + last token on the line, for instance: +@@ -515,21 +528,21 @@ + for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do + let pos = line_start_cnum + i in + if ISet.is_start iset ~pos <> None then +- Format.fprintf ppf "@{<%s>" highlight_tag; +- if ISet.mem iset ~pos then Format.pp_print_char ppf '^' ++ Fmt.fprintf ppf "@{<%s>" highlight_tag; ++ if ISet.mem iset ~pos then Fmt.pp_print_char ppf '^' + else if i < String.length line then begin + (* For alignment purposes, align using a tab for each tab in the + source code *) +- if line.[i] = '\t' then Format.pp_print_char ppf '\t' +- else Format.pp_print_char ppf ' ' ++ if line.[i] = '\t' then Fmt.pp_print_char ppf '\t' ++ else Fmt.pp_print_char ppf ' ' + end; + if ISet.is_end iset ~pos <> None then +- Format.fprintf ppf "@}" ++ Fmt.fprintf ppf "@}" + done; +- Format.fprintf ppf "@}@," ++ Fmt.fprintf ppf "@}@," + | _ -> + (* Multi-line error *) +- Misc.pp_two_columns ~sep:"|" ~max_lines ppf ++ Fmt.pp_two_columns ~sep:"|" ~max_lines ppf + @@ List.map (fun (line, line_nb, line_start_cnum) -> + let line = String.mapi (fun i car -> + if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.' +@@ -537,7 +550,7 @@ + (line_nb, line) + ) lines + end; +- Format.fprintf ppf "@]" ++ Fmt.fprintf ppf "@]" + + + +@@ -633,10 +646,10 @@ + (******************************************************************************) + (* Reporting errors and warnings *) + +-type msg = (Format.formatter -> unit) loc ++type msg = Fmt.t loc + + let msg ?(loc = none) fmt = +- Format.kdprintf (fun txt -> { loc; txt }) fmt ++ Fmt.kdoc_printf (fun txt -> { loc; txt }) fmt + + type report_kind = + | Report_error +@@ -649,6 +662,7 @@ + kind : report_kind; + main : msg; + sub : msg list; ++ footnote: Fmt.t option; + } + + type report_printer = { +@@ -661,7 +675,7 @@ + pp_main_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_main_txt : report_printer -> report -> +- Format.formatter -> (Format.formatter -> unit) -> unit; ++ Format.formatter -> Fmt.t -> unit; + pp_submsgs : report_printer -> report -> + Format.formatter -> msg list -> unit; + pp_submsg : report_printer -> report -> +@@ -669,7 +683,7 @@ + pp_submsg_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_submsg_txt : report_printer -> report -> +- Format.formatter -> (Format.formatter -> unit) -> unit; ++ Format.formatter -> Fmt.t -> unit; + } + + let is_dummy_loc loc = +@@ -725,9 +739,13 @@ + | Misc.Error_style.Short -> + () + in +- Format.fprintf ppf "@[%a:@ %a@]" print_loc loc highlight loc ++ Format.fprintf ppf "@[%a:@ %a@]" print_loc loc ++ (Fmt.compat highlight) loc ++ in ++ let pp_txt ppf txt = Format.fprintf ppf "@[%a@]" Fmt.Doc.format txt in ++ let pp_footnote ppf f = ++ Option.iter (Format.fprintf ppf "@,%a" pp_txt) f + in +- let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in + let pp self ppf report = + setup_tags (); + separate_new_message ppf; +@@ -736,13 +754,14 @@ + to be aligned with the main message box + *) + print_updating_num_loc_lines ppf (fun ppf () -> +- Format.fprintf ppf "@[%a%a%a: %a%a%a%a@]@." ++ Format.fprintf ppf "@[%a%a%a: %a%a%a%a%a@]@." + Format.pp_open_tbox () + (self.pp_main_loc self report) report.main.loc + (self.pp_report_kind self report) report.kind + Format.pp_set_tab () + (self.pp_main_txt self report) report.main.txt + (self.pp_submsgs self report) report.sub ++ pp_footnote report.footnote + Format.pp_close_tbox () + ) () + in +@@ -824,21 +843,22 @@ + (* Reporting errors *) + + type error = report ++type delayed_msg = unit -> Fmt.t option + + let report_error ppf err = + print_report ppf err + +-let mkerror loc sub txt = +- { kind = Report_error; main = { loc; txt }; sub } ++let mkerror loc sub footnote txt = ++ { kind = Report_error; main = { loc; txt }; sub; footnote=footnote () } + +-let errorf ?(loc = none) ?(sub = []) = +- Format.kdprintf (mkerror loc sub) ++let errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = ++ Fmt.kdoc_printf (mkerror loc sub footnote) + +-let error ?(loc = none) ?(sub = []) msg_str = +- mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str) ++let error ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) msg_str = ++ mkerror loc sub footnote Fmt.Doc.(string msg_str empty) + +-let error_of_printer ?(loc = none) ?(sub = []) pp x = +- mkerror loc sub (fun ppf -> pp ppf x) ++let error_of_printer ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) pp x = ++ mkerror loc sub footnote (Fmt.doc_printf "%a" pp x) + + let error_of_printer_file print x = + error_of_printer ~loc:(in_file !input_name) print x +@@ -851,13 +871,13 @@ + match report w with + | `Inactive -> None + | `Active { Warnings.id; message; is_error; sub_locs } -> +- let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in ++ let msg_of_str str = Format_doc.Doc.(empty |> string str) in + let kind = mk is_error id in + let main = { loc; txt = msg_of_str message } in + let sub = List.map (fun (loc, sub_message) -> + { loc; txt = msg_of_str sub_message } + ) sub_locs in +- Some { kind; main; sub } ++ Some { kind; main; sub; footnote=None } + + + let default_warning_reporter = +@@ -907,7 +927,7 @@ + module Style = Misc.Style + + let auto_include_alert lib = +- let message = Format.asprintf "\ ++ let message = Fmt.asprintf "\ + OCaml's lib directory layout changed in 5.0. The %a subdirectory has been \ + automatically added to the search path, but you should add %a to the \ + command-line to silence this alert (e.g. by adding %a to the list of \ +@@ -926,7 +946,7 @@ + prerr_alert none alert + + let deprecated_script_alert program = +- let message = Format.asprintf "\ ++ let message = Fmt.asprintf "\ + Running %a where the first argument is an implicit basename with no \ + extension (e.g. %a) is deprecated. Either rename the script \ + (%a) or qualify the basename (%a)" +@@ -992,5 +1012,5 @@ + | _ -> None + ) + +-let raise_errorf ?(loc = none) ?(sub = []) = +- Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt))) ++let raise_errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = ++ Fmt.kdoc_printf (fun txt -> raise (Error (mkerror loc sub footnote txt))) diff --git a/upstream/patches_503/parsing/location.mli.patch b/upstream/patches_503/parsing/location.mli.patch new file mode 100644 index 000000000..217131a9b --- /dev/null +++ b/upstream/patches_503/parsing/location.mli.patch @@ -0,0 +1,102 @@ +--- ocaml_502/parsing/location.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/location.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -88,7 +88,6 @@ + (** {1 Toplevel-specific functions} *) + + val echo_eof: unit -> unit +-val separate_new_message: formatter -> unit + val reset: unit -> unit + + +@@ -170,10 +169,17 @@ + Otherwise, returns the filename unchanged. *) + + val print_filename: formatter -> string -> unit +- + val print_loc: formatter -> t -> unit + val print_locs: formatter -> t list -> unit ++val separate_new_message: formatter -> unit + ++module Doc: sig ++ val separate_new_message: unit Format_doc.printer ++ val filename: string Format_doc.printer ++ val quoted_filename: string Format_doc.printer ++ val loc: t Format_doc.printer ++ val locs: t list Format_doc.printer ++end + + (** {1 Toplevel-specific location highlighting} *) + +@@ -185,9 +191,9 @@ + + (** {2 The type of reports and report printers} *) + +-type msg = (Format.formatter -> unit) loc ++type msg = Format_doc.t loc + +-val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a ++val msg: ?loc:t -> ('a, Format_doc.formatter, unit, msg) format4 -> 'a + + type report_kind = + | Report_error +@@ -200,6 +206,7 @@ + kind : report_kind; + main : msg; + sub : msg list; ++ footnote: Format_doc.t option + } + + type report_printer = { +@@ -212,7 +219,7 @@ + pp_main_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_main_txt : report_printer -> report -> +- Format.formatter -> (Format.formatter -> unit) -> unit; ++ Format.formatter -> Format_doc.t -> unit; + pp_submsgs : report_printer -> report -> + Format.formatter -> msg list -> unit; + pp_submsg : report_printer -> report -> +@@ -220,7 +227,7 @@ + pp_submsg_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_submsg_txt : report_printer -> report -> +- Format.formatter -> (Format.formatter -> unit) -> unit; ++ Format.formatter -> Format_doc.t -> unit; + } + (** A printer for [report]s, defined using open-recursion. + The goal is to make it easy to define new printers by re-using code from +@@ -321,15 +328,17 @@ + type error = report + (** An [error] is a [report] which [report_kind] must be [Report_error]. *) + +-val error: ?loc:t -> ?sub:msg list -> string -> error ++type delayed_msg = unit -> Format_doc.t option ++ ++val error: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> string -> error + +-val errorf: ?loc:t -> ?sub:msg list -> +- ('a, Format.formatter, unit, error) format4 -> 'a ++val errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> ++ ('a, Format_doc.formatter, unit, error) format4 -> 'a + +-val error_of_printer: ?loc:t -> ?sub:msg list -> +- (formatter -> 'a -> unit) -> 'a -> error ++val error_of_printer: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> ++ (Format_doc.formatter -> 'a -> unit) -> 'a -> error + +-val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error ++val error_of_printer_file: (Format_doc.formatter -> 'a -> unit) -> 'a -> error + + + (** {1 Automatically reporting errors for raised exceptions} *) +@@ -352,8 +361,8 @@ + (** Raising [Already_displayed_error] signals an error which has already been + printed. The exception will be caught, but nothing will be printed *) + +-val raise_errorf: ?loc:t -> ?sub:msg list -> +- ('a, Format.formatter, unit, 'b) format4 -> 'a ++val raise_errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> ++ ('a, Format_doc.formatter, unit, 'b) format4 -> 'a + + val report_exception: formatter -> exn -> unit + (** Reraise the exception if it is unknown. *) diff --git a/upstream/patches_503/parsing/parse.ml.patch b/upstream/patches_503/parsing/parse.ml.patch new file mode 100644 index 000000000..e729c2371 --- /dev/null +++ b/upstream/patches_503/parsing/parse.ml.patch @@ -0,0 +1,38 @@ +--- ocaml_502/parsing/parse.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/parse.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -138,7 +138,7 @@ + Location.errorf ~loc + "In this scoped type, variable %a \ + is reserved for the local type %a." +- (Style.as_inline_code Pprintast.tyvar) var ++ (Style.as_inline_code Pprintast.Doc.tyvar) var + Style.inline_code var + | Other loc -> + Location.errorf ~loc "Syntax error" +@@ -148,20 +148,20 @@ + | Invalid_package_type (loc, ipt) -> + let invalid ppf ipt = match ipt with + | Syntaxerr.Parameterized_types -> +- Format.fprintf ppf "parametrized types are not supported" ++ Format_doc.fprintf ppf "parametrized types are not supported" + | Constrained_types -> +- Format.fprintf ppf "constrained types are not supported" ++ Format_doc.fprintf ppf "constrained types are not supported" + | Private_types -> +- Format.fprintf ppf "private types are not supported" ++ Format_doc.fprintf ppf "private types are not supported" + | Not_with_type -> +- Format.fprintf ppf "only %a constraints are supported" ++ Format_doc.fprintf ppf "only %a constraints are supported" + Style.inline_code "with type t =" + | Neither_identifier_nor_with_type -> +- Format.fprintf ppf ++ Format_doc.fprintf ppf + "only module type identifier and %a constraints are supported" + Style.inline_code "with type" + in +- Location.errorf ~loc "invalid package type: %a" invalid ipt ++ Location.errorf ~loc "Syntax error: invalid package type: %a" invalid ipt + | Removed_string_set loc -> + Location.errorf ~loc + "Syntax error: strings are immutable, there is no assignment \ diff --git a/upstream/patches_503/parsing/parser.mly.patch b/upstream/patches_503/parsing/parser.mly.patch new file mode 100644 index 000000000..0d20f3040 --- /dev/null +++ b/upstream/patches_503/parsing/parser.mly.patch @@ -0,0 +1,225 @@ +--- ocaml_502/parsing/parser.mly 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/parser.mly 2024-09-17 01:16:30.152541842 +0200 +@@ -58,6 +58,7 @@ + let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d + let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d + let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d ++let mkconst ~loc c = Const.mk ~loc:(make_loc loc) c + + let pstr_typext (te, ext) = + (Pstr_typext te, ext) +@@ -150,20 +151,31 @@ + then String.sub f 1 (String.length f - 1) + else "-" ^ f + +-let mkuminus ~oploc name arg = +- match name, arg.pexp_desc with +- | "-", Pexp_constant(Pconst_integer (n,m)) -> +- Pexp_constant(Pconst_integer(neg_string n,m)) +- | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) -> +- Pexp_constant(Pconst_float(neg_string f, m)) ++(* Pre-apply the special [-], [-.], [+] and [+.] prefix operators into ++ constants if possible, otherwise turn them into the corresponding prefix ++ operators [~-], [~-.], etc.. *) ++let mkuminus ~sloc ~oploc name arg = ++ match name, arg.pexp_desc, arg.pexp_attributes with ++ | "-", ++ Pexp_constant({pconst_desc = Pconst_integer (n,m); pconst_loc=_}), ++ [] -> ++ Pexp_constant(mkconst ~loc:sloc (Pconst_integer(neg_string n, m))) ++ | ("-" | "-."), ++ Pexp_constant({pconst_desc = Pconst_float (f, m); pconst_loc=_}), [] -> ++ Pexp_constant(mkconst ~loc:sloc (Pconst_float(neg_string f, m))) + | _ -> + Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) + +-let mkuplus ~oploc name arg = ++let mkuplus ~sloc ~oploc name arg = + let desc = arg.pexp_desc in +- match name, desc with +- | "+", Pexp_constant(Pconst_integer _) +- | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc ++ match name, desc, arg.pexp_attributes with ++ | "+", ++ Pexp_constant({pconst_desc = Pconst_integer _ as desc; pconst_loc=_}), ++ [] ++ | ("+" | "+."), ++ Pexp_constant({pconst_desc = Pconst_float _ as desc; pconst_loc=_}), ++ [] -> ++ Pexp_constant(mkconst ~loc:sloc desc) + | _ -> + Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) + +@@ -478,7 +490,8 @@ + + let mk_quotedext ~loc (id, idloc, str, strloc, delim) = + let exp_id = mkloc id idloc in +- let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in ++ let const = Const.mk ~loc:strloc (Pconst_string (str, strloc, delim)) in ++ let e = ghexp ~loc (Pexp_constant const) in + (exp_id, PStr [mkstrexp e []]) + + let text_str pos = Str.text (rhs_text pos) +@@ -648,6 +661,11 @@ + | Some newtypes -> + mkghost_newtype_function_body newtypes body_constraint body_exp + ++let mk_functor_typ args mty = ++ List.fold_left (fun acc (startpos, arg) -> ++ mkmty ~loc:(startpos, mty.pmty_loc.loc_end) (Pmty_functor (arg, acc))) ++ mty args ++ + (* Alternatively, we could keep the generic module type in the Parsetree + and extract the package type during type-checking. In that case, + the assertions below should be turned into explicit checks. *) +@@ -733,6 +751,7 @@ + %token DOT "." + %token DOTDOT ".." + %token DOWNTO "downto" ++%token EFFECT "effect" + %token ELSE "else" + %token END "end" + %token EOF "" +@@ -838,6 +857,11 @@ + + %token EOL "\\n" (* not great, but EOL is unused *) + ++(* see the [metaocaml_expr] comment *) ++%token METAOCAML_ESCAPE ".~" ++%token METAOCAML_BRACKET_OPEN ".<" ++%token METAOCAML_BRACKET_CLOSE ">." ++ + /* Precedences and associativities. + + Tokens and rules have precedences. A reduce/reduce conflict is resolved +@@ -901,7 +925,7 @@ + LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN + NEW PREFIXOP STRING TRUE UIDENT + LBRACKETPERCENT QUOTED_STRING_EXPR +- ++ METAOCAML_BRACKET_OPEN METAOCAML_ESCAPE + + /* Entry points */ + +@@ -1696,11 +1720,11 @@ + | FUNCTOR attrs = attributes args = functor_args + MINUSGREATER mty = module_type + %prec below_WITH +- { wrap_mty_attrs ~loc:$sloc attrs ( +- List.fold_left (fun acc (startpos, arg) -> +- mkmty ~loc:(startpos, $endpos) (Pmty_functor (arg, acc)) +- ) mty args +- ) } ++ { wrap_mty_attrs ~loc:$sloc attrs (mk_functor_typ args mty) } ++ | args = functor_args ++ MINUSGREATER mty = module_type ++ %prec below_WITH ++ { mk_functor_typ args mty } + | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT + { mkmty ~loc:$sloc ~attrs:$4 (Pmty_typeof $5) } + | LPAREN module_type RPAREN +@@ -1712,8 +1736,6 @@ + | mkmty( + mkrhs(mty_longident) + { Pmty_ident $1 } +- | LPAREN RPAREN MINUSGREATER module_type +- { Pmty_functor(Unit, $4) } + | module_type MINUSGREATER module_type + %prec below_WITH + { Pmty_functor(Named (mknoloc None, $1), $3) } +@@ -2483,9 +2505,9 @@ + | e1 = fun_expr op = op(infix_operator) e2 = expr + { mkinfix e1 op e2 } + | subtractive expr %prec prec_unary_minus +- { mkuminus ~oploc:$loc($1) $1 $2 } ++ { mkuminus ~sloc:$sloc ~oploc:$loc($1) $1 $2 } + | additive expr %prec prec_unary_plus +- { mkuplus ~oploc:$loc($1) $1 $2 } ++ { mkuplus ~sloc:$sloc ~oploc:$loc($1) $1 $2 } + ; + + simple_expr: +@@ -2501,6 +2523,7 @@ + { mk_indexop_expr user_indexing_operators ~loc:$sloc $1 } + | indexop_error (DOT, seq_expr) { $1 } + | indexop_error (qualified_dotop, expr_semi_list) { $1 } ++ | metaocaml_expr { $1 } + | simple_expr_attrs + { let desc, attrs = $1 in + mkexp_attrs ~loc:$sloc desc attrs } +@@ -2527,6 +2550,25 @@ + | OBJECT ext_attributes class_structure error + { unclosed "object" $loc($1) "end" $loc($4) } + ; ++ ++(* We include this parsing rule from the BER-MetaOCaml patchset ++ (see https://okmij.org/ftp/ML/MetaOCaml.html) ++ even though the lexer does *not* include any lexing rule ++ for the METAOCAML_* tokens, so they ++ will never be produced by the upstream compiler. ++ ++ The intention of this dead parsing rule is purely to ease the ++ future maintenance work on MetaOCaml. ++*) ++%inline metaocaml_expr: ++ | METAOCAML_ESCAPE e = simple_expr ++ { wrap_exp_attrs ~loc:$sloc e ++ (Some (mknoloc "metaocaml.escape"), []) } ++ | METAOCAML_BRACKET_OPEN e = seq_expr METAOCAML_BRACKET_CLOSE ++ { wrap_exp_attrs ~loc:$sloc e ++ (Some (mknoloc "metaocaml.bracket"),[]) } ++; ++ + %inline simple_expr_: + | mkrhs(val_longident) + { Pexp_ident ($1) } +@@ -2864,6 +2906,8 @@ + { $1 } + | EXCEPTION ext_attributes pattern %prec prec_constr_appl + { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2} ++ | EFFECT pattern_gen COMMA simple_pattern ++ { mkpat ~loc:$sloc (Ppat_effect($2,$4)) } + ; + + pattern_no_exn: +@@ -2909,6 +2953,7 @@ + | LAZY ext_attributes simple_pattern + { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2} + ; ++ + simple_pattern: + mkpat(mkrhs(val_ident) %prec below_EQUAL + { Ppat_var ($1) }) +@@ -3723,17 +3768,24 @@ + /* Constants */ + + constant: +- | INT { let (n, m) = $1 in Pconst_integer (n, m) } +- | CHAR { Pconst_char $1 } +- | STRING { let (s, strloc, d) = $1 in Pconst_string (s, strloc, d) } +- | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } ++ | INT { let (n, m) = $1 in ++ mkconst ~loc:$sloc (Pconst_integer (n, m)) } ++ | CHAR { mkconst ~loc:$sloc (Pconst_char $1) } ++ | STRING { let (s, strloc, d) = $1 in ++ mkconst ~loc:$sloc (Pconst_string (s,strloc,d)) } ++ | FLOAT { let (f, m) = $1 in ++ mkconst ~loc:$sloc (Pconst_float (f, m)) } + ; + signed_constant: + constant { $1 } +- | MINUS INT { let (n, m) = $2 in Pconst_integer("-" ^ n, m) } +- | MINUS FLOAT { let (f, m) = $2 in Pconst_float("-" ^ f, m) } +- | PLUS INT { let (n, m) = $2 in Pconst_integer (n, m) } +- | PLUS FLOAT { let (f, m) = $2 in Pconst_float(f, m) } ++ | MINUS INT { let (n, m) = $2 in ++ mkconst ~loc:$sloc (Pconst_integer("-" ^ n, m)) } ++ | MINUS FLOAT { let (f, m) = $2 in ++ mkconst ~loc:$sloc (Pconst_float("-" ^ f, m)) } ++ | PLUS INT { let (n, m) = $2 in ++ mkconst ~loc:$sloc (Pconst_integer (n, m)) } ++ | PLUS FLOAT { let (f, m) = $2 in ++ mkconst ~loc:$sloc (Pconst_float(f, m)) } + ; + + /* Identifiers and long identifiers */ diff --git a/upstream/patches_503/parsing/parsetree.mli.patch b/upstream/patches_503/parsing/parsetree.mli.patch new file mode 100644 index 000000000..b2b3a31df --- /dev/null +++ b/upstream/patches_503/parsing/parsetree.mli.patch @@ -0,0 +1,24 @@ +--- ocaml_502/parsing/parsetree.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/parsetree.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -22,7 +22,12 @@ + + open Asttypes + +-type constant = ++type constant = { ++ pconst_desc : constant_desc; ++ pconst_loc : Location.t; ++} ++ ++and constant_desc = + | Pconst_integer of string * char option + (** Integer constants such as [3] [3l] [3L] [3n]. + +@@ -270,6 +275,7 @@ + [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] + *) + | Ppat_exception of pattern (** Pattern [exception P] *) ++ | Ppat_effect of pattern * pattern (* Pattern [effect P P] *) + | Ppat_extension of extension (** Pattern [[%id]] *) + | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) + diff --git a/upstream/patches_503/parsing/pprintast.ml.patch b/upstream/patches_503/parsing/pprintast.ml.patch new file mode 100644 index 000000000..a2c8e41a8 --- /dev/null +++ b/upstream/patches_503/parsing/pprintast.ml.patch @@ -0,0 +1,178 @@ +--- ocaml_502/parsing/pprintast.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/pprintast.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -94,26 +94,95 @@ + let needs_spaces txt = + first_is '*' txt || last_is '*' txt + ++let tyvar_of_name s = ++ if String.length s >= 2 && s.[1] = '\'' then ++ (* without the space, this would be parsed as ++ a character literal *) ++ "' " ^ s ++ else if Lexer.is_keyword s then ++ "'\\#" ^ s ++ else if String.equal s "_" then ++ s ++ else ++ "'" ^ s ++ ++module Doc = struct + (* Turn an arbitrary variable name into a valid OCaml identifier by adding \# + in case it is a keyword, or parenthesis when it is an infix or prefix + operator. *) +-let ident_of_name ppf txt = +- let format : (_, _, _) format = +- if Lexer.is_keyword txt then "\\#%s" +- else if not (needs_parens txt) then "%s" +- else if needs_spaces txt then "(@;%s@;)" +- else "(%s)" +- in fprintf ppf format txt ++ let ident_of_name ppf txt = ++ let format : (_, _, _) format = ++ if Lexer.is_keyword txt then "\\#%s" ++ else if not (needs_parens txt) then "%s" ++ else if needs_spaces txt then "(@;%s@;)" ++ else "(%s)" ++ in Format_doc.fprintf ppf format txt + +-let ident_of_name_loc ppf s = ident_of_name ppf s.txt +- +-let protect_longident ppf print_longident longprefix txt = ++ let protect_longident ppf print_longident longprefix txt = + if not (needs_parens txt) then +- fprintf ppf "%a.%a" print_longident longprefix ident_of_name txt ++ Format_doc.fprintf ppf "%a.%a" ++ print_longident longprefix ++ ident_of_name txt + else if needs_spaces txt then +- fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt ++ Format_doc.fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt + else +- fprintf ppf "%a.(%s)" print_longident longprefix txt ++ Format_doc.fprintf ppf "%a.(%s)" print_longident longprefix txt ++ ++ let rec longident f = function ++ | Lident s -> ident_of_name f s ++ | Ldot(y,s) -> protect_longident f longident y s ++ | Lapply (y,s) -> ++ Format_doc.fprintf f "%a(%a)" longident y longident s ++ ++ let tyvar ppf s = ++ Format_doc.fprintf ppf "%s" (tyvar_of_name s) ++ ++ (* Expressions are considered nominal if they can be used as the subject of a ++ sentence or action. In practice, we consider that an expression is nominal ++ if they satisfy one of: ++ - Similar to an identifier: words separated by '.' or '#'. ++ - Do not contain spaces when printed. ++ - Is a constant that is short enough. ++ *) ++ let nominal_exp t = ++ let open Format_doc.Doc in ++ let longident l = Format_doc.doc_printer longident l.Location.txt in ++ let rec nominal_exp doc exp = ++ match exp.pexp_desc with ++ | _ when exp.pexp_attributes <> [] -> None ++ | Pexp_ident l -> ++ Some (longident l doc) ++ | Pexp_variant (lbl, None) -> ++ Some (printf "`%s" lbl doc) ++ | Pexp_construct (l, None) -> ++ Some (longident l doc) ++ | Pexp_field (parent, lbl) -> ++ Option.map ++ (printf ".%t" (longident lbl)) ++ (nominal_exp doc parent) ++ | Pexp_send (parent, meth) -> ++ Option.map ++ (printf "#%s" meth.txt) ++ (nominal_exp doc parent) ++ (* String constants are syntactically too complex. For example, the ++ quotes conflict with the 'inline_code' style and they might contain ++ spaces. *) ++ | Pexp_constant { pconst_desc = Pconst_string _; _ } -> None ++ (* Char, integer and float constants are nominal. *) ++ | Pexp_constant { pconst_desc = Pconst_char c; _ } -> ++ Some (msg "%C" c) ++ | Pexp_constant ++ { pconst_desc = Pconst_integer (cst, suf) | Pconst_float (cst, suf); ++ _ } -> ++ Some (msg "%s%t" cst (option char suf)) ++ | _ -> None ++ in ++ nominal_exp empty t ++end ++ ++let longident ppf l = Format_doc.compat Doc.longident ppf l ++let ident_of_name ppf i = Format_doc.compat Doc.ident_of_name ppf i ++let ident_of_name_loc ppf s = ident_of_name ppf s.txt + + type space_formatter = (unit, Format.formatter, unit) format + +@@ -225,15 +294,9 @@ + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") + else fu f x + +-let rec longident f = function +- | Lident s -> ident_of_name f s +- | Ldot(y,s) -> protect_longident f longident y s +- | Lapply (y,s) -> +- pp f "%a(%a)" longident y longident s +- + let longident_loc f x = pp f "%a" longident x.txt + +-let constant f = function ++let constant_desc f = function + | Pconst_char i -> + pp f "%C" i + | Pconst_string (i, _, None) -> +@@ -249,6 +312,8 @@ + | Pconst_float (i, Some m) -> + paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m) + ++let constant f const = constant_desc f const.pconst_desc ++ + (* trailing space*) + let mutable_flag f = function + | Immutable -> () +@@ -277,20 +342,9 @@ + + let constant_string f s = pp f "%S" s + +-let tyvar_of_name s = +- if String.length s >= 2 && s.[1] = '\'' then +- (* without the space, this would be parsed as +- a character literal *) +- "' " ^ s +- else if Lexer.is_keyword s then +- "'\\#" ^ s +- else if String.equal s "_" then +- s +- else +- "'" ^ s + +-let tyvar ppf s = +- Format.fprintf ppf "%s" (tyvar_of_name s) ++ ++let tyvar ppf v = Format_doc.compat Doc.tyvar ppf v + + let tyvar_loc f str = tyvar f str.txt + let string_quot f x = pp f "`%a" ident_of_name x +@@ -512,6 +566,8 @@ + pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p ++ | Ppat_effect(p1, p2) -> ++ pp f "@[<2>effect@;%a, @;%a@]" (pattern1 ctxt) p1 (pattern1 ctxt) p2 + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = +@@ -1132,7 +1188,7 @@ + pp f "@[%a@ ->@ %a@]" + (module_type1 ctxt) mt1 (module_type ctxt) mt2 + | Some name -> +- pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name ++ pp f "@[(%s@ :@ %a)@ ->@ %a@]" name + (module_type ctxt) mt1 (module_type ctxt) mt2 + end + | Pmty_with (mt, []) -> module_type ctxt f mt diff --git a/upstream/patches_503/parsing/pprintast.mli.patch b/upstream/patches_503/parsing/pprintast.mli.patch new file mode 100644 index 000000000..67b90ba0e --- /dev/null +++ b/upstream/patches_503/parsing/pprintast.mli.patch @@ -0,0 +1,16 @@ +--- ocaml_502/parsing/pprintast.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/pprintast.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -59,3 +59,13 @@ + (** Print a type variable name as a valid identifier, taking care of the + special treatment required for the single quote character in second + position, or for keywords by escaping them with \#. No-op on "_". *) ++ ++(** {!Format_doc} functions for error messages *) ++module Doc:sig ++ val longident: Longident.t Format_doc.printer ++ val tyvar: string Format_doc.printer ++ ++ (** Returns a format document if the expression reads nicely as the subject ++ of a sentence in a error message. *) ++ val nominal_exp : Parsetree.expression -> Format_doc.t option ++end diff --git a/upstream/patches_503/parsing/printast.ml.patch b/upstream/patches_503/parsing/printast.ml.patch new file mode 100644 index 000000000..f5a8016ea --- /dev/null +++ b/upstream/patches_503/parsing/printast.ml.patch @@ -0,0 +1,76 @@ +--- ocaml_502/parsing/printast.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/printast.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -57,16 +57,6 @@ + | None -> fprintf f "None" + | Some c -> fprintf f "Some %c" c + +-let fmt_constant f x = +- match x with +- | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m +- | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c) +- | Pconst_string (s, strloc, None) -> +- fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc +- | Pconst_string (s, strloc, Some delim) -> +- fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim +- | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m +- + let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable" +@@ -106,6 +96,18 @@ + fprintf f "%s" (String.make ((2*i) mod 72) ' '); + fprintf f s (*...*) + ++let fmt_constant i f x = ++ line i f "constant %a\n" fmt_location x.pconst_loc; ++ let i = i+1 in ++ match x.pconst_desc with ++ | Pconst_integer (j,m) -> line i f "PConst_int (%s,%a)\n" j fmt_char_option m ++ | Pconst_char c -> line i f "PConst_char %02x\n" (Char.code c) ++ | Pconst_string (s, strloc, None) -> ++ line i f "PConst_string(%S,%a,None)\n" s fmt_location strloc ++ | Pconst_string (s, strloc, Some delim) -> ++ line i f "PConst_string (%S,%a,Some %S)\n" s fmt_location strloc delim ++ | Pconst_float (s,m) -> line i f "PConst_float (%s,%a)\n" s fmt_char_option m ++ + let list i f ppf l = + match l with + | [] -> line i ppf "[]\n" +@@ -201,9 +203,13 @@ + | Ppat_alias (p, s) -> + line i ppf "Ppat_alias %a\n" fmt_string_loc s; + pattern i ppf p; +- | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; ++ | Ppat_constant (c) -> ++ line i ppf "Ppat_constant\n"; ++ fmt_constant i ppf c; + | Ppat_interval (c1, c2) -> +- line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; ++ line i ppf "Ppat_interval\n"; ++ fmt_constant i ppf c1; ++ fmt_constant i ppf c2; + | Ppat_tuple (l) -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l; +@@ -242,6 +248,10 @@ + | Ppat_exception p -> + line i ppf "Ppat_exception\n"; + pattern i ppf p ++ | Ppat_effect(p1, p2) -> ++ line i ppf "Ppat_effect\n"; ++ pattern i ppf p1; ++ pattern i ppf p2 + | Ppat_open (m,p) -> + line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; + pattern i ppf p +@@ -255,7 +265,9 @@ + let i = i+1 in + match x.pexp_desc with + | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; +- | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; ++ | Pexp_constant (c) -> ++ line i ppf "Pexp_constant\n"; ++ fmt_constant i ppf c; + | Pexp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; diff --git a/upstream/patches_503/parsing/unit_info.ml.patch b/upstream/patches_503/parsing/unit_info.ml.patch new file mode 100644 index 000000000..869e98d5f --- /dev/null +++ b/upstream/patches_503/parsing/unit_info.ml.patch @@ -0,0 +1,111 @@ +--- ocaml_502/parsing/unit_info.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/unit_info.ml 2024-09-17 01:16:30.152541842 +0200 +@@ -13,18 +13,24 @@ + (* *) + (**************************************************************************) + ++type intf_or_impl = Intf | Impl + type modname = string + type filename = string + type file_prefix = string + ++type error = Invalid_encoding of string ++exception Error of error ++ + type t = { + source_file: filename; + prefix: file_prefix; + modname: modname; ++ kind: intf_or_impl; + } + + let source_file (x: t) = x.source_file + let modname (x: t) = x.modname ++let kind (x: t) = x.kind + let prefix (x: t) = x.prefix + + let basename_chop_extensions basename = +@@ -32,37 +38,39 @@ + | dot_pos -> String.sub basename 0 dot_pos + | exception Not_found -> basename + +-let modulize s = String.capitalize_ascii s ++let strict_modulize s = ++ match Misc.Utf8_lexeme.capitalize s with ++ | Ok x -> x ++ | Error _ -> raise (Error (Invalid_encoding s)) ++ ++let modulize s = match Misc.Utf8_lexeme.capitalize s with Ok x | Error x -> x ++ ++(* We re-export the [Misc] definition, and ignore encoding errors under the ++ assumption that we should focus our effort on not *producing* badly encoded ++ module names *) ++let normalize x = match Misc.normalized_unit_filename x with ++ | Ok x | Error x -> x + +-(* We re-export the [Misc] definition *) +-let normalize = Misc.normalized_unit_filename ++let stem source_file = ++ source_file |> Filename.basename |> basename_chop_extensions + +-let modname_from_source source_file = +- source_file |> Filename.basename |> basename_chop_extensions |> modulize ++let strict_modname_from_source source_file = ++ source_file |> stem |> strict_modulize + +-let start_char = function +- | 'A' .. 'Z' -> true +- | _ -> false +- +-let is_identchar_latin1 = function +- | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' +- | '\248'..'\255' | '\'' | '0'..'9' -> true +- | _ -> false ++let lax_modname_from_source source_file = ++ source_file |> stem |> modulize + + (* Check validity of module name *) +-let is_unit_name name = +- String.length name > 0 +- && start_char name.[0] +- && String.for_all is_identchar_latin1 name ++let is_unit_name name = Misc.Utf8_lexeme.is_valid_identifier name + + let check_unit_name file = + if not (is_unit_name (modname file)) then + Location.prerr_warning (Location.in_file (source_file file)) + (Warnings.Bad_module_name (modname file)) + +-let make ?(check_modname=true) ~source_file prefix = +- let modname = modname_from_source prefix in +- let p = { modname; prefix; source_file } in ++let make ?(check_modname=true) ~source_file kind prefix = ++ let modname = strict_modname_from_source prefix in ++ let p = { modname; prefix; source_file; kind } in + if check_modname then check_unit_name p; + p + +@@ -79,7 +87,7 @@ + let prefix x = Filename.remove_extension (filename x) + + let from_filename filename = +- let modname = modname_from_source filename in ++ let modname = lax_modname_from_source filename in + { modname; filename; source_file = None } + + end +@@ -120,3 +128,14 @@ + let filename = modname f ^ ".cmi" in + let filename = Load_path.find_normalized filename in + { Artifact.filename; modname = modname f; source_file = Some f.source_file } ++ ++let report_error = function ++ | Invalid_encoding name -> ++ Location.errorf "Invalid encoding of output name: %s." name ++ ++let () = ++ Location.register_error_of_exn ++ (function ++ | Error err -> Some (report_error err) ++ | _ -> None ++ ) diff --git a/upstream/patches_503/parsing/unit_info.mli.patch b/upstream/patches_503/parsing/unit_info.mli.patch new file mode 100644 index 000000000..f5b79b4ed --- /dev/null +++ b/upstream/patches_503/parsing/unit_info.mli.patch @@ -0,0 +1,78 @@ +--- ocaml_502/parsing/unit_info.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/parsing/unit_info.mli 2024-09-17 01:16:30.152541842 +0200 +@@ -21,24 +21,32 @@ + + (** {1:modname_from_strings Module name convention and computation} *) + ++type intf_or_impl = Intf | Impl + type modname = string + type filename = string + type file_prefix = string + ++type error = Invalid_encoding of filename ++exception Error of error ++ + (** [modulize s] capitalizes the first letter of [s]. *) + val modulize: string -> modname + + (** [normalize s] uncapitalizes the first letter of [s]. *) + val normalize: string -> string + +-(** [modname_from_source filename] is [modulize stem] where [stem] is the ++(** [lax_modname_from_source filename] is [modulize stem] where [stem] is the + basename of the filename [filename] stripped from all its extensions. +- For instance, [modname_from_source "/pa.th/x.ml.pp"] is ["X"]. *) +-val modname_from_source: filename -> modname ++ For instance, [lax_modname_from_source "/pa.th/x.ml.pp"] is ["X"]. *) ++val lax_modname_from_source: filename -> modname ++ ++(** Same as {!lax_modname_from_source} but raises an {!error.Invalid_encoding} ++ error on filename with invalid utf8 encoding. *) ++val strict_modname_from_source: filename -> modname + + (** {2:module_name_validation Module name validation function}*) + +-(** [is_unit_name ~strict name] is true only if [name] can be used as a ++(** [is_unit_name name] is true only if [name] can be used as a + valid module name. *) + val is_unit_name : modname -> bool + +@@ -67,19 +75,24 @@ + or compilation artifact.*) + val modname: t -> modname + ++(** [kind u] is the kind (interface or implementation) of the unit. *) ++val kind: t -> intf_or_impl ++ + (** [check_unit_name u] prints a warning if the derived module name [modname u] + should not be used as a module name as specified + by {!is_unit_name}[ ~strict:true]. *) + val check_unit_name : t -> unit + +-(** [make ~check ~source_file prefix] associates both the +- [source_file] and the module name {!modname_from_source}[ target_prefix] to +- the prefix filesystem path [prefix]. ++(** [make ~check ~source_file kind prefix] associates both the ++ [source_file] and the module name {!lax_modname_from_source}[ target_prefix] ++ to the prefix filesystem path [prefix]. + + If [check_modname=true], this function emits a warning if the derived module + name is not valid according to {!check_unit_name}. + *) +-val make: ?check_modname:bool -> source_file:filename -> file_prefix -> t ++val make: ++ ?check_modname:bool -> source_file:filename -> ++ intf_or_impl -> file_prefix -> t + + (** {1:artifact_function Build artifacts }*) + module Artifact: sig +@@ -103,7 +116,8 @@ + val modname: t -> modname + + (** [from_filename filename] reconstructs the module name +- [modname_from_source filename] associated to the artifact [filename]. *) ++ [lax_modname_from_source filename] associated to the artifact ++ [filename]. *) + val from_filename: filename -> t + + end diff --git a/upstream/patches_503/typing/btype.ml.patch b/upstream/patches_503/typing/btype.ml.patch new file mode 100644 index 000000000..4a442bc6a --- /dev/null +++ b/upstream/patches_503/typing/btype.ml.patch @@ -0,0 +1,309 @@ +--- ocaml_502/typing/btype.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/typing/btype.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -43,7 +43,6 @@ + let singleton ty = wrap_repr singleton ty + let fold f = TransientTypeMap.fold (wrap_type_expr f) + end +-module TransientTypeHash = Hashtbl.Make(TransientTypeOps) + module TypeHash = struct + include TransientTypeHash + let mem hash = wrap_repr (mem hash) +@@ -94,45 +93,85 @@ + f (type_expr t1, type_expr t2)) + end + +-(**** Forward declarations ****) +- +-let print_raw = +- ref (fun _ -> assert false : Format.formatter -> type_expr -> unit) +- + (**** Type level management ****) + + let generic_level = Ident.highest_scope +- +-(* Used to mark a type during a traversal. *) + let lowest_level = Ident.lowest_scope +-let pivot_level = 2 * lowest_level - 1 +- (* pivot_level - lowest_level < lowest_level *) ++ ++(**** leveled type pool ****) ++(* This defines a stack of pools of type nodes indexed by the level ++ we will try to generalize them in [Ctype.with_local_level_gen]. ++ [pool_of_level] returns the pool in which types at level [level] ++ should be kept, which is the topmost pool whose level is lower or ++ equal to [level]. ++ [Ctype.with_local_level_gen] shall call [with_new_pool] to create ++ a new pool at a given level. On return it shall process all nodes ++ that were added to the pool. ++ Remark: the only function adding to a pool is [add_to_pool], and ++ the only function returning the contents of a pool is [with_new_pool], ++ so that the initial pool can be added to, but never read from. *) ++ ++type pool = {level: int; mutable pool: transient_expr list; next: pool} ++(* To avoid an indirection we choose to add a dummy level at the end of ++ the list. It will never be accessed, as [pool_of_level] is always called ++ with [level >= 0]. *) ++let rec dummy = {level = max_int; pool = []; next = dummy} ++let pool_stack = s_table (fun () -> {level = 0; pool = []; next = dummy}) () ++ ++(* Lookup in the stack is linear, but the depth is the number of nested ++ generalization points (e.g. lhs of let-definitions), which in ML is known ++ to be generally low. In most cases we are allocating in the topmost pool. ++ In [Ctype.with_local_gen], we move non-generalizable type nodes from the ++ topmost pool to one deeper in the stack, so that for each type node the ++ accumulated depth of lookups over its life is bounded by the depth of ++ the stack when it was allocated. ++ In case this linear search turns out to be costly, we could switch to ++ binary search, exploiting the fact that the levels of pools in the stack ++ are expected to grow. *) ++let rec pool_of_level level pool = ++ if level >= pool.level then pool else pool_of_level level pool.next ++ ++(* Create a new pool at given level, and use it locally. *) ++let with_new_pool ~level f = ++ let pool = {level; pool = []; next = !pool_stack} in ++ let r = ++ Misc.protect_refs [ R(pool_stack, pool) ] f ++ in ++ (r, pool.pool) ++ ++let add_to_pool ~level ty = ++ if level >= generic_level || level <= lowest_level then () else ++ let pool = pool_of_level level !pool_stack in ++ pool.pool <- ty :: pool.pool + + (**** Some type creators ****) + ++let newty3 ~level ~scope desc = ++ let ty = proto_newty3 ~level ~scope desc in ++ add_to_pool ~level ty; ++ Transient_expr.type_expr ty ++ ++let newty2 ~level desc = ++ newty3 ~level ~scope:Ident.lowest_scope desc ++ + let newgenty desc = newty2 ~level:generic_level desc + let newgenvar ?name () = newgenty (Tvar name) + let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) + +-(* +-let newmarkedvar level = +- incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } +-let newmarkedgenvar () = +- incr new_id; +- { desc = Tvar; level = pivot_level - generic_level; id = !new_id } +-*) +- + (**** Check some types ****) + + let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false + let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false + let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false ++let is_poly_Tpoly ty = ++ match get_desc ty with Tpoly (_, _ :: _) -> true | _ -> false + let type_kind_is_abstract decl = + match decl.type_kind with Type_abstract _ -> true | _ -> false + let type_origin decl = + match decl.type_kind with + | Type_abstract origin -> origin + | Type_variant _ | Type_record _ | Type_open -> Definition ++let label_is_poly lbl = is_poly_Tpoly lbl.lbl_arg + + let dummy_method = "*dummy method*" + +@@ -238,7 +277,6 @@ + set_type_desc ty (Tvariant row) + | _ -> () + +- + (**********************************) + (* Utilities for type traversal *) + (**********************************) +@@ -303,24 +341,6 @@ + | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem + | Mlink rem -> iter_abbrev f !rem + +-type type_iterators = +- { it_signature: type_iterators -> signature -> unit; +- it_signature_item: type_iterators -> signature_item -> unit; +- it_value_description: type_iterators -> value_description -> unit; +- it_type_declaration: type_iterators -> type_declaration -> unit; +- it_extension_constructor: type_iterators -> extension_constructor -> unit; +- it_module_declaration: type_iterators -> module_declaration -> unit; +- it_modtype_declaration: type_iterators -> modtype_declaration -> unit; +- it_class_declaration: type_iterators -> class_declaration -> unit; +- it_class_type_declaration: type_iterators -> class_type_declaration -> unit; +- it_functor_param: type_iterators -> functor_parameter -> unit; +- it_module_type: type_iterators -> module_type -> unit; +- it_class_type: type_iterators -> class_type -> unit; +- it_type_kind: type_iterators -> type_decl_kind -> unit; +- it_do_type_expr: type_iterators -> type_expr -> unit; +- it_type_expr: type_iterators -> type_expr -> unit; +- it_path: Path.t -> unit; } +- + let iter_type_expr_cstr_args f = function + | Cstr_tuple tl -> List.iter f tl + | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls +@@ -344,8 +364,44 @@ + | Type_open -> + () + ++ (**********************************) ++ (* Utilities for marking *) ++ (**********************************) ++ ++let rec mark_type mark ty = ++ if try_mark_node mark ty then iter_type_expr (mark_type mark) ty ++ ++let mark_type_params mark ty = ++ iter_type_expr (mark_type mark) ty ++ ++ (**********************************) ++ (* (Object-oriented) iterator *) ++ (**********************************) ++ ++type 'a type_iterators = ++ { it_signature: 'a type_iterators -> signature -> unit; ++ it_signature_item: 'a type_iterators -> signature_item -> unit; ++ it_value_description: 'a type_iterators -> value_description -> unit; ++ it_type_declaration: 'a type_iterators -> type_declaration -> unit; ++ it_extension_constructor: ++ 'a type_iterators -> extension_constructor -> unit; ++ it_module_declaration: 'a type_iterators -> module_declaration -> unit; ++ it_modtype_declaration: 'a type_iterators -> modtype_declaration -> unit; ++ it_class_declaration: 'a type_iterators -> class_declaration -> unit; ++ it_class_type_declaration: ++ 'a type_iterators -> class_type_declaration -> unit; ++ it_functor_param: 'a type_iterators -> functor_parameter -> unit; ++ it_module_type: 'a type_iterators -> module_type -> unit; ++ it_class_type: 'a type_iterators -> class_type -> unit; ++ it_type_kind: 'a type_iterators -> type_decl_kind -> unit; ++ it_do_type_expr: 'a type_iterators -> 'a; ++ it_type_expr: 'a type_iterators -> type_expr -> unit; ++ it_path: Path.t -> unit; } + +-let type_iterators = ++type type_iterators_full = (type_expr -> unit) type_iterators ++type type_iterators_without_type_expr = (unit -> unit) type_iterators ++ ++let type_iterators_without_type_expr = + let it_signature it = + List.iter (it.it_signature_item it) + and it_signature_item it = function +@@ -405,6 +461,17 @@ + it.it_class_type it cty + and it_type_kind it kind = + iter_type_expr_kind (it.it_type_expr it) kind ++ and it_path _p = () ++ in ++ { it_path; it_type_expr = (fun _ _ -> ()); it_do_type_expr = (fun _ _ -> ()); ++ it_type_kind; it_class_type; it_functor_param; it_module_type; ++ it_signature; it_class_type_declaration; it_class_declaration; ++ it_modtype_declaration; it_module_declaration; it_extension_constructor; ++ it_type_declaration; it_value_description; it_signature_item; } ++ ++let type_iterators mark = ++ let it_type_expr it ty = ++ if try_mark_node mark ty then it.it_do_type_expr it ty + and it_do_type_expr it ty = + iter_type_expr (it.it_type_expr it) ty; + match get_desc ty with +@@ -415,13 +482,12 @@ + | Tvariant row -> + Option.iter (fun (p,_) -> it.it_path p) (row_name row) + | _ -> () +- and it_path _p = () + in +- { it_path; it_type_expr = it_do_type_expr; it_do_type_expr; +- it_type_kind; it_class_type; it_functor_param; it_module_type; +- it_signature; it_class_type_declaration; it_class_declaration; +- it_modtype_declaration; it_module_declaration; it_extension_constructor; +- it_type_declaration; it_value_description; it_signature_item; } ++ {type_iterators_without_type_expr with it_type_expr; it_do_type_expr} ++ ++ (**********************************) ++ (* Utilities for copying *) ++ (**********************************) + + let copy_row f fixed row keep more = + let Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} = +@@ -467,8 +533,7 @@ + Tpoly (f ty, tyl) + | Tpackage (p, fl) -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl) + +-(* Utilities for copying *) +- ++(* TODO: rename to [module Copy_scope] *) + module For_copy : sig + type copy_scope + +@@ -711,66 +776,10 @@ + | (_, _, ty) -> ty + | exception Not_found -> assert false + +- (**********************************) +- (* Utilities for level-marking *) +- (**********************************) +- +-let not_marked_node ty = get_level ty >= lowest_level +- (* type nodes with negative levels are "marked" *) +- +-let flip_mark_node ty = +- let ty = Transient_expr.repr ty in +- Transient_expr.set_level ty (pivot_level - ty.level) +-let logged_mark_node ty = +- set_level ty (pivot_level - get_level ty) +- +-let try_mark_node ty = not_marked_node ty && (flip_mark_node ty; true) +-let try_logged_mark_node ty = not_marked_node ty && (logged_mark_node ty; true) +- +-let rec mark_type ty = +- if not_marked_node ty then begin +- flip_mark_node ty; +- iter_type_expr mark_type ty +- end +- +-let mark_type_params ty = +- iter_type_expr mark_type ty +- +-let type_iterators = +- let it_type_expr it ty = +- if try_mark_node ty then it.it_do_type_expr it ty +- in +- {type_iterators with it_type_expr} +- +- +-(* Remove marks from a type. *) +-let rec unmark_type ty = +- if get_level ty < lowest_level then begin +- (* flip back the marked level *) +- flip_mark_node ty; +- iter_type_expr unmark_type ty +- end +- +-let unmark_iterators = +- let it_type_expr _it ty = unmark_type ty in +- {type_iterators with it_type_expr} +- +-let unmark_type_decl decl = +- unmark_iterators.it_type_declaration unmark_iterators decl +- +-let unmark_extension_constructor ext = +- List.iter unmark_type ext.ext_type_params; +- iter_type_expr_cstr_args unmark_type ext.ext_args; +- Option.iter unmark_type ext.ext_ret_type +- +-let unmark_class_signature sign = +- unmark_type sign.csig_self; +- unmark_type sign.csig_self_row; +- Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars; +- Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths + +-let unmark_class_type cty = +- unmark_iterators.it_class_type unmark_iterators cty ++ (**********) ++ (* Misc *) ++ (**********) + + (**** Type information getter ****) + diff --git a/upstream/patches_503/typing/btype.mli.patch b/upstream/patches_503/typing/btype.mli.patch new file mode 100644 index 000000000..852f08db2 --- /dev/null +++ b/upstream/patches_503/typing/btype.mli.patch @@ -0,0 +1,170 @@ +--- ocaml_502/typing/btype.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/typing/btype.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -58,6 +58,22 @@ + (**** Levels ****) + + val generic_level: int ++ (* level of polymorphic variables; = Ident.highest_scope *) ++val lowest_level: int ++ (* lowest level for type nodes; = Ident.lowest_scope *) ++ ++val with_new_pool: level:int -> (unit -> 'a) -> 'a * transient_expr list ++ (* [with_new_pool ~level f] executes [f] and returns the nodes ++ that were created at level [level] and above *) ++val add_to_pool: level:int -> transient_expr -> unit ++ (* Add a type node to the pool associated to the level (which should ++ be the level of the type node). ++ Do nothing if [level = generic_level] or [level = lowest_level]. *) ++ ++val newty3: level:int -> scope:int -> type_desc -> type_expr ++ (* Create a type with a fresh id *) ++val newty2: level:int -> type_desc -> type_expr ++ (* Create a type with a fresh id and no scope *) + + val newgenty: type_desc -> type_expr + (* Create a generic type *) +@@ -67,21 +83,16 @@ + (* Return a fresh generic node, to be instantiated + by [Transient_expr.set_stub_desc] *) + +-(* Use Tsubst instead +-val newmarkedvar: int -> type_expr +- (* Return a fresh marked variable *) +-val newmarkedgenvar: unit -> type_expr +- (* Return a fresh marked generic variable *) +-*) +- + (**** Types ****) + + val is_Tvar: type_expr -> bool + val is_Tunivar: type_expr -> bool + val is_Tconstr: type_expr -> bool ++val is_poly_Tpoly: type_expr -> bool + val dummy_method: label + val type_kind_is_abstract: type_declaration -> bool +-val type_origin : type_declaration -> type_origin ++val type_origin: type_declaration -> type_origin ++val label_is_poly: label_description -> bool + + (**** polymorphic variants ****) + +@@ -136,29 +147,47 @@ + val map_type_expr_cstr_args: (type_expr -> type_expr) -> + (constructor_arguments -> constructor_arguments) + ++(**** Utilities for type marking ****) ++ ++val mark_type: type_mark -> type_expr -> unit ++ (* Mark a type recursively *) ++val mark_type_params: type_mark -> type_expr -> unit ++ (* Mark the sons of a type node recursively *) ++ ++(**** (Object-oriented) iterator ****) + +-type type_iterators = +- { it_signature: type_iterators -> signature -> unit; +- it_signature_item: type_iterators -> signature_item -> unit; +- it_value_description: type_iterators -> value_description -> unit; +- it_type_declaration: type_iterators -> type_declaration -> unit; +- it_extension_constructor: type_iterators -> extension_constructor -> unit; +- it_module_declaration: type_iterators -> module_declaration -> unit; +- it_modtype_declaration: type_iterators -> modtype_declaration -> unit; +- it_class_declaration: type_iterators -> class_declaration -> unit; +- it_class_type_declaration: type_iterators -> class_type_declaration -> unit; +- it_functor_param: type_iterators -> functor_parameter -> unit; +- it_module_type: type_iterators -> module_type -> unit; +- it_class_type: type_iterators -> class_type -> unit; +- it_type_kind: type_iterators -> type_decl_kind -> unit; +- it_do_type_expr: type_iterators -> type_expr -> unit; +- it_type_expr: type_iterators -> type_expr -> unit; ++type 'a type_iterators = ++ { it_signature: 'a type_iterators -> signature -> unit; ++ it_signature_item: 'a type_iterators -> signature_item -> unit; ++ it_value_description: 'a type_iterators -> value_description -> unit; ++ it_type_declaration: 'a type_iterators -> type_declaration -> unit; ++ it_extension_constructor: ++ 'a type_iterators -> extension_constructor -> unit; ++ it_module_declaration: 'a type_iterators -> module_declaration -> unit; ++ it_modtype_declaration: 'a type_iterators -> modtype_declaration -> unit; ++ it_class_declaration: 'a type_iterators -> class_declaration -> unit; ++ it_class_type_declaration: ++ 'a type_iterators -> class_type_declaration -> unit; ++ it_functor_param: 'a type_iterators -> functor_parameter -> unit; ++ it_module_type: 'a type_iterators -> module_type -> unit; ++ it_class_type: 'a type_iterators -> class_type -> unit; ++ it_type_kind: 'a type_iterators -> type_decl_kind -> unit; ++ it_do_type_expr: 'a type_iterators -> 'a; ++ it_type_expr: 'a type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; } +-val type_iterators: type_iterators +- (* Iteration on arbitrary type information. ++ ++type type_iterators_full = (type_expr -> unit) type_iterators ++type type_iterators_without_type_expr = (unit -> unit) type_iterators ++ ++val type_iterators: type_mark -> type_iterators_full ++ (* Iteration on arbitrary type information, including [type_expr]. + [it_type_expr] calls [mark_node] to avoid loops. *) +-val unmark_iterators: type_iterators +- (* Unmark any structure containing types. See [unmark_type] below. *) ++ ++val type_iterators_without_type_expr: type_iterators_without_type_expr ++ (* Iteration on arbitrary type information. ++ Cannot recurse on [type_expr]. *) ++ ++(**** Utilities for copying ****) + + val copy_type_desc: + ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc +@@ -184,41 +213,6 @@ + before returning its result. *) + end + +-val lowest_level: int +- (* Marked type: ty.level < lowest_level *) +- +-val not_marked_node: type_expr -> bool +- (* Return true if a type node is not yet marked *) +- +-val logged_mark_node: type_expr -> unit +- (* Mark a type node, logging the marking so it can be backtracked *) +-val try_logged_mark_node: type_expr -> bool +- (* Mark a type node if it is not yet marked, logging the marking so it +- can be backtracked. +- Return false if it was already marked *) +- +-val flip_mark_node: type_expr -> unit +- (* Mark a type node. +- The marking is not logged and will have to be manually undone using +- one of the various [unmark]'ing functions below. *) +-val try_mark_node: type_expr -> bool +- (* Mark a type node if it is not yet marked. +- The marking is not logged and will have to be manually undone using +- one of the various [unmark]'ing functions below. +- +- Return false if it was already marked *) +-val mark_type: type_expr -> unit +- (* Mark a type recursively *) +-val mark_type_params: type_expr -> unit +- (* Mark the sons of a type node recursively *) +- +-val unmark_type: type_expr -> unit +-val unmark_type_decl: type_declaration -> unit +-val unmark_extension_constructor: extension_constructor -> unit +-val unmark_class_type: class_type -> unit +-val unmark_class_signature: class_signature -> unit +- (* Remove marks from a type *) +- + (**** Memorization of abbreviation expansion ****) + + val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option +@@ -312,9 +306,6 @@ + @raises [Assert_failure] if the class has no such method. *) + val instance_variable_type : label -> class_signature -> type_expr + +-(**** Forward declarations ****) +-val print_raw: (Format.formatter -> type_expr -> unit) ref +- + (**** Type information getter ****) + + val cstr_type_path : constructor_description -> Path.t diff --git a/upstream/patches_503/typing/cmt2annot.ml.patch b/upstream/patches_503/typing/cmt2annot.ml.patch new file mode 100644 index 000000000..eb6dee609 --- /dev/null +++ b/upstream/patches_503/typing/cmt2annot.ml.patch @@ -0,0 +1,19 @@ +--- ocaml_502/typing/cmt2annot.ml 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/typing/cmt2annot.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -100,10 +100,12 @@ + bind_bindings exp.exp_loc bindings + | Texp_let (Nonrecursive, bindings, body) -> + bind_bindings body.exp_loc bindings +- | Texp_match (_, f1, _) -> +- bind_cases f1 +- | Texp_try (_, f) -> +- bind_cases f ++ | Texp_match (_, f1, f2, _) -> ++ bind_cases f1; ++ bind_cases f2 ++ | Texp_try (_, f1, f2) -> ++ bind_cases f1; ++ bind_cases f2 + | Texp_function (params, _) -> + List.iter (bind_function_param exp.exp_loc) params + | Texp_letmodule (_, modname, _, _, body ) -> diff --git a/upstream/patches_503/typing/cmt2annot.mli.patch b/upstream/patches_503/typing/cmt2annot.mli.patch new file mode 100644 index 000000000..cf774a3f0 --- /dev/null +++ b/upstream/patches_503/typing/cmt2annot.mli.patch @@ -0,0 +1,10 @@ +--- ocaml_502/typing/cmt2annot.mli 2024-06-27 15:42:08.724127244 +0200 ++++ ocaml_503/typing/cmt2annot.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -20,3 +20,7 @@ + sourcefile:string option -> + use_summaries:bool -> Cmt_format.binary_annots -> + unit ++ ++val iterator : scope:Location.t -> bool -> Tast_iterator.iterator ++ ++val binary_part : Tast_iterator.iterator -> Cmt_format.binary_part -> unit diff --git a/upstream/patches_503/typing/ctype.ml.patch b/upstream/patches_503/typing/ctype.ml.patch new file mode 100644 index 000000000..81043853c --- /dev/null +++ b/upstream/patches_503/typing/ctype.ml.patch @@ -0,0 +1,1524 @@ +--- ocaml_502/typing/ctype.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/ctype.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -24,16 +24,6 @@ + open Local_store + + (* +- Type manipulation after type inference +- ====================================== +- If one wants to manipulate a type after type inference (for +- instance, during code generation or in the debugger), one must +- first make sure that the type levels are correct, using the +- function [correct_levels]. Then, this type can be correctly +- manipulated by [apply], [expand_head] and [moregeneral]. +-*) +- +-(* + General notes + ============= + - As much sharing as possible should be kept : it makes types +@@ -119,10 +109,11 @@ + exception Tags of label * label + + let () = ++ let open Format_doc in + Location.register_error_of_exn + (function + | Tags (l, l') -> +- let pp_tag ppf s = Format.fprintf ppf "`%s" s in ++ let pp_tag ppf s = fprintf ppf "`%s" s in + let inline_tag = Misc.Style.as_inline_code pp_tag in + Some + Location. +@@ -146,6 +137,32 @@ + + exception Incompatible + ++(**** Control tracing of GADT instances *) ++ ++let trace_gadt_instances = ref false ++let check_trace_gadt_instances env = ++ not !trace_gadt_instances && Env.has_local_constraints env && ++ (trace_gadt_instances := true; cleanup_abbrev (); true) ++ ++let reset_trace_gadt_instances b = ++ if b then trace_gadt_instances := false ++ ++let wrap_trace_gadt_instances env f x = ++ let b = check_trace_gadt_instances env in ++ let y = f x in ++ reset_trace_gadt_instances b; ++ y ++ ++(**** Abbreviations without parameters ****) ++(* Shall reset after generalizing *) ++ ++let simple_abbrevs = ref Mnil ++ ++let proper_abbrevs tl abbrev = ++ if tl <> [] || !trace_gadt_instances || !Clflags.principal ++ then abbrev ++ else simple_abbrevs ++ + (**** Type level management ****) + + let current_level = s_ref 0 +@@ -169,10 +186,77 @@ + saved_level := List.tl !saved_level; + current_level := cl; nongen_level := nl + let create_scope () = +- init_def (!current_level + 1); +- !current_level ++ let level = !current_level + 1 in ++ init_def level; ++ level + + let wrap_end_def f = Misc.try_finally f ~always:end_def ++let wrap_end_def_new_pool f = ++ wrap_end_def (fun _ -> with_new_pool ~level:!current_level f) ++ ++(* [with_local_level_gen] handles both the scoping structure of levels ++ and automatic generalization through pools (cf. btype.ml) *) ++let with_local_level_gen ~begin_def ~structure ?before_generalize f = ++ begin_def (); ++ let level = !current_level in ++ let result, pool = wrap_end_def_new_pool f in ++ Option.iter (fun g -> g result) before_generalize; ++ simple_abbrevs := Mnil; ++ (* Nodes in [pool] were either created by the above call to [f], ++ or they were created before, generalized, and then added to ++ the pool by [update_level]. ++ In the latter case, their level was already kept for backtracking ++ by a call to [set_level] inside [update_level]. ++ Since backtracking can only go back to a snapshot taken before [f] was ++ called, this means that either they did not exists in that snapshot, ++ or that they original level is already stored, so that there is no need ++ to register levels for backtracking when we change them with ++ [Transient_expr.set_level] here *) ++ List.iter begin fun ty -> ++ (* Already generic nodes are not tracked *) ++ if ty.level = generic_level then () else ++ match ty.desc with ++ | Tvar _ when structure -> ++ (* In structure mode, we do do not generalize type variables, ++ so we need to lower their level, and move them to an outer pool. ++ The goal of this mode is to allow unsharing inner nodes ++ without introducing polymorphism *) ++ if ty.level >= level then Transient_expr.set_level ty !current_level; ++ add_to_pool ~level:ty.level ty ++ | Tlink _ -> () ++ (* If a node is no longer used as representative, no need ++ to track it anymore *) ++ | _ -> ++ if ty.level < level then ++ (* If a node was introduced locally, but its level was lowered ++ through unification, keeping that node as representative, ++ then we need to move it to an outer pool. *) ++ add_to_pool ~level:ty.level ty ++ else begin ++ (* Generalize all remaining nodes *) ++ Transient_expr.set_level ty generic_level; ++ if structure then match ty.desc with ++ Tconstr (_, _, abbrev) -> ++ (* In structure mode, we drop abbreviations, as the goal of ++ this mode is to reduce sharing *) ++ abbrev := Mnil ++ | _ -> () ++ end ++ end pool; ++ result ++ ++let with_local_level_generalize_structure f = ++ with_local_level_gen ~begin_def ~structure:true f ++let with_local_level_generalize ?before_generalize f = ++ with_local_level_gen ~begin_def ~structure:false ?before_generalize f ++let with_local_level_generalize_if cond ?before_generalize f = ++ if cond then with_local_level_generalize ?before_generalize f else f () ++let with_local_level_generalize_structure_if cond f = ++ if cond then with_local_level_generalize_structure f else f () ++let with_local_level_generalize_structure_if_principal f = ++ if !Clflags.principal then with_local_level_generalize_structure f else f () ++let with_local_level_generalize_for_class f = ++ with_local_level_gen ~begin_def:begin_class_def ~structure:false f + + let with_local_level ?post f = + begin_def (); +@@ -183,7 +267,7 @@ + if cond then with_local_level f ~post else f () + let with_local_level_iter f ~post = + begin_def (); +- let result, l = wrap_end_def f in ++ let (result, l) = wrap_end_def f in + List.iter post l; + result + let with_local_level_iter_if cond f ~post = +@@ -194,8 +278,7 @@ + with_local_level_iter_if !Clflags.principal f ~post + let with_level ~level f = + begin_def (); init_def level; +- let result = wrap_end_def f in +- result ++ wrap_end_def f + let with_level_if cond ~level f = + if cond then with_level ~level f else f () + +@@ -219,32 +302,6 @@ + let restore_global_level gl = + global_level := gl + +-(**** Control tracing of GADT instances *) +- +-let trace_gadt_instances = ref false +-let check_trace_gadt_instances env = +- not !trace_gadt_instances && Env.has_local_constraints env && +- (trace_gadt_instances := true; cleanup_abbrev (); true) +- +-let reset_trace_gadt_instances b = +- if b then trace_gadt_instances := false +- +-let wrap_trace_gadt_instances env f x = +- let b = check_trace_gadt_instances env in +- let y = f x in +- reset_trace_gadt_instances b; +- y +- +-(**** Abbreviations without parameters ****) +-(* Shall reset after generalizing *) +- +-let simple_abbrevs = ref Mnil +- +-let proper_abbrevs tl abbrev = +- if tl <> [] || !trace_gadt_instances || !Clflags.principal +- then abbrev +- else simple_abbrevs +- + (**** Some type creators ****) + + (* Re-export generic type creators *) +@@ -550,9 +607,9 @@ + [free_variables] below drops the type/row information + and only returns a [variable list]. + *) +-let free_vars ?env ty = ++let free_vars ?env mark ty = + let rec fv ~kind acc ty = +- if not (try_mark_node ty) then acc ++ if not (try_mark_node mark ty) then acc + else match get_desc ty, env with + | Tvar _, _ -> + (ty, kind) :: acc +@@ -581,26 +638,22 @@ + in fv ~kind:Type_variable [] ty + + let free_variables ?env ty = +- let tl = List.map fst (free_vars ?env ty) in +- unmark_type ty; +- tl ++ with_type_mark (fun mark -> List.map fst (free_vars ?env mark ty)) + +-let closed_type ty = +- match free_vars ty with ++let closed_type mark ty = ++ match free_vars mark ty with + [] -> () + | (v, real) :: _ -> raise (Non_closed (v, real)) + + let closed_parameterized_type params ty = +- List.iter mark_type params; +- let ok = +- try closed_type ty; true with Non_closed _ -> false in +- List.iter unmark_type params; +- unmark_type ty; +- ok ++ with_type_mark begin fun mark -> ++ List.iter (mark_type mark) params; ++ try closed_type mark ty; true with Non_closed _ -> false ++ end + + let closed_type_decl decl = +- try +- List.iter mark_type decl.type_params; ++ with_type_mark begin fun mark -> try ++ List.iter (mark_type mark) decl.type_params; + begin match decl.type_kind with + Type_abstract _ -> + () +@@ -611,36 +664,35 @@ + | Some _ -> () + | None -> + match cd_args with +- | Cstr_tuple l -> List.iter closed_type l +- | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l ++ | Cstr_tuple l -> List.iter (closed_type mark) l ++ | Cstr_record l -> ++ List.iter (fun l -> closed_type mark l.ld_type) l + ) + v + | Type_record(r, _rep) -> +- List.iter (fun l -> closed_type l.ld_type) r ++ List.iter (fun l -> closed_type mark l.ld_type) r + | Type_open -> () + end; + begin match decl.type_manifest with + None -> () +- | Some ty -> closed_type ty ++ | Some ty -> closed_type mark ty + end; +- unmark_type_decl decl; + None + with Non_closed (ty, _) -> +- unmark_type_decl decl; + Some ty ++ end + + let closed_extension_constructor ext = +- try +- List.iter mark_type ext.ext_type_params; ++ with_type_mark begin fun mark -> try ++ List.iter (mark_type mark) ext.ext_type_params; + begin match ext.ext_ret_type with + | Some _ -> () +- | None -> iter_type_expr_cstr_args closed_type ext.ext_args ++ | None -> iter_type_expr_cstr_args (closed_type mark) ext.ext_args + end; +- unmark_extension_constructor ext; + None + with Non_closed (ty, _) -> +- unmark_extension_constructor ext; + Some ty ++ end + + type closed_class_failure = { + free_variable: type_expr * variable_kind; +@@ -650,13 +702,14 @@ + exception CCFailure of closed_class_failure + + let closed_class params sign = +- List.iter mark_type params; +- ignore (try_mark_node sign.csig_self_row); ++ with_type_mark begin fun mark -> ++ List.iter (mark_type mark) params; ++ ignore (try_mark_node mark sign.csig_self_row); + try + Meths.iter + (fun lab (priv, _, ty) -> + if priv = Mpublic then begin +- try closed_type ty with Non_closed (ty0, variable_kind) -> ++ try closed_type mark ty with Non_closed (ty0, variable_kind) -> + raise (CCFailure { + free_variable = (ty0, variable_kind); + meth = lab; +@@ -664,14 +717,10 @@ + }) + end) + sign.csig_meths; +- List.iter unmark_type params; +- unmark_class_signature sign; + None + with CCFailure reason -> +- List.iter unmark_type params; +- unmark_class_signature sign; + Some reason +- ++ end + + (**********************) + (* Type duplication *) +@@ -691,76 +740,53 @@ + (* Type level manipulation *) + (*****************************) + +-(* +- It would be a bit more efficient to remove abbreviation expansions +- rather than generalizing them: these expansions will usually not be +- used anymore. However, this is not possible in the general case, as +- [expand_abbrev] (via [subst]) requires these expansions to be +- preserved. Does it worth duplicating this code ? +-*) +-let rec generalize ty = +- let level = get_level ty in +- if (level > !current_level) && (level <> generic_level) then begin +- set_level ty generic_level; +- (* recur into abbrev for the speed *) +- begin match get_desc ty with +- Tconstr (_, _, abbrev) -> +- iter_abbrev generalize !abbrev +- | _ -> () +- end; +- iter_type_expr generalize ty +- end +- +-let generalize ty = +- simple_abbrevs := Mnil; +- generalize ty +- +-(* Generalize the structure and lower the variables *) +- +-let rec generalize_structure ty = +- let level = get_level ty in +- if level <> generic_level then begin +- if is_Tvar ty && level > !current_level then +- set_level ty !current_level +- else if level > !current_level then begin +- begin match get_desc ty with +- Tconstr (_, _, abbrev) -> +- abbrev := Mnil +- | _ -> () +- end; +- set_level ty generic_level; +- iter_type_expr generalize_structure ty +- end +- end +- +-let generalize_structure ty = +- simple_abbrevs := Mnil; +- generalize_structure ty + +-(* Generalize the spine of a function, if the level >= !current_level *) ++(* ++ Build a copy of a type in which nodes reachable through a path composed ++ only of Tarrow, Tpoly, Ttuple, Tpackage and Tconstr, and whose level ++ was no lower than [!current_level], are at [generic_level]. ++ This is different from [with_local_level_gen], which generalizes in place, ++ and only nodes with a level higher than [!current_level]. ++ This is used for typing classes, to indicate which types have been ++ inferred in the first pass, and can be considered as "known" during the ++ second pass. ++ *) + +-let rec generalize_spine ty = +- let level = get_level ty in +- if level < !current_level || level = generic_level then () else ++let rec copy_spine copy_scope ty = + match get_desc ty with +- Tarrow (_, ty1, ty2, _) -> +- set_level ty generic_level; +- generalize_spine ty1; +- generalize_spine ty2; +- | Tpoly (ty', _) -> +- set_level ty generic_level; +- generalize_spine ty' +- | Ttuple tyl -> +- set_level ty generic_level; +- List.iter generalize_spine tyl +- | Tpackage (_, fl) -> +- set_level ty generic_level; +- List.iter (fun (_n, ty) -> generalize_spine ty) fl +- | Tconstr (_, tyl, memo) -> +- set_level ty generic_level; +- memo := Mnil; +- List.iter generalize_spine tyl +- | _ -> () ++ | Tsubst (ty, _) -> ty ++ | Tvar _ ++ | Tfield _ ++ | Tnil ++ | Tvariant _ ++ | Tobject _ ++ | Tlink _ ++ | Tunivar _ -> ty ++ | (Tarrow _ | Tpoly _ | Ttuple _ | Tpackage _ | Tconstr _) as desc -> ++ let level = get_level ty in ++ if level < !current_level || level = generic_level then ty else ++ let t = newgenstub ~scope:(get_scope ty) in ++ For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); ++ let copy_rec = copy_spine copy_scope in ++ let desc' = match desc with ++ | Tarrow (lbl, ty1, ty2, _) -> ++ Tarrow (lbl, copy_rec ty1, copy_rec ty2, commu_ok) ++ | Tpoly (ty', tvl) -> ++ Tpoly (copy_rec ty', tvl) ++ | Ttuple tyl -> ++ Ttuple (List.map copy_rec tyl) ++ | Tpackage (path, fl) -> ++ let fl = List.map (fun (n, ty) -> n, copy_rec ty) fl in ++ Tpackage (path, fl) ++ | Tconstr (path, tyl, _) -> ++ Tconstr (path, List.map copy_rec tyl, ref Mnil) ++ | _ -> assert false ++ in ++ Transient_expr.set_stub_desc t desc'; ++ t ++ ++let copy_spine ty = ++ For_copy.with_scope (fun copy_scope -> copy_spine copy_scope ty) + + let forward_try_expand_safe = (* Forward declaration *) + ref (fun _env _ty -> assert false) +@@ -786,35 +812,35 @@ + normalize_package_path env (Path.Pdot (p1', s)) + | _ -> p + +-let rec check_scope_escape env level ty = ++let rec check_scope_escape mark env level ty = + let orig_level = get_level ty in +- if try_logged_mark_node ty then begin ++ if try_mark_node mark ty then begin + if level < get_scope ty then + raise_scope_escape_exn ty; + begin match get_desc ty with + | Tconstr (p, _, _) when level < Path.scope p -> + begin match !forward_try_expand_safe env ty with + | ty' -> +- check_scope_escape env level ty' ++ check_scope_escape mark env level ty' + | exception Cannot_expand -> + raise_escape_exn (Constructor p) + end + | Tpackage (p, fl) when level < Path.scope p -> + let p' = normalize_package_path env p in + if Path.same p p' then raise_escape_exn (Module_type p); +- check_scope_escape env level ++ check_scope_escape mark env level + (newty2 ~level:orig_level (Tpackage (p', fl))) + | _ -> +- iter_type_expr (check_scope_escape env level) ty ++ iter_type_expr (check_scope_escape mark env level) ty + end; + end + + let check_scope_escape env level ty = +- let snap = snapshot () in +- try check_scope_escape env level ty; backtrack snap ++ with_type_mark begin fun mark -> try ++ check_scope_escape mark env level ty + with Escape e -> +- backtrack snap; + raise (Escape { e with context = Some ty }) ++ end + + let rec update_scope scope ty = + if get_scope ty < scope then begin +@@ -838,8 +864,14 @@ + *) + + let rec update_level env level expand ty = +- if get_level ty > level then begin ++ let ty_level = get_level ty in ++ if ty_level > level then begin + if level < get_scope ty then raise_scope_escape_exn ty; ++ let set_level () = ++ set_level ty level; ++ if ty_level = generic_level then ++ add_to_pool ~level (Transient_expr.repr ty) ++ in + match get_desc ty with + Tconstr(p, _tl, _abbrev) when level < Path.scope p -> + (* Try first to replace an abbreviation by its expansion. *) +@@ -866,7 +898,7 @@ + link_type ty ty'; + update_level env level expand ty' + with Cannot_expand -> +- set_level ty level; ++ set_level (); + iter_type_expr (update_level env level expand) ty + end + | Tpackage (p, fl) when level < Path.scope p -> +@@ -884,13 +916,13 @@ + set_type_desc ty (Tvariant (set_row_name row None)) + | _ -> () + end; +- set_level ty level; ++ set_level (); + iter_type_expr (update_level env level expand) ty + | Tfield(lab, _, ty1, _) + when lab = dummy_method && level < get_scope ty1 -> + raise_escape_exn Self + | _ -> +- set_level ty level; ++ set_level (); + (* XXX what about abbreviations in Tconstr ? *) + iter_type_expr (update_level env level expand) ty + end +@@ -969,11 +1001,11 @@ + simple_abbrevs := Mnil; + lower_contravariant env !nongen_level (Hashtbl.create 7) false ty + +-let rec generalize_class_type' gen = ++let rec generalize_class_type gen = + function + Cty_constr (_, params, cty) -> + List.iter gen params; +- generalize_class_type' gen cty ++ generalize_class_type gen cty + | Cty_signature csig -> + gen csig.csig_self; + gen csig.csig_self_row; +@@ -981,20 +1013,10 @@ + Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths + | Cty_arrow (_, ty, cty) -> + gen ty; +- generalize_class_type' gen cty +- +-let generalize_class_type cty = +- generalize_class_type' generalize cty +- +-let generalize_class_type_structure cty = +- generalize_class_type' generalize_structure cty +- +-(* Correct the levels of type [ty]. *) +-let correct_levels ty = +- duplicate_type ty ++ generalize_class_type gen cty + + (* Only generalize the type ty0 in ty *) +-let limited_generalize ty0 ty = ++let limited_generalize ty0 ~inside:ty = + let graph = TypeHash.create 17 in + let roots = ref [] in + +@@ -1034,8 +1056,8 @@ + if get_level ty <> generic_level then set_level ty !current_level) + graph + +-let limited_generalize_class_type rv cty = +- generalize_class_type' (limited_generalize rv) cty ++let limited_generalize_class_type rv ~inside:cty = ++ generalize_class_type (fun inside -> limited_generalize rv ~inside) cty + + (* Compute statically the free univars of all nodes in a type *) + (* This avoids doing it repeatedly during instantiation *) +@@ -1078,15 +1100,14 @@ + + + let fully_generic ty = +- let rec aux ty = +- if not_marked_node ty then +- if get_level ty = generic_level then +- (flip_mark_node ty; iter_type_expr aux ty) +- else raise Exit +- in +- let res = try aux ty; true with Exit -> false in +- unmark_type ty; +- res ++ with_type_mark begin fun mark -> ++ let rec aux ty = ++ if try_mark_node mark ty then ++ if get_level ty = generic_level then iter_type_expr aux ty ++ else raise Exit ++ in ++ try aux ty; true with Exit -> false ++ end + + + (*******************) +@@ -1243,11 +1264,7 @@ + copy ?partial copy_scope sch) + + let generic_instance sch = +- let old = !current_level in +- current_level := generic_level; +- let ty = instance sch in +- current_level := old; +- ty ++ with_level ~level:generic_level (fun () -> instance sch) + + let instance_list schl = + For_copy.with_scope (fun copy_scope -> +@@ -1288,7 +1305,7 @@ + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; +- type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + + let existential_name name_counter ty = +@@ -1370,11 +1387,7 @@ + ) + + let generic_instance_declaration decl = +- let old = !current_level in +- current_level := generic_level; +- let decl = instance_declaration decl in +- current_level := old; +- decl ++ with_level ~level:generic_level (fun () -> instance_declaration decl) + + let instance_class params cty = + let rec copy_class_type copy_scope = function +@@ -1515,33 +1528,31 @@ + + let subst env level priv abbrev oty params args body = + if List.length params <> List.length args then raise Cannot_subst; +- let old_level = !current_level in +- current_level := level; +- let body0 = newvar () in (* Stub *) +- let undo_abbrev = +- match oty with +- | None -> fun () -> () (* No abbreviation added *) +- | Some ty -> +- match get_desc ty with +- Tconstr (path, tl, _) -> +- let abbrev = proper_abbrevs tl abbrev in +- memorize_abbrev abbrev priv path ty body0; +- fun () -> forget_abbrev abbrev path +- | _ -> assert false +- in +- abbreviations := abbrev; +- let (params', body') = instance_parameterized_type params body in +- abbreviations := ref Mnil; +- let uenv = Expression {env; in_subst = true} in +- try +- !unify_var' uenv body0 body'; +- List.iter2 (!unify_var' uenv) params' args; +- current_level := old_level; +- body' +- with Unify _ -> +- current_level := old_level; +- undo_abbrev (); +- raise Cannot_subst ++ with_level ~level begin fun () -> ++ let body0 = newvar () in (* Stub *) ++ let undo_abbrev = ++ match oty with ++ | None -> fun () -> () (* No abbreviation added *) ++ | Some ty -> ++ match get_desc ty with ++ Tconstr (path, tl, _) -> ++ let abbrev = proper_abbrevs tl abbrev in ++ memorize_abbrev abbrev priv path ty body0; ++ fun () -> forget_abbrev abbrev path ++ | _ -> assert false ++ in ++ abbreviations := abbrev; ++ let (params', body') = instance_parameterized_type params body in ++ abbreviations := ref Mnil; ++ let uenv = Expression {env; in_subst = true} in ++ try ++ !unify_var' uenv body0 body'; ++ List.iter2 (!unify_var' uenv) params' args; ++ body' ++ with Unify _ -> ++ undo_abbrev (); ++ raise Cannot_subst ++ end + + (* + Default to generic level. Usually, only the shape of the type matters, not +@@ -1782,8 +1793,8 @@ + (* #10277: forget scopes when printing trace *) + with_level ~level:(get_level ty) begin fun () -> + (* The same as [expand_head], except in the failing case we return the +- *original* type, not [correct_levels ty].*) +- try try_expand_head try_expand_safe env (correct_levels ty) with ++ *original* type, not [duplicate_type ty].*) ++ try try_expand_head try_expand_safe env (duplicate_type ty) with + | Cannot_expand -> ty + end + else expand_head env ty +@@ -1935,6 +1946,17 @@ + (* Polymorphic Unification *) + (*****************************) + ++(* Polymorphic unification is hard in the presence of recursive types. A ++ correctness argument for the approach below can be made by reference to ++ "Numbering matters: first-order canonical forms for second-order recursive ++ types" (ICFP'04) by Gauthier & Pottier. That work describes putting numbers ++ on nodes; we do not do that here, but instead make a decision about whether ++ to abort or continue based on the comparison of the numbers if we calculated ++ them. A different approach would actually store the relevant numbers in the ++ [Tpoly] nodes. (The algorithm here actually pre-dates that paper, which was ++ developed independently. But reading and understanding the paper will help ++ guide intuition for reading this algorithm nonetheless.) *) ++ + (* Since we cannot duplicate universal variables, unification must + be done at meta-level, using bindings in univar_pairs *) + let rec unify_univar t1 t2 = function +@@ -1954,7 +1976,8 @@ + | _ -> + raise Cannot_unify_universal_variables + end +- | [] -> raise Cannot_unify_universal_variables ++ | [] -> ++ Misc.fatal_error "Ctype.unify_univar: univar not in scope" + + (* The same as [unify_univar], but raises the appropriate exception instead of + [Cannot_unify_universal_variables] *) +@@ -1967,10 +1990,11 @@ + (* If [inj_only=true], only check injective positions *) + let occur_univar ?(inj_only=false) env ty = + let visited = ref TypeMap.empty in ++ with_type_mark begin fun mark -> + let rec occur_rec bound ty = +- if not_marked_node ty then ++ if not_marked_node mark ty then + if TypeSet.is_empty bound then +- (flip_mark_node ty; occur_desc bound ty) ++ (ignore (try_mark_node mark ty); occur_desc bound ty) + else try + let bound' = TypeMap.find ty !visited in + if not (TypeSet.subset bound' bound) then begin +@@ -2009,10 +2033,8 @@ + end + | _ -> iter_type_expr (occur_rec bound) ty + in +- Misc.try_finally (fun () -> +- occur_rec TypeSet.empty ty +- ) +- ~always:(fun () -> unmark_type ty) ++ occur_rec TypeSet.empty ty ++ end + + let has_free_univars env ty = + try occur_univar ~inj_only:false env ty; false with Escape _ -> true +@@ -2043,10 +2065,9 @@ + (* Whether a family of univars escapes from a type *) + let univars_escape env univar_pairs vl ty = + let family = get_univar_family univar_pairs vl in +- let visited = ref TypeSet.empty in ++ with_type_mark begin fun mark -> + let rec occur t = +- if TypeSet.mem t !visited then () else begin +- visited := TypeSet.add t !visited; ++ if try_mark_node mark t then begin + match get_desc t with + Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem t family) tl then () +@@ -2068,9 +2089,18 @@ + end + in + occur ty ++ end ++ ++let univar_pairs = ref [] ++ ++let with_univar_pairs pairs f = ++ let old = !univar_pairs in ++ univar_pairs := pairs; ++ Misc.try_finally f ++ ~always:(fun () -> univar_pairs := old) + + (* Wrapper checking that no variable escapes and updating univar_pairs *) +-let enter_poly env univar_pairs t1 tl1 t2 tl2 f = ++let enter_poly env t1 tl1 t2 tl2 f = + let old_univars = !univar_pairs in + let known_univars = + List.fold_left (fun s (cl,_) -> add_univars s cl) +@@ -2082,17 +2112,15 @@ + univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1))); + let cl1 = List.map (fun t -> t, ref None) tl1 + and cl2 = List.map (fun t -> t, ref None) tl2 in +- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; +- Misc.try_finally (fun () -> f t1 t2) +- ~always:(fun () -> univar_pairs := old_univars) ++ with_univar_pairs ++ ((cl1,cl2) :: (cl2,cl1) :: old_univars) ++ (fun () -> f t1 t2) + +-let enter_poly_for tr_exn env univar_pairs t1 tl1 t2 tl2 f = ++let enter_poly_for tr_exn env t1 tl1 t2 tl2 f = + try +- enter_poly env univar_pairs t1 tl1 t2 tl2 f ++ enter_poly env t1 tl1 t2 tl2 f + with Escape e -> raise_for tr_exn (Escape e) + +-let univar_pairs = ref [] +- + (**** Instantiate a generic type into a poly type ***) + + let polyfy env ty vars = +@@ -2179,16 +2207,18 @@ + + (* Return whether [t0] occurs in [ty]. Objects are also traversed. *) + let deep_occur t0 ty = ++ with_type_mark begin fun mark -> + let rec occur_rec ty = +- if get_level ty >= get_level t0 && try_mark_node ty then begin ++ if get_level ty >= get_level t0 && try_mark_node mark ty then begin + if eq_type ty t0 then raise Occur; + iter_type_expr occur_rec ty + end + in + try +- occur_rec ty; unmark_type ty; false ++ occur_rec ty; false + with Occur -> +- unmark_type ty; true ++ true ++ end + + + (* A local constraint can be added only if the rhs +@@ -2273,6 +2303,21 @@ + Path.same p1 path_bytes && Path.same p2 path_string || + Path.same p1 path_string && Path.same p2 path_bytes + ++(* Two labels are considered compatible under certain conditions. ++ - they are the same ++ - in classic mode, only optional labels are relavant ++ - in pattern mode, we act as if we were in classic mode. If not, interactions ++ with GADTs from files compiled in classic mode would be unsound. ++*) ++let compatible_labels ~in_pattern_mode l1 l2 = ++ l1 = l2 ++ || (!Clflags.classic || in_pattern_mode) ++ && not (is_optional l1 || is_optional l2) ++ ++let eq_labels error_mode ~in_pattern_mode l1 l2 = ++ if not (compatible_labels ~in_pattern_mode l1 l2) then ++ raise_for error_mode (Function_label_mismatch {got=l1; expected=l2}) ++ + (* Check for datatypes carefully; see PR#6348 *) + let rec expands_to_datatype env ty = + match get_desc ty with +@@ -2317,7 +2362,7 @@ + | (_, Tvar _) -> + () + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) +- when l1 = l2 || not (is_optional l1 || is_optional l2) -> ++ when compatible_labels ~in_pattern_mode:true l1 l2 -> + mcomp type_pairs env t1 t2; + mcomp type_pairs env u1 u2; + | (Ttuple tl1, Ttuple tl2) -> +@@ -2352,7 +2397,7 @@ + mcomp type_pairs env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + (try +- enter_poly env univar_pairs ++ enter_poly env + t1 tl1 t2 tl2 (mcomp type_pairs env) + with Escape _ -> raise Incompatible) + | (Tunivar _, Tunivar _) -> +@@ -2499,14 +2544,16 @@ + + let find_lowest_level ty = + let lowest = ref generic_level in +- let rec find ty = +- if not_marked_node ty then begin +- let level = get_level ty in +- if level < !lowest then lowest := level; +- flip_mark_node ty; +- iter_type_expr find ty +- end +- in find ty; unmark_type ty; !lowest ++ with_type_mark begin fun mark -> ++ let rec find ty = ++ if try_mark_node mark ty then begin ++ let level = get_level ty in ++ if level < !lowest then lowest := level; ++ iter_type_expr find ty ++ end ++ in find ty ++ end; ++ !lowest + + (* This function can be called only in [Pattern] mode. *) + let add_gadt_equation uenv source destination = +@@ -2553,11 +2600,7 @@ + let nondep_instance env level id ty = + let ty = !nondep_type' env [id] ty in + if level = generic_level then duplicate_type ty else +- let old = !current_level in +- current_level := level; +- let ty = instance ty in +- current_level := old; +- ty ++ with_level ~level (fun () -> instance ty) + + (* Find the type paths nl1 in the module type mty2, and add them to the + list (nl2, tl2). raise Not_found if impossible *) +@@ -2609,10 +2652,10 @@ + let ntl2 = complete_type_list env fl1 lv2 (Mty_ident p2) fl2 + and ntl1 = complete_type_list env fl2 lv1 (Mty_ident p1) fl1 in + unify_list (List.map snd ntl1) (List.map snd ntl2); +- if eq_package_path env p1 p2 +- || !package_subtype env p1 fl1 p2 fl2 +- && !package_subtype env p2 fl2 p1 fl1 then () else raise Not_found +- ++ if eq_package_path env p1 p2 then Ok () ++ else Result.bind ++ (!package_subtype env p1 fl1 p2 fl2) ++ (fun () -> !package_subtype env p2 fl2 p1 fl1) + + (* force unification in Reither when one side has a non-conjunctive type *) + (* Code smell: this could also be put in unification_environment. +@@ -2796,9 +2839,8 @@ + end; + try + begin match (d1, d2) with +- (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || +- (!Clflags.classic || in_pattern_mode uenv) && +- not (is_optional l1 || is_optional l2) -> ++ (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) -> ++ eq_labels Unify ~in_pattern_mode:(in_pattern_mode uenv) l1 l2; + unify uenv t1 t2; unify uenv u1 u2; + begin match is_commu_ok c1, is_commu_ok c2 with + | false, true -> set_commu_ok c1 +@@ -2911,13 +2953,19 @@ + | (Tpoly (t1, []), Tpoly (t2, [])) -> + unify uenv t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> +- enter_poly_for Unify (get_env uenv) univar_pairs t1 tl1 t2 tl2 ++ enter_poly_for Unify (get_env uenv) t1 tl1 t2 tl2 + (unify uenv) + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> +- begin try ++ begin match + unify_package (get_env uenv) (unify_list uenv) + (get_level t1) p1 fl1 (get_level t2) p2 fl2 +- with Not_found -> ++ with ++ | Ok () -> () ++ | Error fm_err -> ++ if not (in_pattern_mode uenv) then ++ raise_for Unify (Errortrace.First_class_module fm_err); ++ List.iter (fun (_n, ty) -> reify uenv ty) (fl1 @ fl2); ++ | exception Not_found -> + if not (in_pattern_mode uenv) then raise_unexplained_for Unify; + List.iter (fun (_n, ty) -> reify uenv ty) (fl1 @ fl2); + (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) +@@ -3231,7 +3279,6 @@ + raise (Unify (expand_to_unification_error (get_env uenv) trace)) + + let unify_gadt (penv : Pattern_env.t) ty1 ty2 = +- univar_pairs := []; + let equated_types = TypePairs.create 0 in + let equations_generation = Allowed { equated_types } in + let uenv = Pattern +@@ -3240,8 +3287,9 @@ + assume_injective = true; + unify_eq_set = TypePairs.create 11; } + in +- unify uenv ty1 ty2; +- equated_types ++ with_univar_pairs [] (fun () -> ++ unify uenv ty1 ty2; ++ equated_types) + + let unify_var uenv t1 t2 = + if eq_type t1 t2 then () else +@@ -3273,8 +3321,8 @@ + unify_var (Expression {env; in_subst = false}) ty1 ty2 + + let unify_pairs env ty1 ty2 pairs = +- univar_pairs := pairs; +- unify (Expression {env; in_subst = false}) ty1 ty2 ++ with_univar_pairs pairs (fun () -> ++ unify (Expression {env; in_subst = false}) ty1 ty2) + + let unify env ty1 ty2 = + unify_pairs env ty1 ty2 [] +@@ -3686,40 +3734,35 @@ + let self = expand_head env sign.csig_self in + close env (object_fields self) + +-let generalize_class_signature_spine env sign = ++let generalize_class_signature_spine sign = + (* Generalize the spine of methods *) +- let meths = sign.csig_meths in +- Meths.iter (fun _ (_, _, ty) -> generalize_spine ty) meths; +- let new_meths = +- Meths.map +- (fun (priv, virt, ty) -> (priv, virt, generic_instance ty)) +- meths +- in +- (* But keep levels correct on the type of self *) +- Meths.iter +- (fun _ (_, _, ty) -> unify_var env (newvar ()) ty) +- meths; +- sign.csig_meths <- new_meths ++ sign.csig_meths <- ++ Meths.map (fun (priv, virt, ty) -> priv, virt, copy_spine ty) ++ sign.csig_meths + + (***********************************) + (* Matching between type schemes *) + (***********************************) + ++(* Level of the subject, should be just below generic_level *) ++let subject_level = generic_level - 1 ++ + (* + Update the level of [ty]. First check that the levels of generic + variables from the subject are not lowered. + *) + let moregen_occur env level ty = +- let rec occur ty = +- let lv = get_level ty in +- if lv <= level then () else +- if is_Tvar ty && lv >= generic_level - 1 then raise Occur else +- if try_mark_node ty then iter_type_expr occur ty +- in +- begin try +- occur ty; unmark_type ty +- with Occur -> +- unmark_type ty; raise_unexplained_for Moregen ++ with_type_mark begin fun mark -> ++ let rec occur ty = ++ let lv = get_level ty in ++ if lv <= level then () else ++ if is_Tvar ty && lv >= subject_level then raise Occur else ++ if try_mark_node mark ty then iter_type_expr occur ty ++ in ++ try ++ occur ty ++ with Occur -> ++ raise_unexplained_for Moregen + end; + (* also check for free univars *) + occur_univar_for Moregen env ty; +@@ -3727,7 +3770,7 @@ + + let may_instantiate inst_nongen t1 = + let level = get_level t1 in +- if inst_nongen then level <> generic_level - 1 ++ if inst_nongen then level <> subject_level + else level = generic_level + + let rec moregen inst_nongen type_pairs env t1 t2 = +@@ -3754,8 +3797,8 @@ + moregen_occur env (get_level t1') t2; + update_scope_for Moregen (get_scope t1') t2; + link_type t1' t2 +- | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 +- || !Clflags.classic && not (is_optional l1 || is_optional l2) -> ++ | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) -> ++ eq_labels Moregen ~in_pattern_mode:false l1 l2; + moregen inst_nongen type_pairs env t1 t2; + moregen inst_nongen type_pairs env u1 u2 + | (Ttuple tl1, Ttuple tl2) -> +@@ -3764,10 +3807,13 @@ + when Path.same p1 p2 -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> +- begin try ++ begin match + unify_package env (moregen_list inst_nongen type_pairs env) + (get_level t1') p1 fl1 (get_level t2') p2 fl2 +- with Not_found -> raise_unexplained_for Moregen ++ with ++ | Ok () -> () ++ | Error fme -> raise_for Moregen (First_class_module fme) ++ | exception Not_found -> raise_unexplained_for Moregen + end + | (Tnil, Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> raise_for Moregen (Obj (Abstract_row First)) +@@ -3783,7 +3829,7 @@ + | (Tpoly (t1, []), Tpoly (t2, [])) -> + moregen inst_nongen type_pairs env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> +- enter_poly_for Moregen env univar_pairs t1 tl1 t2 tl2 ++ enter_poly_for Moregen env t1 tl1 t2 tl2 + (moregen inst_nongen type_pairs env) + | (Tunivar _, Tunivar _) -> + unify_univar_for Moregen t1' t2' !univar_pairs +@@ -3946,8 +3992,8 @@ + + (* Must empty univar_pairs first *) + let moregen inst_nongen type_pairs env patt subj = +- univar_pairs := []; +- moregen inst_nongen type_pairs env patt subj ++ with_univar_pairs [] (fun () -> ++ moregen inst_nongen type_pairs env patt subj) + + (* + Non-generic variable can be instantiated only if [inst_nongen] is +@@ -3958,37 +4004,37 @@ + is unimportant. So, no need to propagate abbreviations. + *) + let moregeneral env inst_nongen pat_sch subj_sch = +- let old_level = !current_level in +- current_level := generic_level - 1; +- (* +- Generic variables are first duplicated with [instance]. So, +- their levels are lowered to [generic_level - 1]. The subject is +- then copied with [duplicate_type]. That way, its levels won't be +- changed. +- *) +- let subj_inst = instance subj_sch in +- let subj = duplicate_type subj_inst in +- current_level := generic_level; +- (* Duplicate generic variables *) +- let patt = instance pat_sch in +- +- Misc.try_finally +- (fun () -> +- try +- moregen inst_nongen (TypePairs.create 13) env patt subj +- with Moregen_trace trace -> +- (* Moregen splits the generic level into two finer levels: +- [generic_level] and [generic_level - 1]. In order to properly +- detect and print weak variables when printing this error, we need to +- merge them back together, by regeneralizing the levels of the types +- after they were instantiated at [generic_level - 1] above. Because +- [moregen] does some unification that we need to preserve for more +- legible error messages, we have to manually perform the +- regeneralization rather than backtracking. *) +- current_level := generic_level - 2; +- generalize subj_inst; +- raise (Moregen (expand_to_moregen_error env trace))) +- ~always:(fun () -> current_level := old_level) ++ (* Moregen splits the generic level into two finer levels: ++ [generic_level] and [subject_level = generic_level - 1]. ++ In order to properly detect and print weak variables when ++ printing errors, we need to merge those levels back together. ++ We do that by starting at level [subject_level - 1], using ++ [with_local_level_generalize] to first set the current level ++ to [subject_level], and then generalize nodes at [subject_level] ++ on exit. ++ Strictly speaking, we could avoid generalizing when there is no error, ++ as nodes at level [subject_level] are never unified with nodes of ++ the original types, but that would be rather ad hoc. ++ *) ++ with_level ~level:(subject_level - 1) begin fun () -> ++ match with_local_level_generalize begin fun () -> ++ assert (!current_level = subject_level); ++ (* ++ Generic variables are first duplicated with [instance]. So, ++ their levels are lowered to [subject_level]. The subject is ++ then copied with [duplicate_type]. That way, its levels won't be ++ changed. ++ *) ++ let subj_inst = instance subj_sch in ++ let subj = duplicate_type subj_inst in ++ (* Duplicate generic variables *) ++ let patt = generic_instance pat_sch in ++ try Ok (moregen inst_nongen (TypePairs.create 13) env patt subj) ++ with Moregen_trace trace -> Error trace ++ end with ++ | Ok () -> () ++ | Error trace -> raise (Moregen (expand_to_moregen_error env trace)) ++ end + + let is_moregeneral env inst_nongen pat_sch subj_sch = + match moregeneral env inst_nongen pat_sch subj_sch with +@@ -3999,8 +4045,8 @@ + and check validity after unification *) + (* Simpler, no? *) + +-let rec rigidify_rec vars ty = +- if try_mark_node ty then ++let rec rigidify_rec mark vars ty = ++ if try_mark_node mark ty then + begin match get_desc ty with + | Tvar _ -> + if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars +@@ -4013,18 +4059,17 @@ + ~name ~closed + in link_type more (newty2 ~level:(get_level ty) (Tvariant row')) + end; +- iter_row (rigidify_rec vars) row; ++ iter_row (rigidify_rec mark vars) row; + (* only consider the row variable if the variant is not static *) + if not (static_row row) then +- rigidify_rec vars (row_more row) ++ rigidify_rec mark vars (row_more row) + | _ -> +- iter_type_expr (rigidify_rec vars) ty ++ iter_type_expr (rigidify_rec mark vars) ty + end + + let rigidify ty = + let vars = ref TypeSet.empty in +- rigidify_rec vars ty; +- unmark_type ty; ++ with_type_mark (fun mark -> rigidify_rec mark vars ty); + TypeSet.elements !vars + + let all_distinct_vars env vars = +@@ -4086,8 +4131,18 @@ + end + + let rec eqtype rename type_pairs subst env t1 t2 = +- if eq_type t1 t2 then () else ++ let check_phys_eq t1 t2 = ++ not rename && eq_type t1 t2 ++ in ++ (* Checking for physical equality of type representatives when [rename] is ++ true would be incorrect: imagine comparing ['a * 'a] with ['b * 'a]. The ++ first ['a] and ['b] would be identified in [eqtype_subst], and then the ++ second ['a] and ['a] would be [eq_type]. So we do not call [eq_type] here. + ++ On the other hand, when [rename] is false we need to check for physical ++ equality, as that's the only way variables can be identified. ++ *) ++ if check_phys_eq t1 t2 then () else + try + match (get_desc t1, get_desc t2) with + (Tvar _, Tvar _) when rename -> +@@ -4098,26 +4153,29 @@ + let t1' = expand_head_rigid env t1 in + let t2' = expand_head_rigid env t2 in + (* Expansion may have changed the representative of the types... *) +- if eq_type t1' t2' then () else ++ if check_phys_eq t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1' t2' +- | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 +- || !Clflags.classic && not (is_optional l1 || is_optional l2) -> ++ | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) -> ++ eq_labels Equality ~in_pattern_mode:false l1 l2; + eqtype rename type_pairs subst env t1 t2; +- eqtype rename type_pairs subst env u1 u2; ++ eqtype rename type_pairs subst env u1 u2 + | (Ttuple tl1, Ttuple tl2) -> + eqtype_list rename type_pairs subst env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) + when Path.same p1 p2 -> +- eqtype_list rename type_pairs subst env tl1 tl2 ++ eqtype_list_same_length rename type_pairs subst env tl1 tl2 + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> +- begin try ++ begin match + unify_package env (eqtype_list rename type_pairs subst env) + (get_level t1') p1 fl1 (get_level t2') p2 fl2 +- with Not_found -> raise_unexplained_for Equality ++ with ++ | Ok () -> () ++ | Error fme -> raise_for Equality (First_class_module fme) ++ | exception Not_found -> raise_unexplained_for Equality + end + | (Tnil, Tconstr _ ) -> + raise_for Equality (Obj (Abstract_row Second)) +@@ -4135,7 +4193,7 @@ + | (Tpoly (t1, []), Tpoly (t2, [])) -> + eqtype rename type_pairs subst env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> +- enter_poly_for Equality env univar_pairs t1 tl1 t2 tl2 ++ enter_poly_for Equality env t1 tl1 t2 tl2 + (eqtype rename type_pairs subst env) + | (Tunivar _, Tunivar _) -> + unify_univar_for Equality t1' t2' !univar_pairs +@@ -4145,17 +4203,22 @@ + with Equality_trace trace -> + raise_trace_for Equality (Diff {got = t1; expected = t2} :: trace) + ++and eqtype_list_same_length rename type_pairs subst env tl1 tl2 = ++ List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 ++ + and eqtype_list rename type_pairs subst env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise_unexplained_for Equality; +- List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 ++ eqtype_list_same_length rename type_pairs subst env tl1 tl2 + + and eqtype_fields rename type_pairs subst env ty1 ty2 = + let (fields1, rest1) = flatten_fields ty1 in + let (fields2, rest2) = flatten_fields ty2 in + (* First check if same row => already equal *) + let same_row = +- eq_type rest1 rest2 || TypePairs.mem type_pairs (rest1,rest2) ++ (* [not rename]: see comment at top of [eqtype] *) ++ (not rename && eq_type rest1 rest2) || ++ TypePairs.mem type_pairs (rest1,rest2) + in + if same_row then () else + (* Try expansion, needed when called from Includecore.type_manifest *) +@@ -4270,20 +4333,23 @@ + pairs + + (* Must empty univar_pairs first *) +-let eqtype_list rename type_pairs subst env tl1 tl2 = +- univar_pairs := []; +- let snap = Btype.snapshot () in +- Misc.try_finally +- ~always:(fun () -> backtrack snap) +- (fun () -> eqtype_list rename type_pairs subst env tl1 tl2) ++let eqtype_list_same_length rename type_pairs subst env tl1 tl2 = ++ with_univar_pairs [] (fun () -> ++ let snap = Btype.snapshot () in ++ Misc.try_finally ++ ~always:(fun () -> backtrack snap) ++ (fun () -> eqtype_list_same_length rename type_pairs subst env tl1 tl2)) + + let eqtype rename type_pairs subst env t1 t2 = +- eqtype_list rename type_pairs subst env [t1] [t2] ++ eqtype_list_same_length rename type_pairs subst env [t1] [t2] + + (* Two modes: with or without renaming of variables *) + let equal env rename tyl1 tyl2 = ++ if List.length tyl1 <> List.length tyl2 then ++ raise_unexplained_for Equality; ++ if List.for_all2 eq_type tyl1 tyl2 then () else + let subst = ref [] in +- try eqtype_list rename (TypePairs.create 11) subst env tyl1 tyl2 ++ try eqtype_list_same_length rename (TypePairs.create 11) subst env tyl1 tyl2 + with Equality_trace trace -> + raise (Equality (expand_to_equality_error env trace !subst)) + +@@ -4447,48 +4513,48 @@ + let errors = match_class_sig_shape ~strict:false sign1 sign2 in + match errors with + | [] -> +- let old_level = !current_level in +- current_level := generic_level - 1; +- (* +- Generic variables are first duplicated with [instance]. So, +- their levels are lowered to [generic_level - 1]. The subject is +- then copied with [duplicate_type]. That way, its levels won't be +- changed. +- *) +- let (_, subj_inst) = instance_class [] subj_sch in +- let subj = duplicate_class_type subj_inst in +- current_level := generic_level; +- (* Duplicate generic variables *) +- let (_, patt) = instance_class [] pat_sch in +- let type_pairs = TypePairs.create 53 in +- let sign1 = signature_of_class_type patt in +- let sign2 = signature_of_class_type subj in +- let self1 = sign1.csig_self in +- let self2 = sign2.csig_self in +- let row1 = sign1.csig_self_row in +- let row2 = sign2.csig_self_row in +- TypePairs.add type_pairs (self1, self2); +- (* Always succeeds *) +- moregen true type_pairs env row1 row2; +- let res = +- match moregen_clty trace type_pairs env patt subj with +- | () -> [] +- | exception Failure res -> +- (* We've found an error. Moregen splits the generic level into two +- finer levels: [generic_level] and [generic_level - 1]. In order +- to properly detect and print weak variables when printing this +- error, we need to merge them back together, by regeneralizing the +- levels of the types after they were instantiated at +- [generic_level - 1] above. Because [moregen] does some +- unification that we need to preserve for more legible error +- messages, we have to manually perform the regeneralization rather +- than backtracking. *) +- current_level := generic_level - 2; +- generalize_class_type subj_inst; +- res +- in +- current_level := old_level; +- res ++ (* Moregen splits the generic level into two finer levels: ++ [generic_level] and [subject_level = generic_level - 1]. ++ In order to properly detect and print weak variables when ++ printing errors, we need to merge those levels back together. ++ We do that by starting at level [subject_level - 1], using ++ [with_local_level_generalize] to first set the current level ++ to [subject_level], and then generalize nodes at [subject_level] ++ on exit. ++ Strictly speaking, we could avoid generalizing when there is no error, ++ as nodes at level [subject_level] are never unified with nodes of ++ the original types, but that would be rather ad hoc. ++ *) ++ with_level ~level:(subject_level - 1) begin fun () -> ++ with_local_level_generalize begin fun () -> ++ assert (!current_level = subject_level); ++ (* ++ Generic variables are first duplicated with [instance]. So, ++ their levels are lowered to [subject_level]. The subject is ++ then copied with [duplicate_type]. That way, its levels won't be ++ changed. ++ *) ++ let (_, subj_inst) = instance_class [] subj_sch in ++ let subj = duplicate_class_type subj_inst in ++ (* Duplicate generic variables *) ++ let (_, patt) = ++ with_level ~level:generic_level ++ (fun () -> instance_class [] pat_sch) in ++ let type_pairs = TypePairs.create 53 in ++ let sign1 = signature_of_class_type patt in ++ let sign2 = signature_of_class_type subj in ++ let self1 = sign1.csig_self in ++ let self2 = sign2.csig_self in ++ let row1 = sign1.csig_self_row in ++ let row2 = sign2.csig_self_row in ++ TypePairs.add type_pairs (self1, self2); ++ (* Always succeeds *) ++ moregen true type_pairs env row1 row2; ++ (* May fail *) ++ try moregen_clty trace type_pairs env patt subj; [] ++ with Failure res -> res ++ end ++ end + | errors -> + CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors + +@@ -4832,8 +4898,8 @@ + match (get_desc t1, get_desc t2) with + (Tvar _, _) | (_, Tvar _) -> + (trace, t1, t2, !univar_pairs)::cstrs +- | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2 +- || !Clflags.classic && not (is_optional l1 || is_optional l2) -> ++ | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) ++ when compatible_labels ~in_pattern_mode:false l1 l2 -> + let cstrs = + subtype_rec + env +@@ -4910,7 +4976,7 @@ + subtype_rec env trace u1' u2 cstrs + | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> + begin try +- enter_poly env univar_pairs u1 tl1 u2 tl2 ++ enter_poly env u1 tl1 u2 tl2 + (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) + with Escape _ -> + (trace, t1, t2, !univar_pairs)::cstrs +@@ -4932,7 +4998,7 @@ + (* need to check module subtyping *) + let snap = Btype.snapshot () in + match List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs' with +- | () when !package_subtype env p1 fl1 p2 fl2 -> ++ | () when Result.is_ok (!package_subtype env p1 fl1 p2 fl2) -> + Btype.backtrack snap; cstrs' @ cstrs + | () | exception Unify _ -> + Btype.backtrack snap; raise Not_found +@@ -5056,19 +5122,22 @@ + + let subtype env ty1 ty2 = + TypePairs.clear subtypes; +- univar_pairs := []; +- (* Build constraint set. *) +- let cstrs = +- subtype_rec env [Subtype.Diff {got = ty1; expected = ty2}] ty1 ty2 [] +- in +- TypePairs.clear subtypes; +- (* Enforce constraints. *) +- function () -> +- List.iter +- (function (trace0, t1, t2, pairs) -> +- try unify_pairs env t1 t2 pairs with Unify {trace} -> +- subtype_error ~env ~trace:trace0 ~unification_trace:(List.tl trace)) +- (List.rev cstrs) ++ with_univar_pairs [] (fun () -> ++ (* Build constraint set. *) ++ let cstrs = ++ subtype_rec env [Subtype.Diff {got = ty1; expected = ty2}] ty1 ty2 [] ++ in ++ TypePairs.clear subtypes; ++ (* Enforce constraints. *) ++ function () -> ++ List.iter ++ (function (trace0, t1, t2, pairs) -> ++ try unify_pairs env t1 t2 pairs with Unify {trace} -> ++ subtype_error ++ ~env ++ ~trace:trace0 ++ ~unification_trace:(List.tl trace)) ++ (List.rev cstrs)) + + (*******************) + (* Miscellaneous *) +@@ -5217,9 +5286,8 @@ + + (* Normalize a type before printing, saving... *) + (* Cannot use mark_type because deep_occur uses it too *) +-let rec normalize_type_rec visited ty = +- if not (TypeSet.mem ty !visited) then begin +- visited := TypeSet.add ty !visited; ++let rec normalize_type_rec mark ty = ++ if try_mark_node mark ty then begin + let tm = row_of_type ty in + begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then + match get_desc tm with (* PR#7348 *) +@@ -5278,11 +5346,11 @@ + set_type_desc fi (get_desc fi') + | _ -> () + end; +- iter_type_expr (normalize_type_rec visited) ty; ++ iter_type_expr (normalize_type_rec mark) ty; + end + + let normalize_type ty = +- normalize_type_rec (ref TypeSet.empty) ty ++ with_type_mark (fun mark -> normalize_type_rec mark ty) + + + (*************************) diff --git a/upstream/patches_503/typing/ctype.mli.patch b/upstream/patches_503/typing/ctype.mli.patch new file mode 100644 index 000000000..4765bff20 --- /dev/null +++ b/upstream/patches_503/typing/ctype.mli.patch @@ -0,0 +1,75 @@ +--- ocaml_502/typing/ctype.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/ctype.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -35,6 +35,15 @@ + + (* All the following wrapper functions revert to the original level, + even in case of exception. *) ++val with_local_level_generalize: ++ ?before_generalize:('a -> unit) -> (unit -> 'a) -> 'a ++val with_local_level_generalize_if: ++ bool -> ?before_generalize:('a -> unit) -> (unit -> 'a) -> 'a ++val with_local_level_generalize_structure: (unit -> 'a) -> 'a ++val with_local_level_generalize_structure_if: bool -> (unit -> 'a) -> 'a ++val with_local_level_generalize_structure_if_principal: (unit -> 'a) -> 'a ++val with_local_level_generalize_for_class: (unit -> 'a) -> 'a ++ + val with_local_level: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* [with_local_level (fun () -> cmd) ~post] evaluates [cmd] at a + raised level. +@@ -129,8 +138,6 @@ + val filter_row_fields: + bool -> (label * row_field) list -> (label * row_field) list + +-val generalize: type_expr -> unit +- (* Generalize in-place the given type *) + val lower_contravariant: Env.t -> type_expr -> unit + (* Lower level of type variables inside contravariant branches; + to be used before generalize for expansive expressions *) +@@ -138,23 +145,16 @@ + (* Lower all variables to the given level *) + val enforce_current_level: Env.t -> type_expr -> unit + (* Lower whole type to !current_level *) +-val generalize_structure: type_expr -> unit +- (* Generalize the structure of a type, lowering variables +- to !current_level *) +-val generalize_class_type : class_type -> unit +- (* Generalize the components of a class type *) +-val generalize_class_type_structure : class_type -> unit +- (* Generalize the structure of the components of a class type *) +-val generalize_class_signature_spine : Env.t -> class_signature -> unit ++val generalize_class_signature_spine: class_signature -> unit + (* Special function to generalize methods during inference *) +-val correct_levels: type_expr -> type_expr +- (* Returns a copy with decreasing levels *) +-val limited_generalize: type_expr -> type_expr -> unit ++val limited_generalize: type_expr -> inside:type_expr -> unit + (* Only generalize some part of the type + Make the remaining of the type non-generalizable *) +-val limited_generalize_class_type: type_expr -> class_type -> unit ++val limited_generalize_class_type: type_expr -> inside:class_type -> unit + (* Same, but for class types *) + ++val duplicate_type: type_expr -> type_expr ++ (* Returns a copy with non-variable nodes at generic level *) + val fully_generic: type_expr -> bool + + val check_scope_escape : Env.t -> int -> type_expr -> unit +@@ -261,6 +261,8 @@ + val extract_concrete_typedecl: + Env.t -> type_expr -> typedecl_extraction_result + ++val get_new_abstract_name : Env.t -> string -> string ++ + val unify: Env.t -> type_expr -> type_expr -> unit + (* Unify the two types given. Raise [Unify] if not possible. *) + val unify_gadt: +@@ -466,7 +468,8 @@ + (* Stubs *) + val package_subtype : + (Env.t -> Path.t -> (Longident.t * type_expr) list -> +- Path.t -> (Longident.t * type_expr) list -> bool) ref ++ Path.t -> (Longident.t * type_expr) list -> ++ (unit,Errortrace.first_class_module) Result.t) ref + + (* Raises [Incompatible] *) + val mcomp : Env.t -> type_expr -> type_expr -> unit diff --git a/upstream/patches_503/typing/datarepr.ml.patch b/upstream/patches_503/typing/datarepr.ml.patch new file mode 100644 index 000000000..23563e809 --- /dev/null +++ b/upstream/patches_503/typing/datarepr.ml.patch @@ -0,0 +1,46 @@ +--- ocaml_502/typing/datarepr.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/datarepr.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -23,24 +23,25 @@ + (* Simplified version of Ctype.free_vars *) + let free_vars ?(param=false) ty = + let ret = ref TypeSet.empty in +- let rec loop ty = +- if try_mark_node ty then +- match get_desc ty with +- | Tvar _ -> +- ret := TypeSet.add ty !ret +- | Tvariant row -> +- iter_row loop row; +- if not (static_row row) then begin +- match get_desc (row_more row) with +- | Tvar _ when param -> ret := TypeSet.add ty !ret +- | _ -> loop (row_more row) +- end +- (* XXX: What about Tobject ? *) +- | _ -> +- iter_type_expr loop ty +- in +- loop ty; +- unmark_type ty; ++ with_type_mark begin fun mark -> ++ let rec loop ty = ++ if try_mark_node mark ty then ++ match get_desc ty with ++ | Tvar _ -> ++ ret := TypeSet.add ty !ret ++ | Tvariant row -> ++ iter_row loop row; ++ if not (static_row row) then begin ++ match get_desc (row_more row) with ++ | Tvar _ when param -> ret := TypeSet.add ty !ret ++ | _ -> loop (row_more row) ++ end ++ (* XXX: What about Tobject ? *) ++ | _ -> ++ iter_type_expr loop ty ++ in ++ loop ty ++ end; + !ret + + let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) diff --git a/upstream/patches_503/typing/datarepr.mli.patch b/upstream/patches_503/typing/datarepr.mli.patch new file mode 100644 index 000000000..5a23f9654 --- /dev/null +++ b/upstream/patches_503/typing/datarepr.mli.patch @@ -0,0 +1,19 @@ +--- ocaml_502/typing/datarepr.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/datarepr.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -19,14 +19,14 @@ + open Types + + val extension_descr: +- current_unit:string -> Path.t -> extension_constructor -> ++ current_unit:(Unit_info.t option) -> Path.t -> extension_constructor -> + constructor_description + + val labels_of_type: + Path.t -> type_declaration -> + (Ident.t * label_description) list + val constructors_of_type: +- current_unit:string -> Path.t -> type_declaration -> ++ current_unit:(Unit_info.t option) -> Path.t -> type_declaration -> + (Ident.t * constructor_description) list + + diff --git a/upstream/patches_503/typing/env.ml.patch b/upstream/patches_503/typing/env.ml.patch new file mode 100644 index 000000000..9ad02dbbe --- /dev/null +++ b/upstream/patches_503/typing/env.ml.patch @@ -0,0 +1,372 @@ +--- ocaml_502/typing/env.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/env.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -794,48 +794,63 @@ + + (* The name of the compilation unit currently compiled. + "" if outside a compilation unit. *) +-module Current_unit_name : sig +- val get : unit -> modname +- val set : modname -> unit +- val is : modname -> bool +- val is_ident : Ident.t -> bool +- val is_path : Path.t -> bool ++module Current_unit : sig ++ val get : unit -> Unit_info.t option ++ val set : Unit_info.t -> unit ++ val unset : unit -> unit ++ ++ module Name : sig ++ val get : unit -> modname ++ val is : modname -> bool ++ val is_ident : Ident.t -> bool ++ val is_path : Path.t -> bool ++ end + end = struct +- let current_unit = +- ref "" ++ let current_unit : Unit_info.t option ref = ++ ref None + let get () = + !current_unit +- let set name = +- current_unit := name +- let is name = +- !current_unit = name +- let is_ident id = +- Ident.persistent id && is (Ident.name id) +- let is_path = function +- | Pident id -> is_ident id +- | Pdot _ | Papply _ | Pextra_ty _ -> false ++ let set cu = ++ current_unit := Some cu ++ let unset () = ++ current_unit := None ++ ++ module Name = struct ++ let get () = ++ match !current_unit with ++ | None -> "" ++ | Some cu -> Unit_info.modname cu ++ let is name = ++ get () = name ++ let is_ident id = ++ Ident.persistent id && is (Ident.name id) ++ let is_path = function ++ | Pident id -> is_ident id ++ | Pdot _ | Papply _ | Pextra_ty _ -> false ++ end + end + +-let set_unit_name = Current_unit_name.set +-let get_unit_name = Current_unit_name.get ++let set_current_unit = Current_unit.set ++let get_current_unit = Current_unit.get ++let get_current_unit_name = Current_unit.Name.get + + let find_same_module id tbl = + match IdTbl.find_same id tbl with + | x -> x + | exception Not_found +- when Ident.persistent id && not (Current_unit_name.is_ident id) -> ++ when Ident.persistent id && not (Current_unit.Name.is_ident id) -> + Mod_persistent + + let find_name_module ~mark name tbl = + match IdTbl.find_name wrap_module ~mark name tbl with + | x -> x +- | exception Not_found when not (Current_unit_name.is name) -> ++ | exception Not_found when not (Current_unit.Name.is name) -> + let path = Pident(Ident.create_persistent name) in + path, Mod_persistent + + let add_persistent_structure id env = + if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure"; +- if Current_unit_name.is_ident id then env ++ if Current_unit.Name.is_ident id then env + else begin + let material = + (* This addition only observably changes the environment if it shadows a +@@ -962,7 +977,7 @@ + () + + let reset_cache () = +- Current_unit_name.set ""; ++ Current_unit.unset (); + Persistent_env.clear !persistent_env; + reset_declaration_caches (); + () +@@ -1287,7 +1302,7 @@ + properly populated. *) + assert false + | exception Not_found +- when Ident.persistent id && not (Current_unit_name.is_ident id) -> ++ when Ident.persistent id && not (Current_unit.Name.is_ident id) -> + Shape.for_persistent_unit (Ident.name id) + end + | Module_type -> +@@ -1682,16 +1697,6 @@ + | Mp_present -> + Lazy_backtrack.create_forced (Aident id) + +-let is_identchar c = +- (* This should be kept in sync with the [identchar_latin1] character class +- in [lexer.mll] *) +- match c with +- | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' +- | '\216'..'\246' | '\248'..'\255' | '\'' | '0'..'9' -> +- true +- | _ -> +- false +- + let rec components_of_module_maker + {cm_env; cm_prefixing_subst; + cm_path; cm_addr; cm_mty; cm_shape} : _ result = +@@ -1739,7 +1744,7 @@ + | Type_variant (_,repr) -> + let cstrs = List.map snd + (Datarepr.constructors_of_type path final_decl +- ~current_unit:(get_unit_name ())) ++ ~current_unit:(get_current_unit ())) + in + List.iter + (fun descr -> +@@ -1777,7 +1782,7 @@ + | SigL_typext(id, ext, _, _) -> + let ext' = Subst.extension_constructor sub ext in + let descr = +- Datarepr.extension_descr ~current_unit:(get_unit_name ()) path ++ Datarepr.extension_descr ~current_unit:(get_current_unit ()) path + ext' + in + let addr = next_address () in +@@ -1897,7 +1902,8 @@ + (* Note: we could also check here general validity of the + identifier, to protect against bad identifiers forged by -pp or + -ppx preprocessors. *) +- if String.length name > 0 && not (is_identchar name.[0]) then ++ if String.length name > 0 && not ++ (Utf8_lexeme.starts_like_a_valid_identifier name) then + for i = 1 to String.length name - 1 do + if name.[i] = '#' then + error (Illegal_value_name(loc, name)) +@@ -1996,7 +2002,7 @@ + match info.type_kind with + | Type_variant (_,repr) -> + let constructors = Datarepr.constructors_of_type path info +- ~current_unit:(get_unit_name ()) ++ ~current_unit:(get_current_unit ()) + in + Type_variant (List.map snd constructors, repr), + List.fold_left +@@ -2043,7 +2049,8 @@ + and store_extension ~check ~rebind id addr ext shape env = + let loc = ext.ext_loc in + let cstr = +- Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext ++ Datarepr.extension_descr ++ ~current_unit:(get_current_unit ()) (Pident id) ext + in + let cda = + { cda_description = cstr; +@@ -2532,7 +2539,7 @@ + let unit_name_of_filename fn = + match Filename.extension fn with + | ".cmi" -> +- let modname = Unit_info.modname_from_source fn in ++ let modname = Unit_info.strict_modname_from_source fn in + if Unit_info.is_unit_name modname then Some modname + else None + | _ -> None +@@ -3283,7 +3290,7 @@ + match IdTbl.find_name wrap_module ~mark:false name env.modules with + | _ -> true + | exception Not_found -> +- if Current_unit_name.is name then false ++ if Current_unit.Name.is name then false + else begin + match find_pers_mod ~allow_hidden:false name with + | _ -> true +@@ -3512,15 +3519,16 @@ + + (* Error report *) + +-open Format ++open Format_doc + + (* Forward declarations *) + +-let print_longident = +- ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit) ++let print_longident : Longident.t printer ref = ref (fun _ _ -> assert false) + +-let print_path = +- ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit) ++let pp_longident ppf l = !print_longident ppf l ++ ++let print_path: Path.t printer ref = ref (fun _ _ -> assert false) ++let pp_path ppf l = !print_path ppf l + + let spellcheck ppf extract env lid = + let choices ~path name = Misc.spellcheck (extract path env) name in +@@ -3560,10 +3568,11 @@ + + module Style = Misc.Style + +-let report_lookup_error _loc env ppf = function ++let quoted_longident = Style.as_inline_code pp_longident ++ ++let report_lookup_error_doc _loc env ppf = function + | Unbound_value(lid, hint) -> begin +- fprintf ppf "Unbound value %a" +- (Style.as_inline_code !print_longident) lid; ++ fprintf ppf "Unbound value %a" quoted_longident lid; + spellcheck ppf extract_values env lid; + match hint with + | No_hint -> () +@@ -3579,52 +3588,52 @@ + end + | Unbound_type lid -> + fprintf ppf "Unbound type constructor %a" +- (Style.as_inline_code !print_longident) lid; ++ quoted_longident lid; + spellcheck ppf extract_types env lid; + | Unbound_module lid -> begin + fprintf ppf "Unbound module %a" +- (Style.as_inline_code !print_longident) lid; ++ quoted_longident lid; + match find_modtype_by_name lid env with + | exception Not_found -> spellcheck ppf extract_modules env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a module type named %a, %s@]" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + "but module types are not modules" + end + | Unbound_constructor lid -> + fprintf ppf "Unbound constructor %a" +- (Style.as_inline_code !print_longident) lid; ++ quoted_longident lid; + spellcheck ppf extract_constructors env lid; + | Unbound_label lid -> + fprintf ppf "Unbound record field %a" +- (Style.as_inline_code !print_longident) lid; ++ quoted_longident lid; + spellcheck ppf extract_labels env lid; + | Unbound_class lid -> begin + fprintf ppf "Unbound class %a" +- (Style.as_inline_code !print_longident) lid; ++ quoted_longident lid; + match find_cltype_by_name lid env with + | exception Not_found -> spellcheck ppf extract_classes env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a class type named %a, %s@]" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + "but classes are not class types" + end + | Unbound_modtype lid -> begin + fprintf ppf "Unbound module type %a" +- (Style.as_inline_code !print_longident) lid; ++ quoted_longident lid; + match find_module_by_name lid env with + | exception Not_found -> spellcheck ppf extract_modtypes env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a module named %a, %s@]" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + "but modules are not module types" + end + | Unbound_cltype lid -> + fprintf ppf "Unbound class type %a" +- (Style.as_inline_code !print_longident) lid; ++ quoted_longident lid; + spellcheck ppf extract_cltypes env lid; + | Unbound_instance_variable s -> + fprintf ppf "Unbound instance variable %a" Style.inline_code s; +@@ -3637,47 +3646,47 @@ + fprintf ppf + "The instance variable %a@ \ + cannot be accessed from the definition of another instance variable" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + | Masked_self_variable lid -> + fprintf ppf + "The self variable %a@ \ + cannot be accessed from the definition of an instance variable" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + | Masked_ancestor_variable lid -> + fprintf ppf + "The ancestor variable %a@ \ + cannot be accessed from the definition of an instance variable" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + | Illegal_reference_to_recursive_module -> + fprintf ppf "Illegal recursive module reference" + | Structure_used_as_functor lid -> + fprintf ppf "@[The module %a is a structure, it cannot be applied@]" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + | Abstract_used_as_functor lid -> + fprintf ppf "@[The module %a is abstract, it cannot be applied@]" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + | Functor_used_as_structure lid -> + fprintf ppf "@[The module %a is a functor, \ +- it cannot have any components@]" !print_longident lid ++ it cannot have any components@]" pp_longident lid + | Abstract_used_as_structure lid -> + fprintf ppf "@[The module %a is abstract, \ + it cannot have any components@]" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + | Generative_used_as_applicative lid -> + fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ + applied@ in@ type@ expressions@]" +- (Style.as_inline_code !print_longident) lid ++ quoted_longident lid + | Cannot_scrape_alias(lid, p) -> + let cause = +- if Current_unit_name.is_path p then "is the current compilation unit" ++ if Current_unit.Name.is_path p then "is the current compilation unit" + else "is missing" + in + fprintf ppf + "The module %a is an alias for module %a, which %s" +- (Style.as_inline_code !print_longident) lid +- (Style.as_inline_code !print_path) p cause ++ quoted_longident lid ++ (Style.as_inline_code pp_path) p cause + +-let report_error ppf = function ++let report_error_doc ppf = function + | Missing_module(_, path1, path2) -> + fprintf ppf "@[@["; + if Path.same path1 path2 then +@@ -3694,7 +3703,7 @@ + | Illegal_value_name(_loc, name) -> + fprintf ppf "%a is not a valid value identifier." + Style.inline_code name +- | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err ++ | Lookup_error(loc, t, err) -> report_lookup_error_doc loc t ppf err + + let () = + Location.register_error_of_exn +@@ -3709,9 +3718,12 @@ + let error_of_printer = + if loc = Location.none + then Location.error_of_printer_file +- else Location.error_of_printer ~loc ?sub:None ++ else Location.error_of_printer ~loc ?sub:None ?footnote:None + in +- Some (error_of_printer report_error err) ++ Some (error_of_printer report_error_doc err) + | _ -> + None + ) ++ ++let report_lookup_error = Format_doc.compat2 report_lookup_error_doc ++let report_error = Format_doc.compat report_error_doc diff --git a/upstream/patches_503/typing/env.mli.patch b/upstream/patches_503/typing/env.mli.patch new file mode 100644 index 000000000..625dbf7b8 --- /dev/null +++ b/upstream/patches_503/typing/env.mli.patch @@ -0,0 +1,47 @@ +--- ocaml_502/typing/env.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/env.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -394,9 +394,10 @@ + (* To be called before each toplevel phrase. *) + val reset_cache_toplevel: unit -> unit + +-(* Remember the name of the current compilation unit. *) +-val set_unit_name: string -> unit +-val get_unit_name: unit -> string ++(* Remember the current compilation unit. *) ++val set_current_unit: Unit_info.t -> unit ++val get_current_unit : unit -> Unit_info.t option ++val get_current_unit_name: unit -> string + + (* Read, save a signature to/from a file *) + val read_signature: Unit_info.Artifact.t -> signature +@@ -447,12 +448,14 @@ + + exception Error of error + +-open Format + +-val report_error: formatter -> error -> unit +- +-val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit ++val report_error: error Format_doc.format_printer ++val report_error_doc: error Format_doc.printer + ++val report_lookup_error: ++ Location.t -> t -> lookup_error Format_doc.format_printer ++val report_lookup_error_doc: ++ Location.t -> t -> lookup_error Format_doc.printer + val in_signature: bool -> t -> t + + val is_in_signature: t -> bool +@@ -482,9 +485,9 @@ + (* Forward declaration to break mutual recursion with Ctype. *) + val same_constr: (t -> type_expr -> type_expr -> bool) ref + (* Forward declaration to break mutual recursion with Printtyp. *) +-val print_longident: (Format.formatter -> Longident.t -> unit) ref ++val print_longident: Longident.t Format_doc.printer ref + (* Forward declaration to break mutual recursion with Printtyp. *) +-val print_path: (Format.formatter -> Path.t -> unit) ref ++val print_path: Path.t Format_doc.printer ref + + + (** Folds *) diff --git a/upstream/patches_503/typing/envaux.ml.patch b/upstream/patches_503/typing/envaux.ml.patch new file mode 100644 index 000000000..b13ae1eff --- /dev/null +++ b/upstream/patches_503/typing/envaux.ml.patch @@ -0,0 +1,26 @@ +--- ocaml_502/typing/envaux.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/envaux.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -101,17 +101,19 @@ + + (* Error report *) + +-open Format ++open Format_doc + module Style = Misc.Style + +-let report_error ppf = function ++let report_error_doc ppf = function + | Module_not_found p -> + fprintf ppf "@[Cannot find module %a@].@." +- (Style.as_inline_code Printtyp.path) p ++ (Style.as_inline_code Printtyp.Doc.path) p + + let () = + Location.register_error_of_exn + (function +- | Error err -> Some (Location.error_of_printer_file report_error err) ++ | Error err -> Some (Location.error_of_printer_file report_error_doc err) + | _ -> None + ) ++ ++let report_error = Format_doc.compat report_error_doc diff --git a/upstream/patches_503/typing/envaux.mli.patch b/upstream/patches_503/typing/envaux.mli.patch new file mode 100644 index 000000000..bfeb202e0 --- /dev/null +++ b/upstream/patches_503/typing/envaux.mli.patch @@ -0,0 +1,18 @@ +--- ocaml_502/typing/envaux.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/envaux.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -14,8 +14,6 @@ + (* *) + (**************************************************************************) + +-open Format +- + (* Convert environment summaries to environments *) + + val env_from_summary : Env.summary -> Subst.t -> Env.t +@@ -33,4 +31,5 @@ + + exception Error of error + +-val report_error: formatter -> error -> unit ++val report_error: error Format_doc.format_printer ++val report_error_doc: error Format_doc.printer diff --git a/upstream/patches_503/typing/errortrace.ml.patch b/upstream/patches_503/typing/errortrace.ml.patch new file mode 100644 index 000000000..d001bbb62 --- /dev/null +++ b/upstream/patches_503/typing/errortrace.ml.patch @@ -0,0 +1,43 @@ +--- ocaml_502/typing/errortrace.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/errortrace.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -16,7 +16,7 @@ + (**************************************************************************) + + open Types +-open Format ++open Format_doc + + type position = First | Second + +@@ -98,14 +98,21 @@ + (* Unification *) + | Self_cannot_be_closed : unification obj + ++type first_class_module = ++ | Package_cannot_scrape of Path.t ++ | Package_inclusion of Format_doc.doc ++ | Package_coercion of Format_doc.doc ++ + type ('a, 'variety) elt = + (* Common *) + | Diff : 'a diff -> ('a, _) elt + | Variant : 'variety variant -> ('a, 'variety) elt + | Obj : 'variety obj -> ('a, 'variety) elt + | Escape : 'a escape -> ('a, _) elt ++ | Function_label_mismatch of Asttypes.arg_label diff + | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt + (* Could move [Incompatible_fields] into [obj] *) ++ | First_class_module: first_class_module -> ('a,_) elt + (* Unification & Moregen; included in Equality for simplicity *) + | Rec_occur : type_expr * type_expr -> ('a, _) elt + +@@ -120,7 +127,8 @@ + Escape { kind = Equation (f x); context } + | Escape {kind = (Univ _ | Self | Constructor _ | Module_type _ | Constraint); + _} +- | Variant _ | Obj _ | Incompatible_fields _ | Rec_occur (_, _) as x -> x ++ | Variant _ | Obj _ | Function_label_mismatch _ | Incompatible_fields _ ++ | Rec_occur (_, _) | First_class_module _ as x -> x + + let map f t = List.map (map_elt f) t + diff --git a/upstream/patches_503/typing/errortrace.mli.patch b/upstream/patches_503/typing/errortrace.mli.patch new file mode 100644 index 000000000..4e1d06aae --- /dev/null +++ b/upstream/patches_503/typing/errortrace.mli.patch @@ -0,0 +1,32 @@ +--- ocaml_502/typing/errortrace.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/errortrace.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -20,7 +20,7 @@ + type position = First | Second + + val swap_position : position -> position +-val print_pos : Format.formatter -> position -> unit ++val print_pos : position Format_doc.printer + + type expanded_type = { ty: type_expr; expanded: type_expr } + +@@ -84,13 +84,20 @@ + (* Unification *) + | Self_cannot_be_closed : unification obj + ++type first_class_module = ++ | Package_cannot_scrape of Path.t ++ | Package_inclusion of Format_doc.doc ++ | Package_coercion of Format_doc.doc ++ + type ('a, 'variety) elt = + (* Common *) + | Diff : 'a diff -> ('a, _) elt + | Variant : 'variety variant -> ('a, 'variety) elt + | Obj : 'variety obj -> ('a, 'variety) elt + | Escape : 'a escape -> ('a, _) elt ++ | Function_label_mismatch of Asttypes.arg_label diff + | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt ++ | First_class_module: first_class_module -> ('a,_) elt + (* Unification & Moregen; included in Equality for simplicity *) + | Rec_occur : type_expr * type_expr -> ('a, _) elt + diff --git a/upstream/patches_503/typing/errortrace_report.ml.patch b/upstream/patches_503/typing/errortrace_report.ml.patch new file mode 100644 index 000000000..edc79eb31 --- /dev/null +++ b/upstream/patches_503/typing/errortrace_report.ml.patch @@ -0,0 +1,593 @@ +--- ocaml_502/typing/errortrace_report.ml 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/typing/errortrace_report.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -0,0 +1,590 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Florian Angeletti, projet Cambium, INRIA Paris *) ++(* *) ++(* Copyright 2024 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* Trace-specific printing *) ++ ++(* A configuration type that controls which trace we print. This could be ++ exposed, but we instead expose three separate ++ [{unification,equality,moregen}] functions. This also lets us ++ give the unification case an extra optional argument without adding it to the ++ equality and moregen cases. *) ++type 'variety trace_format = ++ | Unification : Errortrace.unification trace_format ++ | Equality : Errortrace.comparison trace_format ++ | Moregen : Errortrace.comparison trace_format ++ ++let incompatibility_phrase (type variety) : variety trace_format -> string = ++ function ++ | Unification -> "is not compatible with type" ++ | Equality -> "is not equal to type" ++ | Moregen -> "is not compatible with type" ++ ++(* Print a unification error *) ++open Out_type ++open Format_doc ++module Fmt = Format_doc ++module Style = Misc.Style ++ ++type 'a diff = 'a Out_type.diff = Same of 'a | Diff of 'a * 'a ++ ++let trees_of_trace mode = ++ List.map (Errortrace.map_diff (trees_of_type_expansion mode)) ++ ++let rec trace fst txt ppf = function ++ | {Errortrace.got; expected} :: rem -> ++ if not fst then fprintf ppf "@,"; ++ fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" ++ pp_type_expansion got txt pp_type_expansion expected ++ (trace false txt) rem ++ | _ -> () ++ ++type printing_status = ++ | Discard ++ | Keep ++ | Optional_refinement ++ (** An [Optional_refinement] printing status is attributed to trace ++ elements that are focusing on a new subpart of a structural type. ++ Since the whole type should have been printed earlier in the trace, ++ we only print those elements if they are the last printed element ++ of a trace, and there is no explicit explanation for the ++ type error. ++ *) ++ ++let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; ++ expected = {ty = t2; expanded = t2'} } = ++ if Btype.is_constr_row ~allow_ident:true t1' ++ || Btype.is_constr_row ~allow_ident:true t2' ++ then Discard ++ else if same_path t1 t1' && same_path t2 t2' then Optional_refinement ++ else Keep ++ ++let printing_status = function ++ | Errortrace.Diff d -> diff_printing_status d ++ | Errortrace.Escape {kind = Constraint} -> Keep ++ | _ -> Keep ++ ++(** Flatten the trace and remove elements that are always discarded ++ during printing *) ++ ++(* Takes [printing_status] to change behavior for [Subtype] *) ++let prepare_any_trace printing_status tr = ++ let clean_trace x l = match printing_status x with ++ | Keep -> x :: l ++ | Optional_refinement when l = [] -> [x] ++ | Optional_refinement | Discard -> l ++ in ++ match tr with ++ | [] -> [] ++ | elt :: rem -> elt :: List.fold_right clean_trace rem [] ++ ++let prepare_trace f tr = ++ prepare_any_trace printing_status (Errortrace.map f tr) ++ ++(** Keep elements that are [Diff _ ] and split the the last element if it is ++ optionally elidable, require a prepared trace *) ++let rec filter_trace = function ++ | [] -> [], None ++ | [Errortrace.Diff d as elt] ++ when printing_status elt = Optional_refinement -> [], Some d ++ | Errortrace.Diff d :: rem -> ++ let filtered, last = filter_trace rem in ++ d :: filtered, last ++ | _ :: rem -> filter_trace rem ++ ++let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = ++ match Types.get_desc expanded with ++ Tvariant _ | Tobject _ when compact -> ++ Variable_names.reserve ty; Errortrace.{ty; expanded = ty} ++ | _ -> prepare_expansion ty_exp ++ ++let print_path p = ++ Fmt.dprintf "%a" !Oprint.out_ident (namespaced_tree_of_path Type p) ++ ++let print_tag ppf s = Style.inline_code ppf ("`" ^ s) ++ ++let print_tags ppf tags = ++ Fmt.(pp_print_list ~pp_sep:comma) print_tag ppf tags ++ ++let is_unit env ty = ++ match Types.get_desc (Ctype.expand_head env ty) with ++ | Tconstr (p, _, _) -> Path.same p Predef.path_unit ++ | _ -> false ++ ++let unifiable env ty1 ty2 = ++ let snap = Btype.snapshot () in ++ let res = ++ try Ctype.unify env ty1 ty2; true ++ with Ctype.Unify _ -> false ++ in ++ Btype.backtrack snap; ++ res ++ ++let explanation_diff env t3 t4 = ++ match Types.get_desc t3, Types.get_desc t4 with ++ | Tarrow (_, ty1, ty2, _), _ ++ when is_unit env ty1 && unifiable env ty2 t4 -> ++ Some (doc_printf ++ "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" ++ Style.inline_code "()" ++ ) ++ | _, Tarrow (_, ty1, ty2, _) ++ when is_unit env ty1 && unifiable env t3 ty2 -> ++ Some (doc_printf ++ "@,@[@{Hint@}: Did you forget to wrap the expression using \ ++ %a?@]" ++ Style.inline_code "fun () ->" ++ ) ++ | _ -> ++ None ++ ++let explain_fixed_row_case = function ++ | Errortrace.Cannot_be_closed -> doc_printf "it cannot be closed" ++ | Errortrace.Cannot_add_tags tags -> ++ doc_printf "it may not allow the tag(s) %a" ++ print_tags tags ++ ++let pp_path ppf p = ++ Style.as_inline_code Printtyp.Doc.path ppf p ++ ++let explain_fixed_row pos expl = match expl with ++ | Types.Fixed_private -> ++ doc_printf "The %a variant type is private" Errortrace.print_pos pos ++ | Types.Univar x -> ++ Variable_names.reserve x; ++ doc_printf "The %a variant type is bound to the universal type variable %a" ++ Errortrace.print_pos pos ++ (Style.as_inline_code type_expr_with_reserved_names) x ++ | Types.Reified p -> ++ doc_printf "The %a variant type is bound to %a" ++ Errortrace.print_pos pos ++ (Style.as_inline_code ++ (fun ppf p -> ++ Internal_names.add p; ++ print_path p ppf)) ++ p ++ | Types.Rigid -> Format_doc.Doc.empty ++ ++let explain_variant (type variety) : variety Errortrace.variant -> _ = function ++ (* Common *) ++ | Errortrace.Incompatible_types_for s -> ++ Some(doc_printf "@,Types for tag %a are incompatible" ++ print_tag s ++ ) ++ (* Unification *) ++ | Errortrace.No_intersection -> ++ Some(doc_printf "@,These two variant types have no intersection") ++ | Errortrace.No_tags(pos,fields) -> Some( ++ doc_printf ++ "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" ++ Errortrace.print_pos pos ++ print_tags (List.map fst fields) ++ ) ++ | Errortrace.Fixed_row (pos, ++ k, ++ (Univar _ | Reified _ | Fixed_private as e)) -> ++ Some ( ++ doc_printf "@,@[%a,@ %a@]" pp_doc (explain_fixed_row pos e) ++ pp_doc (explain_fixed_row_case k) ++ ) ++ | Errortrace.Fixed_row (_,_, Rigid) -> ++ (* this case never happens *) ++ None ++ (* Equality & Moregen *) ++ | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( ++ doc_printf ++ "@,@[The tag %a is guaranteed to be present in the %a variant type,\ ++ @ but not in the %a@]" ++ print_tag s ++ Errortrace.print_pos (Errortrace.swap_position pos) ++ Errortrace.print_pos pos ++ ) ++ | Errortrace.Openness pos -> ++ Some(doc_printf "@,The %a variant type is open and the %a is not" ++ Errortrace.print_pos pos ++ Errortrace.print_pos (Errortrace.swap_position pos)) ++ ++let explain_escape pre = function ++ | Errortrace.Univ u -> ++ Variable_names.reserve u; ++ Some( ++ doc_printf "%a@,The universal variable %a would escape its scope" ++ pp_doc pre ++ (Style.as_inline_code type_expr_with_reserved_names) u ++ ) ++ | Errortrace.Constructor p -> Some( ++ doc_printf ++ "%a@,@[The type constructor@;<1 2>%a@ would escape its scope@]" ++ pp_doc pre pp_path p ++ ) ++ | Errortrace.Module_type p -> Some( ++ doc_printf ++ "%a@,@[The module type@;<1 2>%a@ would escape its scope@]" ++ pp_doc pre pp_path p ++ ) ++ | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> ++ Variable_names.reserve t; ++ Some( ++ doc_printf "%a@ @[This instance of %a is ambiguous:@ %s@]" ++ pp_doc pre ++ (Style.as_inline_code type_expr_with_reserved_names) t ++ "it would escape the scope of its equation" ++ ) ++ | Errortrace.Self -> ++ Some (doc_printf "%a@,Self type cannot escape its class" pp_doc pre) ++ | Errortrace.Constraint -> ++ None ++ ++let explain_object (type variety) : variety Errortrace.obj -> _ = function ++ | Errortrace.Missing_field (pos,f) -> Some( ++ doc_printf "@,@[The %a object type has no method %a@]" ++ Errortrace.print_pos pos Style.inline_code f ++ ) ++ | Errortrace.Abstract_row pos -> Some( ++ doc_printf ++ "@,@[The %a object type has an abstract row, it cannot be closed@]" ++ Errortrace.print_pos pos ++ ) ++ | Errortrace.Self_cannot_be_closed -> ++ Some (doc_printf ++ "@,Self type cannot be unified with a closed object type" ++ ) ++ ++let explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = ++ Variable_names.reserve diff.got; ++ Variable_names.reserve diff.expected; ++ doc_printf "@,@[The method %a has type@ %a,@ \ ++ but the expected method type was@ %a@]" ++ Style.inline_code name ++ (Style.as_inline_code type_expr_with_reserved_names) diff.got ++ (Style.as_inline_code type_expr_with_reserved_names) diff.expected ++ ++ ++let explain_label_mismatch ~got ~expected = ++ let quoted_label ppf l = Style.inline_code ppf (Asttypes.string_of_label l) in ++ match got, expected with ++ | Asttypes.Nolabel, Asttypes.(Labelled _ | Optional _ ) -> ++ doc_printf "@,@[A label@ %a@ was expected@]" ++ quoted_label expected ++ | Asttypes.(Labelled _|Optional _), Asttypes.Nolabel -> ++ doc_printf ++ "@,@[The first argument is labeled@ %a,@ \ ++ but an unlabeled argument was expected@]" ++ quoted_label got ++ | Asttypes.Labelled g, Asttypes.Optional e when g = e -> ++ doc_printf ++ "@,@[The label@ %a@ was expected to be optional@]" ++ quoted_label got ++ | Asttypes.Optional g, Asttypes.Labelled e when g = e -> ++ doc_printf ++ "@,@[The label@ %a@ was expected to not be optional@]" ++ quoted_label got ++ | Asttypes.(Labelled _ | Optional _), Asttypes.(Labelled _ | Optional _) -> ++ doc_printf "@,@[Labels %a@ and@ %a do not match@]" ++ quoted_label got ++ quoted_label expected ++ | Asttypes.Nolabel, Asttypes.Nolabel -> ++ (* Two empty labels cannot be mismatched*) ++ assert false ++ ++ ++let explain_first_class_module = function ++ | Errortrace.Package_cannot_scrape p -> Some( ++ doc_printf "@,@[The module alias %a could not be expanded@]" ++ pp_path p ++ ) ++ | Errortrace.Package_inclusion pr -> ++ Some(doc_printf "@,@[%a@]" Fmt.pp_doc pr) ++ | Errortrace.Package_coercion pr -> ++ Some(doc_printf "@,@[%a@]" Fmt.pp_doc pr) ++ ++let explanation (type variety) intro prev env ++ : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function ++ | Errortrace.Diff {got; expected} -> ++ explanation_diff env got.expanded expected.expanded ++ | Errortrace.Escape {kind; context} -> ++ let pre = ++ match context, kind, prev with ++ | Some ctx, _, _ -> ++ Variable_names.reserve ctx; ++ doc_printf "@[%a@;<1 2>%a@]" pp_doc intro ++ (Style.as_inline_code type_expr_with_reserved_names) ctx ++ | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> ++ explain_incompatible_fields name diff ++ | _ -> Format_doc.Doc.empty ++ in ++ explain_escape pre kind ++ | Errortrace.Incompatible_fields { name; diff} -> ++ Some(explain_incompatible_fields name diff) ++ | Errortrace.Function_label_mismatch diff -> ++ Some(explain_label_mismatch ~got:diff.got ~expected:diff.expected) ++ | Errortrace.Variant v -> ++ explain_variant v ++ | Errortrace.Obj o -> ++ explain_object o ++ | Errortrace.First_class_module fm -> ++ explain_first_class_module fm ++ | Errortrace.Rec_occur(x,y) -> ++ add_type_to_preparation x; ++ add_type_to_preparation y; ++ begin match Types.get_desc x with ++ | Tvar _ | Tunivar _ -> ++ Some( ++ doc_printf "@,@[The type variable %a occurs inside@ %a@]" ++ (Style.as_inline_code prepared_type_expr) x ++ (Style.as_inline_code prepared_type_expr) y ++ ) ++ | _ -> ++ (* We had a delayed unification of the type variable with ++ a non-variable after the occur check. *) ++ Some Format_doc.Doc.empty ++ (* There is no need to search further for an explanation, but ++ we don't want to print a message of the form: ++ {[ The type int occurs inside int list -> 'a |} ++ *) ++ end ++ ++let mismatch intro env trace = ++ Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) ++ ++let warn_on_missing_def env ppf t = ++ match Types.get_desc t with ++ | Tconstr (p,_,_) -> ++ begin match Env.find_type p env with ++ | exception Not_found -> ++ fprintf ppf ++ "@,@[Type %a is abstract because@ no corresponding\ ++ @ cmi file@ was found@ in path.@]" pp_path p ++ | { type_manifest = Some _; _ } -> () ++ | { type_manifest = None; _ } as decl -> ++ match Btype.type_origin decl with ++ | Rec_check_regularity -> ++ fprintf ppf ++ "@,@[Type %a was considered abstract@ when checking\ ++ @ constraints@ in this@ recursive type definition.@]" ++ pp_path p ++ | Definition | Existential _ -> () ++ end ++ | _ -> () ++ ++let prepare_expansion_head empty_tr = function ++ | Errortrace.Diff d -> ++ Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) ++ | _ -> None ++ ++let head_error_printer mode txt_got txt_but = function ++ | None -> Format_doc.Doc.empty ++ | Some d -> ++ let d = Errortrace.map_diff (trees_of_type_expansion mode) d in ++ doc_printf "%a@;<1 2>%a@ %a@;<1 2>%a" ++ pp_doc txt_got pp_type_expansion d.Errortrace.got ++ pp_doc txt_but pp_type_expansion d.Errortrace.expected ++ ++let warn_on_missing_defs env ppf = function ++ | None -> () ++ | Some Errortrace.{got = {ty=te1; expanded=_}; ++ expected = {ty=te2; expanded=_} } -> ++ warn_on_missing_def env ppf te1; ++ warn_on_missing_def env ppf te2 ++ ++(* [subst] comes out of equality, and is [[]] otherwise *) ++let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = ++ reset (); ++ (* We want to substitute in the opposite order from [Eqtype] *) ++ Variable_names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); ++ let tr = ++ prepare_trace ++ (fun ty_exp -> ++ Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) ++ tr ++ in ++ match tr with ++ | [] -> assert false ++ | (elt :: tr) as full_trace -> ++ with_labels (not !Clflags.classic) (fun () -> ++ let tr, last = filter_trace tr in ++ let head = prepare_expansion_head (tr=[] && last=None) elt in ++ let tr = List.map (Errortrace.map_diff prepare_expansion) tr in ++ let last = Option.map (Errortrace.map_diff prepare_expansion) last in ++ let head_error = head_error_printer mode txt1 txt2 head in ++ let tr = trees_of_trace mode tr in ++ let last = ++ Option.map (Errortrace.map_diff (trees_of_type_expansion mode)) last in ++ let mis = mismatch txt1 env full_trace in ++ let tr = match mis, last with ++ | None, Some elt -> tr @ [elt] ++ | Some _, _ | _, None -> tr ++ in ++ fprintf ppf ++ "@[\ ++ @[%a%a@]%a%a\ ++ @]" ++ pp_doc head_error ++ pp_doc ty_expect_explanation ++ (trace false (incompatibility_phrase trace_format)) tr ++ (pp_print_option pp_doc) mis; ++ if env <> Env.empty ++ then warn_on_missing_defs env ppf head; ++ Internal_names.print_explanations env ppf; ++ Ident_conflicts.err_print ppf ++ ) ++ ++let report_error trace_format ppf mode env tr ++ ?(subst = []) ++ ?(type_expected_explanation = Fmt.Doc.empty) ++ txt1 txt2 = ++ wrap_printing_env ~error:true env (fun () -> ++ error trace_format mode subst env tr txt1 ppf txt2 ++ type_expected_explanation) ++ ++let unification ++ ppf env ({trace} : Errortrace.unification_error) = ++ report_error Unification ppf Type env ++ ?subst:None trace ++ ++let equality ++ ppf mode env ({subst; trace} : Errortrace.equality_error) = ++ report_error Equality ppf mode env ++ ~subst ?type_expected_explanation:None trace ++ ++let moregen ++ ppf mode env ({trace} : Errortrace.moregen_error) = ++ report_error Moregen ppf mode env ++ ?subst:None ?type_expected_explanation:None trace ++ ++let comparison ppf mode env = function ++ | Errortrace.Equality_error error -> equality ppf mode env error ++ | Errortrace.Moregen_error error -> moregen ppf mode env error ++ ++module Subtype = struct ++ (* There's a frustrating amount of code duplication between this module and ++ the outside code, particularly in [prepare_trace] and [filter_trace]. ++ Unfortunately, [Subtype] is *just* similar enough to have code duplication, ++ while being *just* different enough (it's only [Diff]) for the abstraction ++ to be nonobvious. Someday, perhaps... *) ++ ++ let printing_status = function ++ | Errortrace.Subtype.Diff d -> diff_printing_status d ++ ++ let prepare_unification_trace = prepare_trace ++ ++ let prepare_trace f tr = ++ prepare_any_trace printing_status (Errortrace.Subtype.map f tr) ++ ++ let trace filter_trace get_diff fst keep_last txt ppf tr = ++ with_labels (not !Clflags.classic) (fun () -> ++ match tr with ++ | elt :: tr' -> ++ let diffed_elt = get_diff elt in ++ let tr, last = filter_trace tr' in ++ let tr = match keep_last, last with ++ | true, Some last -> tr @ [last] ++ | _ -> tr ++ in ++ let tr = ++ trees_of_trace Type ++ @@ List.map (Errortrace.map_diff prepare_expansion) tr in ++ let tr = ++ match fst, diffed_elt with ++ | true, Some elt -> elt :: tr ++ | _, _ -> tr ++ in ++ trace fst txt ppf tr ++ | _ -> () ++ ) ++ ++ let rec filter_subtype_trace = function ++ | [] -> [], None ++ | [Errortrace.Subtype.Diff d as elt] ++ when printing_status elt = Optional_refinement -> ++ [], Some d ++ | Errortrace.Subtype.Diff d :: rem -> ++ let ftr, last = filter_subtype_trace rem in ++ d :: ftr, last ++ ++ let unification_get_diff = function ++ | Errortrace.Diff diff -> ++ Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) ++ | _ -> None ++ ++ let subtype_get_diff = function ++ | Errortrace.Subtype.Diff diff -> ++ Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) ++ ++ let error ++ ppf ++ env ++ (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) ++ txt1 = ++ wrap_printing_env ~error:true env (fun () -> ++ reset (); ++ let tr_sub = prepare_trace prepare_expansion tr_sub in ++ let tr_unif = prepare_unification_trace prepare_expansion tr_unif in ++ let keep_first = match tr_unif with ++ | [Obj _ | Variant _ | Escape _ ] | [] -> true ++ | _ -> false in ++ fprintf ppf "@[%a" ++ (trace filter_subtype_trace subtype_get_diff true keep_first txt1) ++ tr_sub; ++ if tr_unif = [] then fprintf ppf "@]" else ++ let mis = mismatch (doc_printf "Within this type") env tr_unif in ++ fprintf ppf "%a%a%t@]" ++ (trace filter_trace unification_get_diff false ++ (mis = None) "is not compatible with type") tr_unif ++ (pp_print_option pp_doc) mis ++ Ident_conflicts.err_print ++ ) ++end ++ ++let subtype = Subtype.error ++ ++let quoted_ident ppf t = ++ Style.as_inline_code !Oprint.out_ident ppf t ++ ++let type_path_expansion ppf = function ++ | Same p -> quoted_ident ppf p ++ | Diff(p,p') -> ++ fprintf ppf "@[<2>%a@ =@ %a@]" ++ quoted_ident p ++ quoted_ident p' ++ ++let trees_of_type_path_expansion (tp,tp') = ++ let path_tree = namespaced_tree_of_path Type in ++ if Path.same tp tp' then Same(path_tree tp) else ++ Diff(path_tree tp, path_tree tp) ++ ++let type_path_list ppf l = ++ Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.pp_print_break ppf 2 0) ++ type_path_expansion ppf l ++ ++let ambiguous_type ppf env tp0 tpl txt1 txt2 txt3 = ++ wrap_printing_env ~error:true env (fun () -> ++ reset (); ++ let tp0 = trees_of_type_path_expansion tp0 in ++ match tpl with ++ [] -> assert false ++ | [tp] -> ++ fprintf ppf ++ "@[%a@;<1 2>%a@ \ ++ %a@;<1 2>%a\ ++ @]" ++ pp_doc txt1 type_path_expansion (trees_of_type_path_expansion tp) ++ pp_doc txt3 type_path_expansion tp0 ++ | _ -> ++ fprintf ppf ++ "@[%a@;<1 2>@[%a@]\ ++ @ %a@;<1 2>%a\ ++ @]" ++ pp_doc txt2 type_path_list (List.map trees_of_type_path_expansion tpl) ++ pp_doc txt3 type_path_expansion tp0) diff --git a/upstream/patches_503/typing/errortrace_report.mli.patch b/upstream/patches_503/typing/errortrace_report.mli.patch new file mode 100644 index 000000000..a7e1d64e7 --- /dev/null +++ b/upstream/patches_503/typing/errortrace_report.mli.patch @@ -0,0 +1,59 @@ +--- ocaml_502/typing/errortrace_report.mli 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/typing/errortrace_report.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -0,0 +1,56 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Florian Angeletti, projet Cambium, INRIA Paris *) ++(* *) ++(* Copyright 2024 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(** Functions for reporting core level type errors. *) ++ ++open Format_doc ++ ++val ambiguous_type: ++ formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> ++ Format_doc.t -> Format_doc.t -> Format_doc.t -> unit ++ ++val unification : ++ formatter -> ++ Env.t -> Errortrace.unification_error -> ++ ?type_expected_explanation:Format_doc.t -> Format_doc.t -> Format_doc.t -> ++ unit ++ ++val equality : ++ formatter -> ++ Out_type.type_or_scheme -> ++ Env.t -> Errortrace.equality_error -> ++ Format_doc.t -> Format_doc.t -> ++ unit ++ ++val moregen : ++ formatter -> ++ Out_type.type_or_scheme -> ++ Env.t -> Errortrace.moregen_error -> ++ Format_doc.t -> Format_doc.t -> ++ unit ++ ++val comparison : ++ formatter -> ++ Out_type.type_or_scheme -> ++ Env.t -> Errortrace.comparison_error -> ++ Format_doc.t -> Format_doc.t -> ++ unit ++ ++val subtype : ++ formatter -> ++ Env.t -> ++ Errortrace.Subtype.error -> ++ string -> ++ unit diff --git a/upstream/patches_503/typing/gprinttyp.ml.patch b/upstream/patches_503/typing/gprinttyp.ml.patch new file mode 100644 index 000000000..b865d5b6b --- /dev/null +++ b/upstream/patches_503/typing/gprinttyp.ml.patch @@ -0,0 +1,915 @@ +--- ocaml_502/typing/gprinttyp.ml 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/typing/gprinttyp.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -0,0 +1,912 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Florian Angeletti, projet Cambium, Inria Paris *) ++(* *) ++(* Copyright 2024 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++ ++(* Print a raw type expression, with sharing *) ++open Format ++ ++module String_set = Set.Make(String) ++ ++module Decoration = struct ++ type color = ++ | Named of string ++ | HSL of {h:float;s:float;l:float} ++ ++ let red = Named "red" ++ let blue = Named "blue" ++ let green = Named "green" ++ let purple = Named "purple" ++ let lightgrey = Named "lightgrey" ++ let hsl ~h ~s ~l = HSL {h;s;l} ++ ++ type style = ++ | Filled of color option ++ | Dotted ++ | Dash ++ ++ type shape = ++ | Ellipse ++ | Circle ++ | Diamond ++ ++ type property = ++ | Color of color ++ | Font_color of color ++ | Style of style ++ | Label of string list ++ | Shape of shape ++ ++ let filled c = Style (Filled (Some c)) ++ ++ type r = { ++ color: color option; ++ font_color:color option; ++ style: style option; ++ label: string list; ++ shape: shape option; ++ } ++ ++ let update r l = match l with ++ | Color c -> { r with color = Some c} ++ | Style s -> { r with style = Some s} ++ | Label s -> { r with label = s} ++ | Font_color c -> { r with font_color = Some c} ++ | Shape s -> { r with shape = Some s } ++ ++ let none = { color=None; font_color=None; style=None; shape=None; label = [] } ++ ++ let make l = List.fold_left update none l ++ ++ let label r = if r.label = [] then None else Some (Label r.label) ++ let color r = Option.map (fun x -> Color x) r.color ++ let font_color r = Option.map (fun x -> Font_color x) r.font_color ++ let style r = Option.map (fun x -> Style x) r.style ++ let shape r = Option.map (fun x -> Shape x) r.shape ++ ++ let decompose r = ++ let (@?) x l = match x with ++ | None -> l ++ | Some x -> x :: l ++ in ++ label r @? color r @? font_color r @? style r @? shape r @? [] ++ ++ let alt x y = match x with ++ | None -> y ++ | Some _ -> x ++ ++ let merge_label l r = ++ let r' = String_set.of_list r in ++ let l' = String_set.of_list l in ++ List.filter (fun x -> not (String_set.mem x r') ) l ++ @ List.filter (fun x -> not (String_set.mem x l') ) r ++ ++ let merge l r = ++ { color = alt l.color r.color; ++ style = alt l.style r.style; ++ label = merge_label l.label r.label; ++ font_color = alt l.font_color r.font_color; ++ shape = alt l.shape r.shape; ++ } ++ let txt t = Label [t] ++ ++end ++type decoration = Decoration.r ++ ++type dir = Toward | From ++ ++let txt = Decoration.txt ++let std = Decoration.none ++let dotted = Decoration.(make [Style Dotted]) ++let memo = Decoration.(make [txt "expand"; Style Dash] ) ++ ++ ++type params = { ++ short_ids:bool; ++ elide_links:bool; ++ expansion_as_hyperedge:bool; ++ colorize:bool; ++ follow_expansions:bool; ++} ++ ++let elide_links ty = ++ let rec follow_safe visited t = ++ let t = Types.Transient_expr.coerce t in ++ if List.memq t visited then t ++ else match t.Types.desc with ++ | Tlink t' -> follow_safe (t::visited) t' ++ | _ -> t ++ in ++ follow_safe [] ty ++ ++let repr params ty = ++ if params.elide_links then elide_links ty ++ else Types.Transient_expr.coerce ty ++ ++module Index: sig ++ type t = private ++ | Main of int ++ | Synthetic of int ++ | Named_subnode of { id:int; synth:bool; name:string } ++ val subnode: name:string -> t -> t ++ val either_ext: Types.row_field_cell -> t ++ val split: ++ params -> Types.type_expr -> t * Decoration.color option * Types.type_desc ++ val colorize: params -> t -> Decoration.color option ++end = struct ++ type t = ++ | Main of int ++ | Synthetic of int ++ | Named_subnode of { id:int; synth:bool; name:string } ++ ++ type name_map = { ++ (* We keep the main and synthetic and index space separate to avoid index ++ collision when we use the typechecker provided [id]s as main indices *) ++ main_last: int ref; ++ synthetic_last: int ref; ++ either_cell_ids: (Types.row_field_cell * int) list ref; ++ tbl: (int,int) Hashtbl.t; ++ } ++ ++ let id_map = { ++ main_last = ref 0; ++ synthetic_last = ref 0; ++ either_cell_ids = ref []; ++ tbl = Hashtbl.create 20; ++ } ++ ++ let fresh_main_id () = ++ incr id_map.main_last; ++ !(id_map.main_last) ++ ++ let fresh_synthetic_id () = ++ incr id_map.synthetic_last; ++ !(id_map.synthetic_last) ++ ++ let stable_id = function ++ | Main id | Synthetic id | Named_subnode {id;_} -> id ++ ++ let pretty_id params id = ++ if not params.short_ids then Main id else ++ match Hashtbl.find_opt id_map.tbl id with ++ | Some x -> Main x ++ | None -> ++ let last = fresh_main_id () in ++ Hashtbl.replace id_map.tbl id last; ++ Main last ++ ++ (** Generate color from the node id to keep the color stable inbetween ++ different calls to the typechecker on the same input. *) ++ let colorize_id params id = ++ if not params.colorize then None ++ else ++ (* Generate pseudo-random color by cycling over 200 hues while keeping ++ pastel level of saturation and lightness *) ++ let nhues = 200 in ++ (* 17 and 200 are relatively prime, thus 17 is of order 200 in Z/200Z. A ++ step size around 20 makes it relatively easy to spot different hues. *) ++ let h = float_of_int (17 * id mod nhues) /. float_of_int nhues in ++ (* Add a modulation of period 3 and 7 to the saturation and lightness *) ++ let s = match id mod 3 with ++ | 0 -> 0.3 ++ | 1 -> 0.5 ++ | 2 | _ -> 0.7 ++ in ++ let l = match id mod 7 with ++ | 0 -> 0.5 ++ | 1 -> 0.55 ++ | 2 -> 0.60 ++ | 3 -> 0.65 ++ | 4 -> 0.70 ++ | 5 -> 0.75 ++ | 6 | _ -> 0.8 ++ in ++ (* With 3, 7 and 200 relatively prime, we cycle over the full parameter ++ space with 4200 different colors. *) ++ Some (Decoration.hsl ~h ~s ~l) ++ ++ let colorize params index = colorize_id params (stable_id index) ++ ++ let split params x = ++ let x = repr params x in ++ let color = colorize_id params x.id in ++ pretty_id params x.id, color, x.desc ++ ++ let subnode ~name x = match x with ++ | Main id -> Named_subnode {id;name;synth=false} ++ | Named_subnode r -> Named_subnode {r with name} ++ | Synthetic id -> Named_subnode {id;name;synth=true} ++ ++ let either_ext r = ++ let either_ids = !(id_map.either_cell_ids) in ++ match List.assq_opt r either_ids with ++ | Some n -> Synthetic n ++ | None -> ++ let n = fresh_synthetic_id () in ++ id_map.either_cell_ids := (r,n) :: either_ids; ++ Synthetic n ++ ++end ++ ++ ++type index = Index.t ++module Node_set = Set.Make(struct ++ type t = Index.t ++ let compare = Stdlib.compare ++end) ++ ++module Edge_set = Set.Make(struct ++ type t = Index.t * Index.t ++ let compare = Stdlib.compare ++end) ++ ++module Hyperedge_set = Set.Make(struct ++ type t = (dir * Decoration.r * index) list ++ let compare = Stdlib.compare ++end) ++ ++type subgraph = ++ { ++ nodes: Node_set.t; ++ edges: Edge_set.t; ++ hyperedges: Hyperedge_set.t; ++ subgraphes: (Decoration.r * subgraph) list; ++ } ++ ++ ++let empty_subgraph= ++ { nodes = Node_set.empty; ++ edges=Edge_set.empty; ++ hyperedges = Hyperedge_set.empty; ++ subgraphes = []; ++ } ++ ++ ++type 'index elt = ++ | Node of 'index ++ | Edge of 'index * 'index ++ | Hyperedge of (dir * Decoration.r * 'index) list ++type element = Types.type_expr elt ++ ++ ++module Elt_map = Map.Make(struct ++ type t = Index.t elt ++ let compare = Stdlib.compare ++ end) ++let (.%()) map e = ++ Option.value ~default:Decoration.none @@ ++ Elt_map.find_opt e map ++ ++type digraph = { ++ elts: Decoration.r Elt_map.t; ++ graph: subgraph ++} ++ ++module Pp = struct ++ ++ let semi ppf () = fprintf ppf ";@ " ++ let space ppf () = fprintf ppf "@ " ++ let empty ppf () = fprintf ppf "" ++ let string =pp_print_string ++ let list ~sep = pp_print_list ~pp_sep:sep ++ let seq ~sep = pp_print_seq ~pp_sep:sep ++ let rec longident ppf = function ++ | Longident.Lident s -> fprintf ppf "%s" s ++ | Longident.Ldot (l,s) -> fprintf ppf "%a.%s" longident l s ++ | Longident.Lapply(f,x) -> fprintf ppf "%a(%a)" longident f longident x ++ ++ let color ppf = function ++ | Decoration.Named s -> fprintf ppf "%s" s ++ | Decoration.HSL r -> fprintf ppf "%1.3f %1.3f %1.3f" r.h r.s r.l ++ ++ let style ppf = function ++ | Decoration.Filled _ -> fprintf ppf "filled" ++ | Decoration.Dash -> fprintf ppf "dashed" ++ | Decoration.Dotted -> fprintf ppf "dotted" ++ ++ let shape ppf = function ++ | Decoration.Circle -> fprintf ppf "circle" ++ | Decoration.Diamond -> fprintf ppf "diamond" ++ | Decoration.Ellipse -> fprintf ppf "ellipse" ++ ++ let property ppf = function ++ | Decoration.Color c -> fprintf ppf {|color="%a"|} color c ++ | Decoration.Font_color c -> fprintf ppf {|fontcolor="%a"|} color c ++ | Decoration.Style s -> ++ fprintf ppf {|style="%a"|} style s; ++ begin match s with ++ | Filled (Some c) -> fprintf ppf {|;@ fillcolor="%a"|} color c; ++ | _ -> () ++ end; ++ | Decoration.Shape s -> fprintf ppf {|shape="%a"|} shape s ++ | Decoration.Label s -> ++ fprintf ppf {|label=<%a>|} (list ~sep:space string) s ++ ++ let inline_decoration ppf r = ++ match Decoration.decompose r with ++ | [] -> () ++ | l -> fprintf ppf "@[%a@]" (list ~sep:semi property) l ++ ++ let decoration ppf r = ++ match Decoration.decompose r with ++ | [] -> () ++ | l -> fprintf ppf "[@[%a@]]" (list ~sep:semi property) l ++ ++ let row_fixed ppf = function ++ | None -> fprintf ppf "" ++ | Some Types.Fixed_private -> fprintf ppf "private" ++ | Some Types.Rigid -> fprintf ppf "rigid" ++ | Some Types.Univar _t -> fprintf ppf "univar" ++ | Some Types.Reified _p -> fprintf ppf "reified" ++ ++ let field_kind ppf v = ++ match Types.field_kind_repr v with ++ | Fpublic -> fprintf ppf "public" ++ | Fabsent -> fprintf ppf "absent" ++ | Fprivate -> fprintf ppf "private" ++ ++ let index ppf = function ++ | Index.Main id -> fprintf ppf "i%d" id ++ | Index.Synthetic id -> fprintf ppf "s%d" id ++ | Index.Named_subnode r -> ++ fprintf ppf "%s%dRF%s" (if r.synth then "s" else "i") r.id r.name ++ ++ let prettier_index ppf = function ++ | Index.Main id -> fprintf ppf "%d" id ++ | Index.Synthetic id -> fprintf ppf "[%d]" id ++ | Index.Named_subnode r -> fprintf ppf "%d(%s)" r.id r.name ++ ++ let hyperedge_id ppf l = ++ let sep ppf () = fprintf ppf "h" in ++ let elt ppf (_,_,x) = index ppf x in ++ fprintf ppf "h%a" (list ~sep elt) l ++ ++ let node graph ppf x = ++ let d = graph.%(Node x) in ++ fprintf ppf "%a%a;@ " index x decoration d ++ ++ let edge graph ppf (x,y) = ++ let d = graph.%(Edge (x,y)) in ++ fprintf ppf "%a->%a%a;@ " index x index y decoration d ++ ++ let hyperedge graph ppf l = ++ let d = graph.%(Hyperedge l) in ++ fprintf ppf "%a%a;@ " hyperedge_id l decoration d; ++ List.iter (fun (dir,d,x) -> ++ match dir with ++ | From -> ++ fprintf ppf "%a->%a%a;@ " index x hyperedge_id l decoration d ++ | Toward -> ++ fprintf ppf "%a->%a%a;@ " hyperedge_id l index x decoration d ++ ) l ++ ++ let cluster_counter = ref 0 ++ let pp_cluster ppf = ++ incr cluster_counter; ++ fprintf ppf "cluster_%d" !cluster_counter ++ ++ let exponent_of_label ppf = function ++ | Asttypes.Nolabel -> () ++ | Asttypes.Labelled s -> fprintf ppf "%s" s ++ | Asttypes.Optional s -> fprintf ppf "?%s" s ++ ++ let pretty_var ppf name = ++ let name = Option.value ~default:"_" name in ++ let name' = ++ match name with ++ | "a" -> "𝛼" ++ | "b" -> "𝛽" ++ | "c" -> "𝛾" ++ | "d" -> "𝛿" ++ | "e" -> "𝜀" ++ | "f" -> "𝜑" ++ | "t" -> "𝜏" ++ | "r" -> "𝜌" ++ | "s" -> "𝜎" ++ | "p" -> "𝜋" ++ | "i" -> "𝜄" ++ | "h" -> "𝜂" ++ | "k" -> "𝜅" ++ | "l" -> "𝜆" ++ | "m" -> "𝜇" ++ | "x" -> "𝜒" ++ | "n" -> "𝜐" ++ | "o" -> "𝜔" ++ | name -> name ++ in ++ if name = name' then ++ fprintf ppf "'%s" name ++ else pp_print_string ppf name' ++ ++ let rec subgraph elts ppf (d,sg) = ++ fprintf ppf ++ "@[subgraph %t {@,\ ++ %a;@ \ ++ %a%a%a%a}@]@." ++ pp_cluster ++ inline_decoration d ++ (seq ~sep:empty (node elts)) (Node_set.to_seq sg.nodes) ++ (seq ~sep:empty (edge elts)) (Edge_set.to_seq sg.edges) ++ (seq ~sep:empty (hyperedge elts)) (Hyperedge_set.to_seq sg.hyperedges) ++ (list ~sep:empty (subgraph elts)) sg.subgraphes ++ ++ let graph ppf {elts;graph} = ++ fprintf ppf "@[digraph {@,%a%a%a%a}@]@." ++ (seq ~sep:empty (node elts)) (Node_set.to_seq graph.nodes) ++ (seq ~sep:empty (edge elts)) (Edge_set.to_seq graph.edges) ++ (seq ~sep:empty (hyperedge elts)) (Hyperedge_set.to_seq graph.hyperedges) ++ (list ~sep:empty (subgraph elts)) graph.subgraphes ++ ++end ++ ++ ++module Digraph = struct ++ ++ type t = digraph = { ++ elts: Decoration.r Elt_map.t; ++ graph: subgraph ++ } ++ ++ let empty = { elts = Elt_map.empty; graph = empty_subgraph } ++ ++ let add_to_subgraph s = function ++ | Node ty -> ++ let nodes = Node_set.add ty s.nodes in ++ { s with nodes } ++ | Edge (x,y) -> ++ let edges = Edge_set.add (x,y) s.edges in ++ { s with edges } ++ | Hyperedge l -> ++ let hyperedges = Hyperedge_set.add l s.hyperedges in ++ { s with hyperedges } ++ ++ let add_subgraph sub g = ++ { g with subgraphes = sub :: g.subgraphes } ++ ++ let add ?(override=false) d entry dg = ++ match Elt_map.find_opt entry dg.elts with ++ | Some d' -> ++ let d = ++ if override then Decoration.merge d d' ++ else Decoration.merge d' d ++ in ++ { dg with elts = Elt_map.add entry d dg.elts } ++ | None -> ++ let elts = Elt_map.add entry d dg.elts in ++ { elts; graph = add_to_subgraph dg.graph entry } ++ ++ let rec hyperedges_of_memo ty params id abbrev dg = ++ match abbrev with ++ | Types.Mnil -> dg ++ | Types.Mcons (_priv, _p, t1, t2, rem) -> ++ let s, dg = ty params t1 dg in ++ let exp, dg = ty params t2 dg in ++ dg |> ++ add memo ++ (Hyperedge ++ [From, dotted, id; ++ Toward, dotted, s; ++ Toward, Decoration.make [txt "expand"], exp ++ ]) ++ |> hyperedges_of_memo ty params id rem ++ | Types.Mlink rem -> hyperedges_of_memo ty params id !rem dg ++ ++ let rec edges_of_memo ty params abbrev dg = ++ match abbrev with ++ | Types.Mnil -> dg ++ | Types.Mcons (_priv, _p, t1, t2, rem) -> ++ let x, dg = ty params t1 dg in ++ let y, dg = ty params t2 dg in ++ dg |> add memo (Edge (x,y)) |> edges_of_memo ty params rem ++ | Types.Mlink rem -> edges_of_memo ty params !rem dg ++ ++ let expansions ty params id memo dg = ++ if params.expansion_as_hyperedge then ++ hyperedges_of_memo ty params id memo dg ++ else ++ edges_of_memo ty params memo dg ++ ++ let labelk k fmt = kasprintf (fun s -> k [txt s]) fmt ++ let labelf fmt = labelk Fun.id fmt ++ let labelr fmt = labelk Decoration.make fmt ++ ++ let add_node explicit_d color id tynode dg = ++ let d = labelf "%a" Pp.prettier_index id in ++ let d = match color with ++ | None -> Decoration.make d ++ | Some x -> Decoration.(make (filled x :: d)) ++ in ++ let d = Decoration.merge explicit_d d in ++ add d tynode dg ++ ++ let field_node color lbl rf = ++ let col = match color with ++ | None -> [] ++ | Some c -> [Decoration.Color c] ++ in ++ let pr_lbl ppf = match lbl with ++ | None -> () ++ | Some lbl -> fprintf ppf "`%s" lbl ++ in ++ let lbl = ++ Types.match_row_field ++ ~absent:(fun _ -> labelf "`-%t" pr_lbl) ++ ~present:(fun _ -> labelf ">%t" pr_lbl) ++ ~either:(fun c _tl m _e -> ++ labelf "%s%t%s" ++ (if m then "?" else "") ++ pr_lbl ++ (if c then "(∅)" else "") ++ ) ++ rf ++ in ++ Decoration.(make (Shape Diamond::col@lbl)) ++ ++ let group ty id0 lbl l dg = ++ match l with ++ | [] -> dg ++ | first :: l -> ++ let sub = { dg with graph = empty_subgraph } in ++ let id, sub = ty first sub in ++ let sub = List.fold_left (fun dg t -> snd (ty t dg)) sub l in ++ let dg = { sub with graph = add_subgraph (lbl,sub.graph) dg.graph } in ++ dg |> add std (Edge(id0,id)) ++ ++ let split_fresh_typ params ty0 g = ++ let (id, color, desc) = Index.split params ty0 in ++ let tynode = Node id in ++ if Elt_map.mem tynode g then id, None else id, Some (tynode,color,desc) ++ ++ let pp_path = Format_doc.compat Path.print ++ ++ let rec inject_typ params ty0 dg = ++ let id, next = split_fresh_typ params ty0 dg.elts in ++ match next with ++ | None -> id, dg ++ | Some (tynode,color,desc) -> ++ id, node params color id tynode desc dg ++ and edge params id0 lbl ty gh = ++ let id, gh = inject_typ params ty gh in ++ add lbl (Edge(id0,id)) gh ++ and poly_edge ~color params id0 gh ty = ++ let id, gh = inject_typ params ty gh in ++ match color with ++ | None -> add (labelr "bind") (Edge (id0,id)) gh ++ | Some c -> ++ let d = Decoration.(make [txt "bind"; Color c]) in ++ let gh = add d (Edge (id0,id)) gh in ++ add ~override:true Decoration.(make [filled c]) (Node id) gh ++ and numbered_edge params id0 (i,gh) ty = ++ let l = labelr "%d" i in ++ i + 1, edge params id0 l ty gh ++ and numbered_edges params id0 l gh = ++ snd @@ List.fold_left ++ (numbered_edge params id0) ++ (0,gh) l ++ and node params color id tynode desc dg = ++ let add_tynode l = add_node l color id tynode dg in ++ let mk fmt = labelk (fun l -> add_tynode (Decoration.make l)) fmt in ++ let numbered = numbered_edges params id in ++ let edge = edge params id in ++ let std_edge = edge std in ++ match desc with ++ | Types.Tvar name -> mk "%a" Pp.pretty_var name ++ | Types.Tarrow(l,t1,t2,_) -> ++ mk "→%a" Pp.exponent_of_label l |> numbered [t1; t2] ++ | Types.Ttuple tl -> ++ mk "*" |> numbered tl ++ | Types.Tconstr (p,tl,abbrevs) -> ++ let constr = mk "%a" pp_path p |> numbered tl in ++ if not params.follow_expansions then ++ constr ++ else ++ expansions inject_typ params id !abbrevs constr ++ | Types.Tobject (t, name) -> ++ let dg = ++ begin match !name with ++ | None -> mk "[obj]" ++ | Some (p,[]) -> (* invalid format *) ++ mk "[obj(%a)]" pp_path p ++ | Some (p, (rv_or_nil :: tl)) -> ++ match Types.get_desc rv_or_nil with ++ | Tnil -> ++ mk "[obj(%a)]" pp_path p |> std_edge t |> numbered tl ++ | _ -> ++ mk "[obj(#%a)]" pp_path p ++ |> edge (labelr "row variable") rv_or_nil ++ |> numbered tl ++ end ++ in ++ begin match split_fresh_typ params t dg.elts with ++ | _, None -> dg ++ | next_id, Some (_, color, desc) -> ++ group_fields ~params ~prev_id:id ++ dg.elts dg.graph empty_subgraph ++ ~id:next_id ~color ~desc ++ end ++ | Types.Tfield _ -> ++ group_fields ~params ~prev_id:id ++ dg.elts dg.graph empty_subgraph ++ ~color ~id ~desc ++ | Types.Tnil -> mk "[Nil]" ++ | Types.Tlink t -> add_tynode Decoration.(make [Style Dash]) |> std_edge t ++ | Types.Tsubst (t, o) -> ++ let dg = add_tynode (labelr "[Subst]") |> std_edge t in ++ begin match o with ++ | None -> dg ++ | Some row -> edge (labelr "parent polyvar") row dg ++ end ++ | Types.Tunivar name -> ++ mk "%a∀" Pp.pretty_var name ++ | Types.Tpoly (t, tl) -> ++ let dg = mk "∀" |> std_edge t in ++ List.fold_left (poly_edge ~color params id) dg tl ++ | Types.Tvariant row -> ++ let Row {fields; more; name; fixed; closed} = Types.row_repr row in ++ let closed = if closed then "closed" else "" in ++ let dg = match name with ++ | None -> mk "[Row%s]" closed ++ | Some (p,tl) -> ++ mk "[Row %a%s]" pp_path p closed ++ |> numbered tl ++ in ++ let more_lbl = labelr "%a row variable" Pp.row_fixed fixed in ++ let dg = dg |> edge more_lbl more in ++ let elts, main, fields = ++ List.fold_left (variant params id) ++ (dg.elts, dg.graph, empty_subgraph) ++ fields ++ in ++ { elts; graph = add_subgraph (labelr "polyvar", fields) main } ++ | Types.Tpackage (p, fl) -> ++ let types = List.map snd fl in ++ mk "[mod %a with %a]" ++ pp_path p ++ Pp.(list ~sep:semi longident) (List.map fst fl) ++ |> numbered types ++ and variant params id0 (elts,main,fields) (name,rf) = ++ let id = Index.subnode ~name id0 in ++ let fnode = Node id in ++ let color = Index.colorize params id in ++ let fgraph = { elts; graph=fields } in ++ let fgraph = add (field_node color (Some name) rf) fnode fgraph in ++ let { elts; graph=fields} = add dotted (Edge(id0,id)) fgraph in ++ let mgraph = { elts; graph=main } in ++ let {elts; graph=main} = ++ variant_inside params id rf mgraph ++ in ++ elts, main, fields ++ and variant_inside params id rf dg = ++ Types.match_row_field ++ ~absent:(fun () -> dg) ++ ~present:(function ++ | None -> dg ++ | Some arg -> numbered_edges params id [arg] dg ++ ) ++ ~either:(fun _ tl _ (cell,e) -> ++ let dg = match tl with ++ | [] -> dg ++ | [x] -> edge params id std x dg ++ | _ :: _ as tls -> ++ let label = Decoration.(make [txt "⋀"; filled lightgrey]) in ++ group (inject_typ params) id label tls dg ++ in ++ match e with ++ | None -> dg ++ | Some f -> ++ let id_ext = Index.either_ext cell in ++ let color = Index.colorize params id_ext in ++ let dg = add (field_node color None f) (Node id_ext) dg in ++ let dg = add std (Edge(id,id_ext)) dg in ++ variant_inside params id_ext f dg ++ ) ++ rf ++ and group_fields ~params ~prev_id elts main fields ++ ~color ~id ~desc = ++ let add_tynode dg l = add_node l color id (Node id) dg in ++ let mk dg fmt = labelk (fun l -> add_tynode dg (Decoration.make l)) fmt in ++ let merge elts ~main ~fields = ++ {elts; graph= add_subgraph (labelr "fields", fields) main } ++ in ++ match desc with ++ | Types.Tfield (f, k,typ, next) -> ++ let fgraph = { elts; graph=fields } in ++ let fgraph = mk fgraph "%s%a" f Pp.field_kind k in ++ let {elts; graph=fields} = add dotted (Edge (prev_id,id)) fgraph in ++ let {elts; graph=main} = ++ edge params id (labelr "method type") typ ++ {elts; graph= main} ++ in ++ let id_next, next = split_fresh_typ params next elts in ++ begin match next with ++ | None -> {elts; graph=main} ++ | Some (_,color,desc) -> ++ group_fields ~params ~prev_id:id ++ elts main fields ++ ~id:id_next ~desc ~color ++ end ++ | Types.Tvar name -> ++ let dg = mk {elts; graph= fields } "%a" Pp.pretty_var name in ++ let {elts; graph=fields} = ++ add (labelr "row variable") (Edge(prev_id,id)) dg ++ in ++ merge elts ~main ~fields ++ | Types.Tnil -> merge elts ~main ~fields ++ | _ -> ++ let dg = merge elts ~main ~fields in ++ node params color id (Node id) desc dg ++end ++ ++let params ++ ?(elide_links=true) ++ ?(expansion_as_hyperedge=false) ++ ?(short_ids=true) ++ ?(colorize=true) ++ ?(follow_expansions=true) ++ () = ++ { ++ expansion_as_hyperedge; ++ short_ids; ++ elide_links; ++ colorize; ++ follow_expansions; ++ } ++ ++let update_params ?elide_links ++ ?expansion_as_hyperedge ++ ?short_ids ++ ?colorize ++ ?follow_expansions ++ params = ++ { ++ elide_links = Option.value ~default:params.elide_links elide_links; ++ expansion_as_hyperedge = ++ Option.value ~default:params.expansion_as_hyperedge ++ expansion_as_hyperedge; ++ short_ids = Option.value ~default:params.short_ids short_ids; ++ colorize = Option.value ~default:params.colorize colorize; ++ follow_expansions = ++ Option.value ~default:params.follow_expansions follow_expansions; ++ } ++ ++ ++let translate params dg (label,entry) = ++ let node, dg = match entry with ++ | Node ty -> ++ let id, dg = Digraph.inject_typ params ty dg in ++ Node id, dg ++ | Edge (ty,ty') -> ++ let id, dg = Digraph.inject_typ params ty dg in ++ let id', dg = Digraph.inject_typ params ty' dg in ++ Edge(id,id'), dg ++ | Hyperedge l -> ++ let l, dg = List.fold_left (fun (l,dg) (d,lbl,ty) -> ++ let id, dg = Digraph.inject_typ params ty dg in ++ (d,lbl,id)::l, dg ++ ) ([],dg) l ++ in ++ Hyperedge l, dg ++ in ++ Digraph.add ~override:true label node dg ++ ++let add params ts dg = ++ List.fold_left (translate params) dg ts ++ ++ ++let make params ts = ++ add params ts Digraph.empty ++let pp = Pp.graph ++ ++let add_subgraph params d elts dg = ++ let sub = add params elts { dg with graph = empty_subgraph } in ++ { sub with graph = Digraph.add_subgraph (d,sub.graph) dg.graph } ++ ++let group_nodes (decoration, {graph=sub; elts=_}) ({elts;graph=main} as gmain) = ++ let nodes = Node_set.inter sub.nodes main.nodes in ++ if Node_set.cardinal nodes > 1 then ++ let sub = { empty_subgraph with nodes } in ++ let graph = ++ { main with ++ nodes = Node_set.diff main.nodes sub.nodes; ++ subgraphes = (decoration,sub) :: main.subgraphes ++ } ++ in { graph; elts} ++ else gmain ++ ++let file_counter = ref 0 ++ ++let compact_loc ppf (loc:Warnings.loc) = ++ let startline = loc.loc_start.pos_lnum in ++ let endline = loc.loc_end.pos_lnum in ++ let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in ++ let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in ++ if startline = endline then ++ fprintf ppf "l%d[%d-%d]" startline startchar endchar ++ else ++ fprintf ppf "l%d-%d[%d-%d]" startline endline startchar endchar ++ ++type 'a context = 'a option ref * (Format.formatter -> 'a -> unit) ++ ++let set_context (r,_pr) x = r := Some x ++let pp_context (r,pr) ppf = match !r with ++ | None -> () ++ | Some x -> fprintf ppf "%a" pr x ++ ++let with_context (r,_) x f = ++ let old = !r in ++ r:= Some x; ++ Fun.protect f ~finally:(fun () -> r := old) ++ ++let global = ref None, pp_print_string ++let loc = ref None, compact_loc ++let context = [pp_context global; pp_context loc] ++let dash ppf () = fprintf ppf "-" ++ ++let node_register = ref [] ++let register_type (label,ty) = ++ node_register := (label,Node ty) :: !node_register ++ ++let subgraph_register = ref [] ++let default_style = Decoration.(make [filled lightgrey]) ++let register_subgraph params ?(decoration=default_style) tys = ++ let node x = Decoration.none, Node x in ++ let subgraph = make params (List.map node tys) in ++ subgraph_register := (decoration, subgraph) :: !subgraph_register ++ ++let forget () = ++ node_register := []; ++ subgraph_register := [] ++ ++let node x = Node x ++let edge x y = Edge(x,y) ++let hyperedge l = Hyperedge l ++ ++let nodes ~title params ts = ++ incr file_counter; ++ let filename = ++ match !Clflags.dump_dir with ++ | None -> asprintf "%04d-%s.dot" !file_counter title ++ | Some d -> ++ asprintf "%s%s%04d-%s-%a.dot" ++ d Filename.dir_sep ++ !file_counter ++ title ++ Pp.(list ~sep:dash (fun ppf pr -> pr ppf)) context ++ in ++ Out_channel.with_open_bin filename (fun ch -> ++ let ppf = Format.formatter_of_out_channel ch in ++ let ts = List.map (fun (l,t) -> l, t) ts in ++ let g = make params (ts @ !node_register) in ++ let g = ++ List.fold_left (fun g sub -> group_nodes sub g) g !subgraph_register ++ in ++ Pp.graph ppf g ++ ) ++ ++let types ~title params ts = ++ nodes ~title params (List.map (fun (lbl,ty) -> lbl, Node ty) ts) ++ ++let make params elts = make params elts ++let add params elts = add params elts ++ ++ ++(** Debugging hooks *) ++let debug_on = ref (fun () -> false) ++let debug f = if !debug_on () then f () ++ ++let debug_off f = ++ let old = !debug_on in ++ debug_on := Fun.const false; ++ Fun.protect f ++ ~finally:(fun () -> debug_on := old) diff --git a/upstream/patches_503/typing/gprinttyp.mli.patch b/upstream/patches_503/typing/gprinttyp.mli.patch new file mode 100644 index 000000000..b0ea6cfe5 --- /dev/null +++ b/upstream/patches_503/typing/gprinttyp.mli.patch @@ -0,0 +1,328 @@ +--- ocaml_502/typing/gprinttyp.mli 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/typing/gprinttyp.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -0,0 +1,325 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Florian Angeletti, projet Cambium, Inria Paris *) ++(* *) ++(* Copyright 2024 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++(** ++ This module provides function for printing type expressions as digraph using ++ graphviz format. This is mostly aimed at providing a better representation ++ of type expressions during debugging session. ++*) ++(** ++A type node is printed as ++{[ ++ .------------. ++ | id |----> ++ | |---> ++ .------------. ++]} ++where the description part might be: ++- a path: [list/8!] ++- a type variable: ['name], [α], [β], [γ] ++- [*] for tuples ++- [→] for arrows type ++- an universal type variable: [[β]∀], ['name ∀], ... ++- [[mod X with ...]] for a first class module ++ ++- [∀] for a universal type binder ++ ++The more complex encoding for polymorphic variants and object types uses nodes ++as head of the subgraph representing those types ++ ++- [[obj...]] for the head of an object subgraph ++- [[Nil]] for the end of an object subgraph ++- [[Row...]] for the head of a polymorphic variant subgraph ++ ++- [[Subst]] for a temporary substitution node ++ ++Then each nodes is relied by arrows to any of its children types. ++ ++- Type variables, universal type variables, [Nil], and [Subst] nodes don't have ++ children. ++ ++- For tuples, the children types are the elements of the tuple. For instance, ++ [int * float] is represented as ++{[ ++ .------. 0 .-------. ++ | * 1 |-------->| int! 2| ++ .------. .-------. ++ | ++ | 1 ++ v ++ .----------. ++ | float! 3 | ++ .----------. ++]} ++ ++- For arrows, the children types are the type of the argument and the result ++ type. For instance, for [int -> float]: ++{[ ++ .------. 0 .-------. ++ | → 4 |-------->| int! 2| ++ .------. .-------. ++ | ++ | 1 ++ v ++ .----------. ++ | float! 3 | ++ .----------. ++]} ++ ++- For type constructor, like list the main children nodes are the argument ++ types. For instance, [(int,float) result] is represented as: ++ ++{[ ++ .-------------. 0 .-------. ++ | Result.t 5 |-------->| int! 2| ++ .-------------. .-------. ++ | ++ | 1 ++ v ++ .----------. ++ | float! 3 | ++ .----------. ++]} ++ ++Moreover, type abbreviations might be linked to the expanded nodes. ++If I define: [type 'a pair = 'a * 'a], a type expression [int pair] might ++correspond to the nodes: ++ ++{[ ++ .--------. 0 .--------. ++ | pair 6 |------> | int! 2 | ++ .--------. .--------. ++ ┆ ^ ++ ┆ expand | ++ ┆ | ++ .------. 0 + 1 | ++ | * 7 |------>-------. ++ .------. ++]} ++ ++- Universal type binders have two kind of children: bound variables, ++ and the main body. For instance, ['a. 'a -> 'a] is represented as ++{[ ++ ++ .------. bind .-------. ++ | ∀ 8 |----------> | 𝛼 10 | ++ .------. .------. ++ | ^ ++ | | ++ v | ++ .------. 0 + 1 | ++ | → 9 |------>-------. ++ .------. ++ ++]} ++ ++- [[Subst]] node are children are the type graph guarded by the ++ substitution node, and an eventual link to the parent row variable. ++ ++- The children of first-class modules are the type expressions that may appear ++ in the right hand side of constraints. ++ For instance, [module M with type t = 'a and type u = 'b] is represented as ++{[ ++ .----------------------. 0 .-----. ++ | [mod M with t, u] 11 |-------->| 𝛼 12| ++ .----------------------. .----- ++ | ++ | 1 ++ v ++ .------. ++ | 𝛽 13 | ++ .------. ++]} ++ ++ ++- The children of [obj] (resp. [row]) are the methods (resp. constructor) of the ++ object type (resp. polymorphic variant). Each method is then linked to its ++ type. To make them easier to read they are grouped inside graphviz cluster. ++ For instance, [ as 'self] will be represented as: ++ ++{[ ++ ++ .----------------. ++ | .----------. | ++ | | [obj] 14 |<------<-----<-----. ++ | .----------. | | ++ | ┆ | | ++ | .-------------. | .------. | .-------. ++ | | a public 15 |----->| ∀ 18 |----->| int! 2 | ++ | .-------------. | .------. | .-------. ++ | ┆ | | ++ | .-------------. | .------. | ++ | | m public 16 |-----| ∀ 19 |>--| ++ | .------------. | .------. ++ | ┆ | ++ | ┆ row var | ++ | ┆ | ++ | .-------. | ++ | | '_ 17 | | ++ | .-------. | ++ .-----------------. ++ ++]} ++*) ++ ++type digraph ++(** Digraph with nodes, edges, hyperedges and subgraphes *) ++ ++type params ++(** Various possible choices on how to represent types, see the {!params} ++ functions for more detail.*) ++ ++type element ++(** Graph element, see the {!node}, {!edge} and {!hyperedge} function *) ++ ++type decoration ++(** Visual decoration on graph elements, see the {!Decoration} module.*) ++ ++ ++val types: title:string -> params -> (decoration * Types.type_expr) list -> unit ++(** Print a graph to the file ++ [asprintf "%s/%04d-%s-%a.dot" ++ dump_dir ++ session_unique_id ++ title ++ pp_context context ++ ] ++ ++ If the [dump_dir] flag is not set, the local directory is used. ++ See the {!context} type on how and why to setup the context. *) ++ ++(** Full version of {!types} that allow to print any kind of graph element *) ++val nodes: title:string -> params -> (decoration * element) list -> unit ++ ++val params: ++ ?elide_links:bool -> ++ ?expansion_as_hyperedge:bool -> ++ ?short_ids:bool -> ++ ?colorize:bool -> ++ ?follow_expansions:bool -> ++ unit -> params ++(** Choice of details for printing type graphes: ++ - if [elide_links] is [true] link nodes are not displayed (default:[true]) ++ - with [expansion_as_hyperedge], memoized constructor expansion are ++ displayed as a hyperedge between the node storing the memoized expansion, ++ the expanded node and the expansion (default:[false]). ++ - with [short_ids], we use an independent counter for node ids, in order to ++ have shorter ids for small digraphs (default:[true]). ++ - with [colorize] nodes are colorized according to their typechecker ids ++ (default:[true]). ++ - with [follow_expansions], we add memoized type constructor expansions to ++ the digraph (default:[true]). ++*) ++ ++(** Update an existing [params] with new values. *) ++val update_params: ++ ?elide_links:bool -> ++ ?expansion_as_hyperedge:bool -> ++ ?short_ids:bool -> ++ ?colorize:bool -> ++ ?follow_expansions:bool -> ++ params -> params ++ ++val node: Types.type_expr -> element ++val edge: Types.type_expr -> Types.type_expr -> element ++ ++type dir = Toward | From ++val hyperedge: (dir * decoration * Types.type_expr) list -> element ++(** Edges between more than two elements. *) ++ ++(** {1 Node and decoration types} *) ++module Decoration: sig ++ type color = ++ | Named of string ++ | HSL of {h:float;s:float;l:float} ++ ++ val green: color ++ val blue: color ++ val red:color ++ val purple:color ++ val hsl: h:float -> s:float -> l:float -> color ++ ++ type style = ++ | Filled of color option ++ | Dotted ++ | Dash ++ ++ type shape = ++ | Ellipse ++ | Circle ++ | Diamond ++ ++ type property = ++ | Color of color ++ | Font_color of color ++ | Style of style ++ | Label of string list ++ | Shape of shape ++ val filled: color -> property ++ val txt: string -> property ++ val make: property list -> decoration ++end ++ ++(** {1 Digraph construction and printing}*) ++ ++val make: params -> (decoration * element) list -> digraph ++val add: params -> (decoration * element) list -> digraph -> digraph ++ ++(** add a subgraph to a digraph, only fresh nodes are added to the subgraph *) ++val add_subgraph: ++ params -> decoration -> (decoration * element) list -> digraph -> digraph ++ ++(** groups existing nodes inside a subgraph *) ++val group_nodes: decoration * digraph -> digraph -> digraph ++ ++val pp: Format.formatter -> digraph -> unit ++ ++ ++(** {1 Debugging helper functions } *) ++ ++(** {2 Generic print debugging function} *) ++ ++(** Conditional graph printing *) ++val debug_on: (unit -> bool) ref ++ ++(** [debug_off f] switches off debugging before running [f]. *) ++val debug_off: (unit -> 'a) -> 'a ++ ++(** [debug f] runs [f] when [!debug_on ()]*) ++val debug: (unit -> unit) -> unit ++ ++(** {2 Node tracking functions }*) ++ ++(** [register_type (lbl,ty)] adds the type [t] to all graph printed until ++ {!forget} is called *) ++val register_type: decoration * Types.type_expr -> unit ++ ++(** [register_subgraph params tys] groups together all types reachable from ++ [tys] at this point in printed digraphs, until {!forget} is called *) ++val register_subgraph: ++ params -> ?decoration:decoration -> Types.type_expr list -> unit ++ ++(** Forget all recorded context types *) ++val forget : unit -> unit ++ ++(** {2 Contextual information} ++ ++ Those functions can be used to modify the filename of the generated digraphs. ++ Use those functions to provide contextual information on a graph emitted ++ during an execution trace.*) ++type 'a context ++val global: string context ++val loc: Warnings.loc context ++val set_context: 'a context -> 'a -> unit ++val with_context: 'a context -> 'a -> (unit -> 'b) -> 'b diff --git a/upstream/patches_503/typing/ident.ml.patch b/upstream/patches_503/typing/ident.ml.patch new file mode 100644 index 000000000..02e813aa7 --- /dev/null +++ b/upstream/patches_503/typing/ident.ml.patch @@ -0,0 +1,54 @@ +--- ocaml_502/typing/ident.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/ident.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -16,7 +16,8 @@ + open Local_store + + let lowest_scope = 0 +-let highest_scope = 100000000 ++let highest_scope = 100_000_000 ++ (* assumed to fit in 27 bits, see Types.scope_field *) + + type t = + | Local of { name: string; stamp: int } +@@ -111,6 +112,9 @@ + | Scoped { stamp; _ } -> stamp + | _ -> 0 + ++let compare_stamp id1 id2 = ++ compare (stamp id1) (stamp id2) ++ + let scope = function + | Scoped { scope; _ } -> scope + | Local _ -> highest_scope +@@ -134,24 +138,24 @@ + | _ -> false + + let print ~with_scope ppf = +- let open Format in ++ let open Format_doc in + function + | Global name -> fprintf ppf "%s!" name + | Predef { name; stamp = n } -> + fprintf ppf "%s%s!" name +- (if !Clflags.unique_ids then sprintf "/%i" n else "") ++ (if !Clflags.unique_ids then asprintf "/%i" n else "") + | Local { name; stamp = n } -> + fprintf ppf "%s%s" name +- (if !Clflags.unique_ids then sprintf "/%i" n else "") ++ (if !Clflags.unique_ids then asprintf "/%i" n else "") + | Scoped { name; stamp = n; scope } -> + fprintf ppf "%s%s%s" name +- (if !Clflags.unique_ids then sprintf "/%i" n else "") +- (if with_scope then sprintf "[%i]" scope else "") ++ (if !Clflags.unique_ids then asprintf "/%i" n else "") ++ (if with_scope then asprintf "[%i]" scope else "") + + let print_with_scope ppf id = print ~with_scope:true ppf id + +-let print ppf id = print ~with_scope:false ppf id +- ++let doc_print ppf id = print ~with_scope:false ppf id ++let print ppf id = Format_doc.compat doc_print ppf id + (* For the documentation of ['a Ident.tbl], see ident.mli. + + The implementation is a copy-paste specialization of diff --git a/upstream/patches_503/typing/ident.mli.patch b/upstream/patches_503/typing/ident.mli.patch new file mode 100644 index 000000000..1e5acf501 --- /dev/null +++ b/upstream/patches_503/typing/ident.mli.patch @@ -0,0 +1,24 @@ +--- ocaml_502/typing/ident.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/ident.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -24,7 +24,8 @@ + - [compare] compares identifiers by binding location + *) + +-val print_with_scope : Format.formatter -> t -> unit ++val doc_print: t Format_doc.printer ++val print_with_scope : t Format_doc.printer + (** Same as {!print} except that it will also add a "[n]" suffix + if the scope of the argument is [n]. *) + +@@ -50,7 +51,11 @@ + [create_*], or if they are both persistent and have the same + name. *) + ++val compare_stamp: t -> t -> int ++ (** Compare only the internal stamps, 0 if absent *) ++ + val compare: t -> t -> int ++ (** Compare identifiers structurally, including the name *) + + val global: t -> bool + val is_predef: t -> bool diff --git a/upstream/patches_503/typing/includeclass.ml.patch b/upstream/patches_503/typing/includeclass.ml.patch new file mode 100644 index 000000000..6915f8bc5 --- /dev/null +++ b/upstream/patches_503/typing/includeclass.ml.patch @@ -0,0 +1,84 @@ +--- ocaml_502/typing/includeclass.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/includeclass.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -40,8 +40,9 @@ + cty1.cty_params cty1.cty_type + cty2.cty_params cty2.cty_type + +-open Format ++open Format_doc + open Ctype ++module Printtyp=Printtyp.Doc + + (* + let rec hide_params = function +@@ -50,6 +51,7 @@ + *) + + let include_err mode ppf = ++ let msg fmt = Format_doc.Doc.msg fmt in + function + | CM_Virtual_class -> + fprintf ppf "A class cannot be changed from virtual to concrete" +@@ -57,12 +59,10 @@ + fprintf ppf + "The classes do not have the same number of type parameters" + | CM_Type_parameter_mismatch (n, env, err) -> +- Printtyp.report_equality_error ppf mode env err +- (function ppf -> +- fprintf ppf "The %d%s type parameter has type" ++ Errortrace_report.equality ppf mode env err ++ (msg "The %d%s type parameter has type" + n (Misc.ordinal_suffix n)) +- (function ppf -> +- fprintf ppf "but is expected to have type") ++ (msg "but is expected to have type") + | CM_Class_type_mismatch (env, cty1, cty2) -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + fprintf ppf +@@ -71,24 +71,18 @@ + "is not matched by the class type" + Printtyp.class_type cty2) + | CM_Parameter_mismatch (n, env, err) -> +- Printtyp.report_moregen_error ppf mode env err +- (function ppf -> +- fprintf ppf "The %d%s parameter has type" ++ Errortrace_report.moregen ppf mode env err ++ (msg "The %d%s parameter has type" + n (Misc.ordinal_suffix n)) +- (function ppf -> +- fprintf ppf "but is expected to have type") ++ (msg "but is expected to have type") + | CM_Val_type_mismatch (lab, env, err) -> +- Printtyp.report_comparison_error ppf mode env err +- (function ppf -> +- fprintf ppf "The instance variable %s@ has type" lab) +- (function ppf -> +- fprintf ppf "but is expected to have type") ++ Errortrace_report.comparison ppf mode env err ++ (msg "The instance variable %s@ has type" lab) ++ (msg "but is expected to have type") + | CM_Meth_type_mismatch (lab, env, err) -> +- Printtyp.report_comparison_error ppf mode env err +- (function ppf -> +- fprintf ppf "The method %s@ has type" lab) +- (function ppf -> +- fprintf ppf "but is expected to have type") ++ Errortrace_report.comparison ppf mode env err ++ (msg "The method %s@ has type" lab) ++ (msg "but is expected to have type") + | CM_Non_mutable_value lab -> + fprintf ppf + "@[The non-mutable instance variable %s cannot become mutable@]" lab +@@ -110,9 +104,11 @@ + | CM_Private_method lab -> + fprintf ppf "@[The private method %s cannot become public@]" lab + +-let report_error mode ppf = function ++let report_error_doc mode ppf = function + | [] -> () + | err :: errs -> + let print_errs ppf errs = + List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in + fprintf ppf "@[%a%a@]" (include_err mode) err print_errs errs ++ ++let report_error mode = Format_doc.compat (report_error_doc mode) diff --git a/upstream/patches_503/typing/includeclass.mli.patch b/upstream/patches_503/typing/includeclass.mli.patch new file mode 100644 index 000000000..116c4779f --- /dev/null +++ b/upstream/patches_503/typing/includeclass.mli.patch @@ -0,0 +1,18 @@ +--- ocaml_502/typing/includeclass.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/includeclass.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -17,7 +17,6 @@ + + open Types + open Ctype +-open Format + + val class_types: + Env.t -> class_type -> class_type -> class_match_failure list +@@ -30,4 +29,6 @@ + class_match_failure list + + val report_error : +- Printtyp.type_or_scheme -> formatter -> class_match_failure list -> unit ++ Out_type.type_or_scheme -> class_match_failure list Format_doc.format_printer ++val report_error_doc : ++ Out_type.type_or_scheme -> class_match_failure list Format_doc.printer diff --git a/upstream/patches_503/typing/includecore.ml.patch b/upstream/patches_503/typing/includecore.ml.patch new file mode 100644 index 000000000..2485d0757 --- /dev/null +++ b/upstream/patches_503/typing/includecore.ml.patch @@ -0,0 +1,363 @@ +--- ocaml_502/typing/includecore.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/includecore.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -70,6 +70,26 @@ + + exception Dont_match of value_mismatch + ++(* A value description [vd1] is consistent with the value description [vd2] if ++ there is a context E such that [E |- vd1 <: vd2] for the ordinary subtyping. ++ For values, this is the case as soon as the kind of [vd1] is a subkind of the ++ [vd2] kind. *) ++let value_descriptions_consistency env vd1 vd2 = ++ match (vd1.val_kind, vd2.val_kind) with ++ | (Val_prim p1, Val_prim p2) -> begin ++ match primitive_descriptions p1 p2 with ++ | None -> Tcoerce_none ++ | Some err -> raise (Dont_match (Primitive_mismatch err)) ++ end ++ | (Val_prim p, _) -> ++ let pc = ++ { pc_desc = p; pc_type = vd2.Types.val_type; ++ pc_env = env; pc_loc = vd1.Types.val_loc; } ++ in ++ Tcoerce_primitive pc ++ | (_, Val_prim _) -> raise (Dont_match Not_a_primitive) ++ | (_, _) -> Tcoerce_none ++ + let value_descriptions ~loc env name + (vd1 : Types.value_description) + (vd2 : Types.value_description) = +@@ -81,22 +101,7 @@ + name; + match Ctype.moregeneral env true vd1.val_type vd2.val_type with + | exception Ctype.Moregen err -> raise (Dont_match (Type err)) +- | () -> begin +- match (vd1.val_kind, vd2.val_kind) with +- | (Val_prim p1, Val_prim p2) -> begin +- match primitive_descriptions p1 p2 with +- | None -> Tcoerce_none +- | Some err -> raise (Dont_match (Primitive_mismatch err)) +- end +- | (Val_prim p, _) -> +- let pc = +- { pc_desc = p; pc_type = vd2.Types.val_type; +- pc_env = env; pc_loc = vd1.Types.val_loc; } +- in +- Tcoerce_primitive pc +- | (_, Val_prim _) -> raise (Dont_match Not_a_primitive) +- | (_, _) -> Tcoerce_none +- end ++ | () -> value_descriptions_consistency env vd1 vd2 + + (* Inclusion between manifest types (particularly for private row types) *) + +@@ -203,9 +208,11 @@ + | Immediate of Type_immediacy.Violation.t + + module Style = Misc.Style ++module Fmt = Format_doc ++module Printtyp = Printtyp.Doc + + let report_primitive_mismatch first second ppf err = +- let pr fmt = Format.fprintf ppf fmt in ++ let pr fmt = Fmt.fprintf ppf fmt in + match (err : primitive_mismatch) with + | Name -> + pr "The names of the primitives are not the same" +@@ -226,7 +233,7 @@ + n (Misc.ordinal_suffix n) + + let report_value_mismatch first second env ppf err = +- let pr fmt = Format.fprintf ppf fmt in ++ let pr fmt = Fmt.fprintf ppf fmt in + pr "@ "; + match (err : value_mismatch) with + | Primitive_mismatch pm -> +@@ -234,14 +241,16 @@ + | Not_a_primitive -> + pr "The implementation is not a primitive." + | Type trace -> +- Printtyp.report_moregen_error ppf Type_scheme env trace +- (fun ppf -> Format.fprintf ppf "The type") +- (fun ppf -> Format.fprintf ppf "is not compatible with the type") ++ let msg = Fmt.Doc.msg in ++ Errortrace_report.moregen ppf Type_scheme env trace ++ (msg "The type") ++ (msg "is not compatible with the type") + + let report_type_inequality env ppf err = +- Printtyp.report_equality_error ppf Type_scheme env err +- (fun ppf -> Format.fprintf ppf "The type") +- (fun ppf -> Format.fprintf ppf "is not equal to the type") ++ let msg = Fmt.Doc.msg in ++ Errortrace_report.equality ppf Type_scheme env err ++ (msg "The type") ++ (msg "is not equal to the type") + + let report_privacy_mismatch ppf err = + let singular, item = +@@ -251,7 +260,7 @@ + | Private_record_type -> true, "record constructor" + | Private_extensible_variant -> true, "extensible variant" + | Private_row_type -> true, "row type" +- in Format.fprintf ppf "%s %s would be revealed." ++ in Format_doc.fprintf ppf "%s %s would be revealed." + (if singular then "A private" else "Private") + item + +@@ -260,20 +269,20 @@ + | Type err -> + report_type_inequality env ppf err + | Mutability ord -> +- Format.fprintf ppf "%s is mutable and %s is not." ++ Format_doc.fprintf ppf "%s is mutable and %s is not." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + + let pp_record_diff first second prefix decl env ppf (x : record_change) = + match x with + | Delete cd -> +- Format.fprintf ppf "%aAn extra field, %a, is provided in %s %s." ++ Fmt.fprintf ppf "%aAn extra field, %a, is provided in %s %s." + prefix x Style.inline_code (Ident.name cd.delete.ld_id) first decl + | Insert cd -> +- Format.fprintf ppf "%aA field, %a, is missing in %s %s." ++ Fmt.fprintf ppf "%aA field, %a, is missing in %s %s." + prefix x Style.inline_code (Ident.name cd.insert.ld_id) first decl + | Change Type {got=lbl1; expected=lbl2; reason} -> +- Format.fprintf ppf ++ Fmt.fprintf ppf + "@[%aFields do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" +@@ -282,34 +291,34 @@ + (Style.as_inline_code Printtyp.label) lbl2 + (report_label_mismatch first second env) reason + | Change Name n -> +- Format.fprintf ppf "%aFields have different names, %a and %a." ++ Fmt.fprintf ppf "%aFields have different names, %a and %a." + prefix x + Style.inline_code n.got + Style.inline_code n.expected + | Swap sw -> +- Format.fprintf ppf "%aFields %a and %a have been swapped." ++ Fmt.fprintf ppf "%aFields %a and %a have been swapped." + prefix x + Style.inline_code sw.first + Style.inline_code sw.last + | Move {name; got; expected } -> +- Format.fprintf ppf ++ Fmt.fprintf ppf + "@[<2>%aField %a has been moved@ from@ position %d@ to %d.@]" + prefix x Style.inline_code name expected got + + let report_patch pr_diff first second decl env ppf patch = +- let nl ppf () = Format.fprintf ppf "@," in ++ let nl ppf () = Fmt.fprintf ppf "@," in + let no_prefix _ppf _ = () in + match patch with + | [ elt ] -> +- Format.fprintf ppf "@[%a@]" ++ Fmt.fprintf ppf "@[%a@]" + (pr_diff first second no_prefix decl env) elt + | _ -> + let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in +- Format.fprintf ppf "@[%a@]" +- (Format.pp_print_list ~pp_sep:nl pp_diff) patch ++ Fmt.fprintf ppf "@[%a@]" ++ (Fmt.pp_print_list ~pp_sep:nl pp_diff) patch + + let report_record_mismatch first second decl env ppf err = +- let pr fmt = Format.fprintf ppf fmt in ++ let pr fmt = Fmt.fprintf ppf fmt in + match err with + | Label_mismatch patch -> + report_patch pp_record_diff first second decl env ppf patch +@@ -319,7 +328,7 @@ + "uses unboxed float representation" + + let report_constructor_mismatch first second decl env ppf err = +- let pr fmt = Format.fprintf ppf fmt in ++ let pr fmt = Fmt.fprintf ppf fmt in + match (err : constructor_mismatch) with + | Type err -> report_type_inequality env ppf err + | Arity -> pr "They have different arities." +@@ -337,13 +346,13 @@ + let pp_variant_diff first second prefix decl env ppf (x : variant_change) = + match x with + | Delete cd -> +- Format.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s." ++ Fmt.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s." + prefix x Style.inline_code (Ident.name cd.delete.cd_id) first decl + | Insert cd -> +- Format.fprintf ppf "%aA constructor, %a, is missing in %s %s." ++ Fmt.fprintf ppf "%aA constructor, %a, is missing in %s %s." + prefix x Style.inline_code (Ident.name cd.insert.cd_id) first decl + | Change Type {got; expected; reason} -> +- Format.fprintf ppf ++ Fmt.fprintf ppf + "@[%aConstructors do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" +@@ -352,24 +361,24 @@ + (Style.as_inline_code Printtyp.constructor) expected + (report_constructor_mismatch first second decl env) reason + | Change Name n -> +- Format.fprintf ppf ++ Fmt.fprintf ppf + "%aConstructors have different names, %a and %a." + prefix x + Style.inline_code n.got + Style.inline_code n.expected + | Swap sw -> +- Format.fprintf ppf ++ Fmt.fprintf ppf + "%aConstructors %a and %a have been swapped." + prefix x + Style.inline_code sw.first + Style.inline_code sw.last + | Move {name; got; expected} -> +- Format.fprintf ppf ++ Fmt.fprintf ppf + "@[<2>%aConstructor %a has been moved@ from@ position %d@ to %d.@]" + prefix x Style.inline_code name expected got + + let report_extension_constructor_mismatch first second decl env ppf err = +- let pr fmt = Format.fprintf ppf fmt in ++ let pr fmt = Fmt.fprintf ppf fmt in + match (err : extension_constructor_mismatch) with + | Constructor_privacy -> + pr "Private extension constructor(s) would be revealed." +@@ -385,8 +394,8 @@ + + + let report_private_variant_mismatch first second decl env ppf err = +- let pr fmt = Format.fprintf ppf fmt in +- let pp_tag ppf x = Format.fprintf ppf "`%s" x in ++ let pr fmt = Fmt.fprintf ppf fmt in ++ let pp_tag ppf x = Fmt.fprintf ppf "`%s" x in + match (err : private_variant_mismatch) with + | Only_outer_closed -> + (* It's only dangerous in one direction, so we don't have a position *) +@@ -403,14 +412,14 @@ + report_type_inequality env ppf err + + let report_private_object_mismatch env ppf err = +- let pr fmt = Format.fprintf ppf fmt in ++ let pr fmt = Fmt.fprintf ppf fmt in + match (err : private_object_mismatch) with + | Missing s -> + pr "The implementation is missing the method %a" Style.inline_code s + | Types err -> report_type_inequality env ppf err + + let report_kind_mismatch first second ppf (kind1, kind2) = +- let pr fmt = Format.fprintf ppf fmt in ++ let pr fmt = Fmt.fprintf ppf fmt in + let kind_to_string = function + | Kind_abstract -> "abstract" + | Kind_record -> "a record" +@@ -423,7 +432,7 @@ + (kind_to_string kind2) + + let report_type_mismatch first second decl env ppf err = +- let pr fmt = Format.fprintf ppf fmt in ++ let pr fmt = Fmt.fprintf ppf fmt in + pr "@ "; + match err with + | Arity -> +@@ -543,14 +552,37 @@ + | None -> Ok () + + let weight: Diff.change -> _ = function +- | Insert _ -> 10 +- | Delete _ -> 10 ++ | Insert _ | Delete _ -> ++ (* Insertion and deletion are symmetrical for definitions *) ++ 100 + | Keep _ -> 0 +- | Change (_,_,Diffing_with_keys.Name t ) -> +- if t.types_match then 10 else 15 +- | Change _ -> 10 +- +- ++ (* [Keep] must have the smallest weight. *) ++ | Change (_,_,c) -> ++ (* Constraints: ++ - [ Change < Insert + Delete ], otherwise [Change] are never optimal ++ ++ - [ Swap < Move ] => [ 2 Change < Insert + Delete ] => ++ [ Change < Delete ], in order to favour consecutive [Swap]s ++ over [Move]s. ++ ++ - For some D and a large enough R, ++ [Delete^D Keep^R Insert^D < Change^(D+R)] ++ => [ Change > (2 D)/(D+R) Delete ]. ++ Note that the case [D=1,R=1] is incompatible with the inequation ++ above. If we choose [R = D + 1] for [D<5], we can specialize the ++ inequation to [ Change > 10 / 11 Delete ]. *) ++ match c with ++ (* With [Type ++ if t.types_match then 98 else 99 ++ | Diffing_with_keys.Type _ -> 50 ++ (* With the uniqueness constraint on keys, the only relevant constraint ++ is [Type-only change < Name change]. Indeed, names can only match at ++ one position. In other words, if a [ Type ] patch is admissible, the ++ only admissible patches at this position are of the form [Delete^D ++ Name_change]. And with the constranit [Type_change < Name_change], ++ we have [Type_change Delete^D < Delete^D Name_change]. *) + + let key (x: Defs.left) = Ident.name x.ld_id + let diffing loc env params1 params2 cstrs_1 cstrs_2 = +@@ -662,13 +694,12 @@ + let update _ st = st + + let weight: D.change -> _ = function +- | Insert _ -> 10 +- | Delete _ -> 10 ++ | Insert _ | Delete _ -> 100 + | Keep _ -> 0 +- | Change (_,_,Diffing_with_keys.Name t) -> +- if t.types_match then 10 else 15 +- | Change _ -> 10 +- ++ | Change (_,_,Diffing_with_keys.Name c) -> ++ if c.types_match then 98 else 99 ++ | Change (_,_,Diffing_with_keys.Type _) -> 50 ++ (** See {!Variant_diffing.weight} for an explanation *) + + let test loc env (params1,params2) + ({pos; data=cd1}: D.left) +@@ -890,6 +921,17 @@ + | () -> None + end + ++(* A type declarations [td1] is consistent with the type declaration [td2] if ++ there is a context E such E |- td1 <: td2 for the ordinary subtyping. For ++ types, this is the case as soon as the two type declarations share the same ++ arity and the privacy of [td1] is less than the privacy of [td2] (consider a ++ context E where all type constructors are equal). *) ++let type_declarations_consistency env decl1 decl2 = ++ if decl1.type_arity <> decl2.type_arity then Some Arity ++ else match privacy_mismatch env decl1 decl2 with ++ | Some err -> Some (Privacy err) ++ | None -> None ++ + let type_declarations ?(equality = false) ~loc env ~mark name + decl1 path decl2 = + Builtin_attributes.check_alerts_inclusion +@@ -898,12 +940,7 @@ + loc + decl1.type_attributes decl2.type_attributes + name; +- if decl1.type_arity <> decl2.type_arity then Some Arity else +- let err = +- match privacy_mismatch env decl1 decl2 with +- | Some err -> Some (Privacy err) +- | None -> None +- in ++ let err = type_declarations_consistency env decl1 decl2 in + if err <> None then err else + let err = match (decl1.type_manifest, decl2.type_manifest) with + (_, None) -> diff --git a/upstream/patches_503/typing/includecore.mli.patch b/upstream/patches_503/typing/includecore.mli.patch new file mode 100644 index 000000000..8103d9252 --- /dev/null +++ b/upstream/patches_503/typing/includecore.mli.patch @@ -0,0 +1,42 @@ +--- ocaml_502/typing/includecore.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/includecore.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -118,6 +118,21 @@ + loc:Location.t -> Env.t -> mark:bool -> Ident.t -> + extension_constructor -> extension_constructor -> + extension_constructor_mismatch option ++ ++(** The functions [value_descriptions_consistency] and ++ [type_declarations_consistency] check if two declaration are consistent. ++ Declarations are consistent when there exists an environment such that the ++ first declaration is a subtype of the second one. ++ ++ Notably, if a type declaration [td1] is consistent with [td2] then a type ++ expression [te] which is well-formed with the [td2] declaration in scope ++ is still well-formed with the [td1] declaration: [E, td2 |- te] => [E, td1 ++ |- te]. *) ++val value_descriptions_consistency: ++ Env.t -> value_description -> value_description -> module_coercion ++val type_declarations_consistency: ++ Env.t -> type_declaration -> type_declaration -> type_mismatch option ++ + (* + val class_types: + Env.t -> class_type -> class_type -> bool +@@ -126,14 +141,14 @@ + val report_value_mismatch : + string -> string -> + Env.t -> +- Format.formatter -> value_mismatch -> unit ++ value_mismatch Format_doc.printer + + val report_type_mismatch : + string -> string -> string -> + Env.t -> +- Format.formatter -> type_mismatch -> unit ++ type_mismatch Format_doc.printer + + val report_extension_constructor_mismatch : + string -> string -> string -> + Env.t -> +- Format.formatter -> extension_constructor_mismatch -> unit ++ extension_constructor_mismatch Format_doc.printer diff --git a/upstream/patches_503/typing/includemod.ml.patch b/upstream/patches_503/typing/includemod.ml.patch new file mode 100644 index 000000000..9136a2f0a --- /dev/null +++ b/upstream/patches_503/typing/includemod.ml.patch @@ -0,0 +1,609 @@ +--- ocaml_502/typing/includemod.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/includemod.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -150,62 +150,64 @@ + | Mark_both | Mark_positive -> true + | Mark_negative | Mark_neither -> false + +-(* All functions "blah env x1 x2" check that x1 is included in x2, +- i.e. that x1 is the type of an implementation that fulfills the +- specification x2. If not, Error is raised with a backtrace of the error. *) +- +-(* Inclusion between value descriptions *) +- +-let value_descriptions ~loc env ~mark subst id vd1 vd2 = +- Cmt_format.record_value_dependency vd1 vd2; +- if mark_positive mark then +- Env.mark_value_used vd1.val_uid; +- let vd2 = Subst.value_description subst vd2 in +- try +- Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2) +- with Includecore.Dont_match err -> +- Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) +- +-(* Inclusion between type declarations *) +- +-let type_declarations ~loc env ~mark ?old_env:_ subst id decl1 decl2 = +- let mark = mark_positive mark in +- if mark then +- Env.mark_type_used decl1.type_uid; +- let decl2 = Subst.type_declaration subst decl2 in +- match +- Includecore.type_declarations ~loc env ~mark +- (Ident.name id) decl1 (Path.Pident id) decl2 +- with +- | None -> Ok Tcoerce_none +- | Some err -> +- Error Error.(Core(Type_declarations (diff decl1 decl2 err))) +- +-(* Inclusion between extension constructors *) +- +-let extension_constructors ~loc env ~mark subst id ext1 ext2 = +- let mark = mark_positive mark in +- let ext2 = Subst.extension_constructor subst ext2 in +- match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with +- | None -> Ok Tcoerce_none +- | Some err -> +- Error Error.(Core(Extension_constructors(diff ext1 ext2 err))) +- +-(* Inclusion between class declarations *) +- +-let class_type_declarations ~loc ~old_env:_ env subst decl1 decl2 = +- let decl2 = Subst.cltype_declaration subst decl2 in +- match Includeclass.class_type_declarations ~loc env decl1 decl2 with +- [] -> Ok Tcoerce_none +- | reason -> +- Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason))) +- +-let class_declarations ~old_env:_ env subst decl1 decl2 = +- let decl2 = Subst.class_declaration subst decl2 in +- match Includeclass.class_declarations env decl1 decl2 with +- [] -> Ok Tcoerce_none +- | reason -> +- Error Error.(Core(Class_declarations(diff decl1 decl2 reason))) ++module Core_inclusion = struct ++ (* All functions "blah env x1 x2" check that x1 is included in x2, ++ i.e. that x1 is the type of an implementation that fulfills the ++ specification x2. If not, Error is raised with a backtrace of the error. *) ++ ++ (* Inclusion between value descriptions *) ++ ++ let value_descriptions ~loc env ~mark subst id vd1 vd2 = ++ Cmt_format.record_value_dependency vd1 vd2; ++ if mark_positive mark then ++ Env.mark_value_used vd1.val_uid; ++ let vd2 = Subst.value_description subst vd2 in ++ try ++ Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2) ++ with Includecore.Dont_match err -> ++ Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) ++ ++ (* Inclusion between type declarations *) ++ ++ let type_declarations ~loc env ~mark subst id decl1 decl2 = ++ let mark = mark_positive mark in ++ if mark then ++ Env.mark_type_used decl1.type_uid; ++ let decl2 = Subst.type_declaration subst decl2 in ++ match ++ Includecore.type_declarations ~loc env ~mark ++ (Ident.name id) decl1 (Path.Pident id) decl2 ++ with ++ | None -> Ok Tcoerce_none ++ | Some err -> ++ Error Error.(Core(Type_declarations (diff decl1 decl2 err))) ++ ++ (* Inclusion between extension constructors *) ++ ++ let extension_constructors ~loc env ~mark subst id ext1 ext2 = ++ let mark = mark_positive mark in ++ let ext2 = Subst.extension_constructor subst ext2 in ++ match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with ++ | None -> Ok Tcoerce_none ++ | Some err -> ++ Error Error.(Core(Extension_constructors(diff ext1 ext2 err))) ++ ++ (* Inclusion between class declarations *) ++ ++ let class_type_declarations ~loc env ~mark:_ subst _id decl1 decl2 = ++ let decl2 = Subst.cltype_declaration subst decl2 in ++ match Includeclass.class_type_declarations ~loc env decl1 decl2 with ++ [] -> Ok Tcoerce_none ++ | reason -> ++ Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason))) ++ ++ let class_declarations ~loc:_ env ~mark:_ subst _id decl1 decl2 = ++ let decl2 = Subst.class_declaration subst decl2 in ++ match Includeclass.class_declarations env decl1 decl2 with ++ [] -> Ok Tcoerce_none ++ | reason -> ++ Error Error.(Core(Class_declarations(diff decl1 decl2 reason))) ++end + + (* Expand a module type identifier when possible *) + +@@ -308,7 +310,7 @@ + print_coercion out + | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> + pr "prim %s@ (%a)" pc_desc.Primitive.prim_name +- Printtyp.raw_type_expr pc_type ++ Rawprinttyp.type_expr pc_type + | Tcoerce_alias (_, p, c) -> + pr "@[<2>alias %a@ (%a)@]" + Printtyp.path p +@@ -406,6 +408,24 @@ + } + end + ++(** Core type system subtyping-like relation that we want to lift at the module ++ level. We have two relations that we want to lift: ++ ++ - the normal subtyping relation [<:]. ++ - the coarse-grain consistency relation [C], which is defined by ++ [d1 C d2] if there is an environment [E] such that [E |- d1 <: d2]. *) ++type 'a core_incl = ++ loc:Location.t -> Env.t -> mark:mark -> Subst.t -> Ident.t -> ++ 'a -> 'a -> (module_coercion, Error.sigitem_symptom) result ++ ++type core_relation = { ++ value_descriptions: Types.value_description core_incl; ++ type_declarations: Types.type_declaration core_incl; ++ extension_constructors: Types.extension_constructor core_incl; ++ class_declarations: Types.class_declaration core_incl; ++ class_type_declarations: Types.class_type_declaration core_incl; ++} ++ + (** + In the group of mutual functions below, the [~in_eq] argument is [true] when + we are in fact checking equality of module types. +@@ -422,14 +442,14 @@ + described above. + *) + +-let rec modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape = +- match try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape with ++let rec modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape = ++ match try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape with + | Ok _ as ok -> ok + | Error reason -> + let mty2 = Subst.modtype Make_local subst mty2 in + Error Error.(diff mty1 mty2 reason) + +-and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = ++and try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = + match mty1, mty2 with + | (Mty_alias p1, Mty_alias p2) -> + if Env.is_functor_arg p2 env then +@@ -447,8 +467,8 @@ + begin match expand_module_alias ~strengthen:false env p1 with + | Error e -> Error (Error.Mt_core e) + | Ok mty1 -> +- match strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark +- subst mty1 p1 mty2 orig_shape ++ match strengthened_modtypes ~core ~in_eq ~loc ~aliasable:true env ++ ~mark subst mty1 p1 mty2 orig_shape + with + | Ok _ as x -> x + | Error reason -> Error (Error.After_alias_expansion reason) +@@ -461,20 +481,21 @@ + else + begin match expand_modtype_path env p1, expand_modtype_path env p2 with + | Some mty1, Some mty2 -> +- try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape ++ try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape + | None, _ | _, None -> Error (Error.Mt_core Abstract_module_type) + end + | (Mty_ident p1, _) -> + let p1 = Env.normalize_modtype_path env p1 in + begin match expand_modtype_path env p1 with + | Some p1 -> +- try_modtypes ~in_eq ~loc env ~mark subst p1 mty2 orig_shape ++ try_modtypes ~core ~in_eq ~loc env ~mark subst p1 mty2 orig_shape + | None -> Error (Error.Mt_core Abstract_module_type) + end + | (_, Mty_ident p2) -> + let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in + begin match expand_modtype_path env p2 with +- | Some p2 -> try_modtypes ~in_eq ~loc env ~mark subst mty1 p2 orig_shape ++ | Some p2 -> ++ try_modtypes ~core ~in_eq ~loc env ~mark subst mty1 p2 orig_shape + | None -> + begin match mty1 with + | Mty_functor _ -> +@@ -486,14 +507,14 @@ + end + | (Mty_signature sig1, Mty_signature sig2) -> + begin match +- signatures ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape ++ signatures ~core ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape + with + | Ok _ as ok -> ok + | Error e -> Error (Error.Signature e) + end + | Mty_functor (param1, res1), Mty_functor (param2, res2) -> + let cc_arg, env, subst = +- functor_param ~in_eq ~loc env ~mark:(negate_mark mark) ++ functor_param ~core ~in_eq ~loc env ~mark:(negate_mark mark) + subst param1 param2 + in + let var, res_shape = +@@ -501,16 +522,18 @@ + | Some (var, res_shape) -> var, res_shape + | None -> + (* Using a fresh variable with a placeholder uid here is fine: users +- will never try to jump to the definition of that variable. +- If they try to jump to the parameter from inside the functor, +- they will use the variable shape that is stored in the local +- environment. *) ++ will never try to jump to the definition of that variable. If ++ they try to jump to the parameter from inside the functor, they ++ will use the variable shape that is stored in the local ++ environment. *) + let var, shape_var = + Shape.fresh_var Uid.internal_not_actually_unique + in + var, Shape.app orig_shape ~arg:shape_var + in +- let cc_res = modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape in ++ let cc_res = ++ modtypes ~core ~in_eq ~loc env ~mark subst res1 res2 res_shape ++ in + begin match cc_arg, cc_res with + | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) -> + let final_shape = +@@ -552,7 +575,7 @@ + + (* Functor parameters *) + +-and functor_param ~in_eq ~loc env ~mark subst param1 param2 = ++and functor_param ~core ~in_eq ~loc env ~mark subst param1 param2 = + match param1, param2 with + | Unit, Unit -> + Ok Tcoerce_none, env, subst +@@ -560,7 +583,7 @@ + let arg2' = Subst.modtype Keep subst arg2 in + let cc_arg = + match +- modtypes ~in_eq ~loc env ~mark Subst.identity arg2' arg1 ++ modtypes ~core ~in_eq ~loc env ~mark Subst.identity arg2' arg1 + Shape.dummy_mod + with + | Ok (cc, _) -> Ok cc +@@ -588,27 +611,28 @@ + | None, None -> + env, subst + +-and strengthened_modtypes ~in_eq ~loc ~aliasable env ~mark ++and strengthened_modtypes ~core ~in_eq ~loc ~aliasable env ~mark + subst mty1 path1 mty2 shape = + match mty1, mty2 with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in +- modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape ++ modtypes ~core ~in_eq ~loc env ~mark subst mty1 mty2 shape + +-and strengthened_module_decl ~loc ~aliasable env ~mark ++and strengthened_module_decl ~core ~loc ~aliasable env ~mark + subst md1 path1 md2 shape = + match md1.md_type, md2.md_type with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in +- modtypes ~in_eq:false ~loc env ~mark subst md1.md_type md2.md_type shape ++ modtypes ~core ~in_eq:false ~loc env ~mark subst ++ md1.md_type md2.md_type shape + + (* Inclusion between signatures *) + +-and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = ++and signatures ~core ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = + (* Environment used to check inclusion of components *) + let new_env = + Env.add_signature sig1 (Env.in_signature true env) in +@@ -653,12 +677,12 @@ + Return a coercion list indicating, for all run-time components + of sig2, the position of the matching run-time components of sig1 + and the coercion to be applied to it. *) +- let rec pair_components subst paired unpaired = function ++ let rec pair_components ~core subst paired unpaired = function + [] -> + let open Sign_diff in + let d = +- signature_components ~in_eq ~loc env ~mark new_env subst mod_shape +- Shape.Map.empty ++ signature_components ~core ~in_eq ~loc env ~mark new_env subst ++ mod_shape Shape.Map.empty + (List.rev paired) + in + begin match unpaired, d.errors, d.runtime_coercions, d.leftovers with +@@ -707,21 +731,21 @@ + | Sig_class _ | Sig_class_type _ -> + subst + in +- pair_components new_subst ++ pair_components ~core new_subst + ((item1, item2, pos1) :: paired) unpaired rem + | exception Not_found -> + let unpaired = + if report then + item2 :: unpaired + else unpaired in +- pair_components subst paired unpaired rem ++ pair_components ~core subst paired unpaired rem + end in + (* Do the pairing and checking, and return the final coercion *) +- pair_components subst [] [] sig2 ++ pair_components ~core subst [] [] sig2 + + (* Inclusion between signature components *) + +-and signature_components ~in_eq ~loc old_env ~mark env subst ++and signature_components ~core ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map paired = + match paired with + | [] -> Sign_diff.{ empty with shape_map } +@@ -731,7 +755,8 @@ + match sigi1, sigi2 with + | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) -> + let item = +- value_descriptions ~loc env ~mark subst id1 valdecl1 valdecl2 ++ core.value_descriptions ~loc env ~mark subst id1 ++ valdecl1 valdecl2 + in + let item = mark_error_as_recoverable item in + let present_at_runtime = match valdecl2.val_kind with +@@ -742,7 +767,7 @@ + id1, item, shape_map, present_at_runtime + | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) -> + let item = +- type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2 ++ core.type_declarations ~loc env ~mark subst id1 tydec1 tydec2 + in + let item = mark_error_as_unrecoverable item in + (* Right now we don't filter hidden constructors / labels from the +@@ -751,7 +776,7 @@ + id1, item, shape_map, false + | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> + let item = +- extension_constructors ~loc env ~mark subst id1 ext1 ext2 ++ core.extension_constructors ~loc env ~mark subst id1 ext1 ext2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = +@@ -764,8 +789,8 @@ + Shape.(proj orig_shape (Item.module_ id1)) + in + let item = +- module_declarations ~in_eq ~loc env ~mark subst id1 mty1 mty2 +- orig_shape ++ module_declarations ~core ~in_eq ~loc env ~mark subst id1 ++ mty1 mty2 orig_shape + in + let item, shape_map = + match item with +@@ -793,7 +818,7 @@ + end + | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> + let item = +- modtype_infos ~in_eq ~loc env ~mark subst id1 info1 info2 ++ modtype_infos ~core ~in_eq ~loc env ~mark subst id1 info1 info2 + in + let shape_map = + Shape.Map.add_module_type_proj shape_map id1 orig_shape +@@ -802,7 +827,7 @@ + id1, item, shape_map, false + | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> + let item = +- class_declarations ~old_env env subst decl1 decl2 ++ core.class_declarations ~loc env ~mark subst id1 decl1 decl2 + in + let shape_map = + Shape.Map.add_class_proj shape_map id1 orig_shape +@@ -811,7 +836,7 @@ + id1, item, shape_map, true + | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> + let item = +- class_type_declarations ~loc ~old_env env subst info1 info2 ++ core.class_type_declarations ~loc env ~mark subst id1 info1 info2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = +@@ -838,7 +863,7 @@ + in + let rest = + if continue then +- signature_components ~in_eq ~loc old_env ~mark env subst ++ signature_components ~core ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map rem + else Sign_diff.{ empty with leftovers=rem } + in +@@ -859,7 +884,7 @@ + + (* Inclusion between module type specifications *) + +-and modtype_infos ~in_eq ~loc env ~mark subst id info1 info2 = ++and modtype_infos ~core ~in_eq ~loc env ~mark subst id info1 info2 = + Builtin_attributes.check_alerts_inclusion + ~def:info1.mtd_loc + ~use:info2.mtd_loc +@@ -872,17 +897,18 @@ + (None, None) -> Ok Tcoerce_none + | (Some _, None) -> Ok Tcoerce_none + | (Some mty1, Some mty2) -> +- check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 ++ check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 + | (None, Some mty2) -> + let mty1 = Mty_ident(Path.Pident id) in +- check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 in ++ check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 in + match r with + | Ok _ as ok -> ok + | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e)) + +-and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = ++and check_modtype_equiv ~core ~in_eq ~loc env ~mark mty1 mty2 = + let c1 = +- modtypes ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 Shape.dummy_mod ++ modtypes ~core ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 ++ Shape.dummy_mod + in + let c2 = + (* For nested module type paths, we check only one side of the equivalence: +@@ -893,7 +919,7 @@ + else + let mark = negate_mark mark in + Some ( +- modtypes ~in_eq:true ~loc env ~mark Subst.identity ++ modtypes ~core ~in_eq:true ~loc env ~mark Subst.identity + mty2 mty1 Shape.dummy_mod + ) + in +@@ -919,7 +945,34 @@ + in + no_apply path && not (Env.is_functor_arg path env) + +- ++let core_inclusion = Core_inclusion.{ ++ type_declarations; ++ value_descriptions; ++ extension_constructors; ++ class_type_declarations; ++ class_declarations; ++} ++ ++let core_consistency = ++ let type_declarations ~loc:_ env ~mark:_ _ _ d1 d2 = ++ match Includecore.type_declarations_consistency env d1 d2 with ++ | None -> Ok Tcoerce_none ++ | Some err -> Error Error.(Core(Type_declarations (diff d1 d2 err))) ++ in ++ let value_descriptions ~loc:_ env ~mark:_ _ _ vd1 vd2 = ++ match Includecore.value_descriptions_consistency env vd1 vd2 with ++ | x -> Ok x ++ | exception Includecore.Dont_match err -> ++ Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) ++ in ++ let accept ~loc:_ _env ~mark:_ _subst _id _d1 _d2 = Ok Tcoerce_none in ++ { ++ type_declarations; ++ value_descriptions; ++ class_declarations=accept; ++ class_type_declarations=accept; ++ extension_constructors=accept; ++ } + + type explanation = Env.t * Error.all + exception Error of explanation +@@ -938,8 +991,8 @@ + + let check_modtype_inclusion_raw ~loc env mty1 path1 mty2 = + let aliasable = can_alias env path1 in +- strengthened_modtypes ~in_eq:false ~loc ~aliasable env ~mark:Mark_both +- Subst.identity mty1 path1 mty2 Shape.dummy_mod ++ strengthened_modtypes ~core:core_inclusion ~in_eq:false ~loc ~aliasable env ++ ~mark:Mark_both Subst.identity mty1 path1 mty2 Shape.dummy_mod + |> Result.map fst + + let check_modtype_inclusion ~loc env mty1 path1 mty2 = +@@ -974,9 +1027,10 @@ + interface. *) + + let compunit env ~mark impl_name impl_sig intf_name intf_sig unit_shape = ++ let loc = Location.in_file impl_name in + match +- signatures ~in_eq:false ~loc:(Location.in_file impl_name) env ~mark +- Subst.identity impl_sig intf_sig unit_shape ++ signatures ~core:core_inclusion ~in_eq:false ~loc env ++ ~mark Subst.identity impl_sig intf_sig unit_shape + with Result.Error reasons -> + let cdiff = + Error.In_Compilation_unit(Error.diff impl_name intf_name reasons) in +@@ -1079,8 +1133,8 @@ + let test st mty1 mty2 = + let loc = Location.none in + let res, _, _ = +- functor_param ~in_eq:false ~loc st.env ~mark:Mark_neither +- st.subst mty1 mty2 ++ functor_param ~core:core_inclusion ~in_eq:false ~loc st.env ++ ~mark:Mark_neither st.subst mty1 mty2 + in + res + let update = update +@@ -1174,8 +1228,9 @@ + Result.Error (Error.Incompatible_params(arg,param)) + | ( Anonymous | Named _ | Empty_struct ), Named (_, param) -> + match +- modtypes ~in_eq:false ~loc state.env ~mark:Mark_neither +- state.subst arg_mty param Shape.dummy_mod ++ modtypes ~core:core_inclusion ~in_eq:false ~loc state.env ++ ~mark:Mark_neither state.subst arg_mty param ++ Shape.dummy_mod + with + | Error mty -> Result.Error (Error.Mismatch mty) + | Ok (cc, _) -> Ok cc +@@ -1196,36 +1251,45 @@ + (* Hide the context and substitution parameters to the outside world *) + + let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 = +- match modtypes ~in_eq:false ~loc env ~mark ++ match modtypes ~core:core_inclusion ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 shape + with + | Ok (cc, shape) -> cc, shape + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + ++let modtypes_consistency ~loc env mty1 mty2 = ++ match modtypes ~core:core_consistency ~in_eq:false ~loc env ~mark:Mark_neither ++ Subst.identity mty1 mty2 Shape.dummy_mod ++ with ++ | Ok _ -> () ++ | Error reason -> raise (Error (env, Error.(In_Module_type reason))) ++ + let modtypes ~loc env ~mark mty1 mty2 = +- match modtypes ~in_eq:false ~loc env ~mark ++ match modtypes ~core:core_inclusion ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + + let signatures env ~mark sig1 sig2 = +- match signatures ~in_eq:false ~loc:Location.none env ~mark +- Subst.identity sig1 sig2 Shape.dummy_mod ++ match signatures ~core:core_inclusion ~in_eq:false ~loc:Location.none env ++ ~mark Subst.identity sig1 sig2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error(env,Error.(In_Signature reason))) + + let type_declarations ~loc env ~mark id decl1 decl2 = +- match type_declarations ~loc env ~mark Subst.identity id decl1 decl2 with ++ match Core_inclusion.type_declarations ~loc env ~mark ++ Subst.identity id decl1 decl2 ++ with + | Ok _ -> () + | Error (Error.Core reason) -> + raise (Error(env,Error.(In_Type_declaration(id,reason)))) + | Error _ -> assert false + + let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 = +- match strengthened_module_decl ~loc ~aliasable env ~mark Subst.identity +- md1 path1 md2 Shape.dummy_mod with ++ match strengthened_module_decl ~core:core_inclusion ~loc ~aliasable env ~mark ++ Subst.identity md1 path1 md2 Shape.dummy_mod with + | Ok (x, _shape) -> x + | Error mdiff -> + raise (Error(env,Error.(In_Module_type mdiff))) +@@ -1237,7 +1301,9 @@ + raise (Error(env,In_Expansion(Error.Unbound_module_path path))) + + let check_modtype_equiv ~loc env id mty1 mty2 = +- match check_modtype_equiv ~in_eq:false ~loc env ~mark:Mark_both mty1 mty2 with ++ match check_modtype_equiv ~core:core_inclusion ~in_eq:false ~loc env ++ ~mark:Mark_both mty1 mty2 ++ with + | Ok _ -> () + | Error e -> + raise (Error(env, diff --git a/upstream/patches_503/typing/includemod.mli.patch b/upstream/patches_503/typing/includemod.mli.patch new file mode 100644 index 000000000..c96aa3273 --- /dev/null +++ b/upstream/patches_503/typing/includemod.mli.patch @@ -0,0 +1,13 @@ +--- ocaml_502/typing/includemod.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/includemod.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -155,6 +155,10 @@ + loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion + ++ ++val modtypes_consistency: ++ loc:Location.t -> Env.t -> module_type -> module_type -> unit ++ + val modtypes_with_shape: + shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion * Shape.t diff --git a/upstream/patches_503/typing/includemod_errorprinter.ml.patch b/upstream/patches_503/typing/includemod_errorprinter.ml.patch new file mode 100644 index 000000000..6cea68a99 --- /dev/null +++ b/upstream/patches_503/typing/includemod_errorprinter.ml.patch @@ -0,0 +1,795 @@ +--- ocaml_502/typing/includemod_errorprinter.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/includemod_errorprinter.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -14,6 +14,8 @@ + (**************************************************************************) + + module Style = Misc.Style ++module Fmt = Format_doc ++module Printtyp = Printtyp.Doc + + module Context = struct + type pos = +@@ -34,28 +36,28 @@ + + let rec context ppf = function + Module id :: rem -> +- Format.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem ++ Fmt.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem + | Modtype id :: rem -> +- Format.fprintf ppf "@[<2>module type %a =@ %a@]" ++ Fmt.fprintf ppf "@[<2>module type %a =@ %a@]" + Printtyp.ident id context_mty rem + | Body x :: rem -> +- Format.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem ++ Fmt.fprintf ppf "(%s) ->@ %a" (argname x) context_mty rem + | Arg x :: rem -> +- Format.fprintf ppf "functor (%s : %a) -> ..." ++ Fmt.fprintf ppf "(%s : %a) -> ..." + (argname x) context_mty rem + | [] -> +- Format.fprintf ppf "" ++ Fmt.fprintf ppf "" + and context_mty ppf = function + (Module _ | Modtype _) :: _ as rem -> +- Format.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem ++ Fmt.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + | cxt -> context ppf cxt + and args ppf = function + Body x :: rem -> +- Format.fprintf ppf "(%s)%a" (argname x) args rem ++ Fmt.fprintf ppf "(%s)%a" (argname x) args rem + | Arg x :: rem -> +- Format.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem ++ Fmt.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem + | cxt -> +- Format.fprintf ppf " :@ %a" context_mty cxt ++ Fmt.fprintf ppf " :@ %a" context_mty cxt + and argname = function + | Types.Unit -> "" + | Types.Named (None, _) -> "_" +@@ -64,25 +66,24 @@ + let alt_pp ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then +- Format.fprintf ppf "in module %a," ++ Fmt.fprintf ppf ",@ in module %a" + (Style.as_inline_code Printtyp.path) (path_of_context cxt) + else +- Format.fprintf ppf "@[at position@ %a,@]" ++ Fmt.fprintf ppf ",@ @[at position@ %a@]" + (Style.as_inline_code context) cxt + + let pp ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then +- Format.fprintf ppf "In module %a:@ " ++ Fmt.fprintf ppf "In module %a:@ " + (Style.as_inline_code Printtyp.path) (path_of_context cxt) + else +- Format.fprintf ppf "@[At position@ %a@]@ " ++ Fmt.fprintf ppf "@[At position@ %a@]@ " + (Style.as_inline_code context) cxt + end + +-module Illegal_permutation = struct +- (** Extraction of information in case of illegal permutation +- in a module type *) ++module Runtime_coercion = struct ++ (** Extraction of a small change from a non-identity runtime coercion *) + + (** When examining coercions, we only have runtime component indices, + we use thus a limited version of {!pos}. *) +@@ -95,43 +96,50 @@ + | None -> g y + | Some _ as v -> v + +- (** We extract a lone transposition from a full tree of permutations. *) +- let rec transposition_under path (coerc:Typedtree.module_coercion) = ++ type change = ++ | Transposition of int * int ++ | Primitive_coercion of string ++ | Alias_coercion of Path.t ++ ++ (** We extract a small change from a full coercion. *) ++ let rec first_change_under path (coerc:Typedtree.module_coercion) = + match coerc with + | Tcoerce_structure(c,_) -> + either +- (not_fixpoint path 0) c ++ (first_item_transposition path 0) c + (first_non_id path 0) c + | Tcoerce_functor(arg,res) -> + either +- (transposition_under (InArg::path)) arg +- (transposition_under (InBody::path)) res ++ (first_change_under (InArg::path)) arg ++ (first_change_under (InBody::path)) res + | Tcoerce_none -> None +- | Tcoerce_alias _ | Tcoerce_primitive _ -> +- (* these coercions are not inversible, and raise an error earlier when +- checking for module type equivalence *) +- assert false ++ | Tcoerce_alias _ | Tcoerce_primitive _ -> None ++ + (* we search the first point which is not invariant at the current level *) +- and not_fixpoint path pos = function ++ and first_item_transposition path pos = function + | [] -> None + | (n, _) :: q -> +- if n = pos then +- not_fixpoint path (pos+1) q ++ if n < 0 || n = pos then ++ (* when n < 0, this is not a transposition but a kind coercion, ++ which will be covered in the first_non_id case *) ++ first_item_transposition path (pos+1) q + else +- Some(List.rev path, pos, n) ++ Some(List.rev path, Transposition (pos, n)) + (* we search the first item with a non-identity inner coercion *) + and first_non_id path pos = function + | [] -> None + | (_, Typedtree.Tcoerce_none) :: q -> first_non_id path (pos + 1) q ++ | (_, Typedtree.Tcoerce_alias (_,p,_)) :: _ -> ++ Some (List.rev path, Alias_coercion p) ++ | (_, Typedtree.Tcoerce_primitive p) :: _ -> ++ let name = Primitive.byte_name p.pc_desc in ++ Some (List.rev path, Primitive_coercion name) + | (_,c) :: q -> + either +- (transposition_under (Item pos :: path)) c ++ (first_change_under (Item pos :: path)) c + (first_non_id path (pos + 1)) q + +- let transposition c = +- match transposition_under [] c with +- | None -> raise Not_found +- | Some x -> x ++ let first_change c = first_change_under [] c + + let rec runtime_item k = function + | [] -> raise Not_found +@@ -168,23 +176,64 @@ + let item mt k = Includemod.item_ident_name (runtime_item k mt) + + let pp_item ppf (id,_,kind) = +- Format.fprintf ppf "%s %a" ++ Fmt.fprintf ppf "%s %a" + (Includemod.kind_of_field_desc kind) + Style.inline_code (Ident.name id) + +- let pp ctx_printer env ppf (mty,c) = ++ let illegal_permutation ctx_printer env ppf (mty,c) = ++ match first_change c with ++ | None | Some (_, (Primitive_coercion _ | Alias_coercion _)) -> ++ (* those kind coercions are not inversible, and raise an error earlier ++ when checking for module type equivalence *) ++ assert false ++ | Some (path, Transposition (k,l)) -> + try +- let p, k, l = transposition c in +- let ctx, mt = find env p mty in +- Format.fprintf ppf ++ let ctx, mt = find env path mty in ++ Fmt.fprintf ppf + "@[Illegal permutation of runtime components in a module type.@ \ +- @[For example,@ %a@]@ @[the %a@ and the %a are not in the same order@ \ ++ @[For example%a,@]@ @[the %a@ and the %a are not in the same order@ \ + in the expected and actual module types.@]@]" + ctx_printer ctx pp_item (item mt k) pp_item (item mt l) + with Not_found -> (* this should not happen *) +- Format.fprintf ppf ++ Fmt.fprintf ppf + "Illegal permutation of runtime components in a module type." + ++ let in_package_subtype ctx_printer env mty c ppf = ++ match first_change c with ++ | None -> ++ (* The coercion looks like the identity but was not simplified to ++ [Tcoerce_none], this only happens when the two first-class module ++ types differ by runtime size *) ++ Fmt.fprintf ppf ++ "The two first-class module types differ by their runtime size." ++ | Some (path, c) -> ++ try ++ let ctx, mt = find env path mty in ++ match c with ++ | Primitive_coercion prim_name -> ++ Fmt.fprintf ppf ++ "@[The two first-class module types differ by a coercion of@ \ ++ the primitive %a@ to a value%a.@]" ++ Style.inline_code prim_name ++ ctx_printer ctx ++ | Alias_coercion path -> ++ Fmt.fprintf ppf ++ "@[The two first-class module types differ by a coercion of@ \ ++ a module alias %a@ to a module%a.@]" ++ (Style.as_inline_code Printtyp.path) path ++ ctx_printer ctx ++ | Transposition (k,l) -> ++ Fmt.fprintf ppf ++ "@[@[The two first-class module types do not share@ \ ++ the same positions for runtime components.@]@ \ ++ @[For example,%a@ the %a@ occurs at the expected position of@ \ ++ the %a.@]@]" ++ ctx_printer ctx pp_item (item mt k) pp_item (item mt l) ++ with Not_found -> ++ Fmt.fprintf ppf ++ "@[The two packages types do not share@ \ ++ the@ same@ positions@ for@ runtime@ components.@]" ++ + end + + +@@ -204,7 +253,7 @@ + let show_loc msg ppf loc = + let pos = loc.Location.loc_start in + if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then () +- else Format.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg ++ else Fmt.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.Doc.loc loc msg + + let show_locs ppf (loc1, loc2) = + show_loc "Expected declaration" ppf loc2; +@@ -212,10 +261,10 @@ + + + let dmodtype mty = +- let tmty = Printtyp.tree_of_modtype mty in +- Format.dprintf "%a" !Oprint.out_module_type tmty ++ let tmty = Out_type.tree_of_modtype mty in ++ Fmt.dprintf "%a" !Oprint.out_module_type tmty + +-let space ppf () = Format.fprintf ppf "@ " ++let space ppf () = Fmt.fprintf ppf "@ " + + (** + In order to display a list of functor arguments in a compact format, +@@ -264,8 +313,8 @@ + + let make side pos = + match side with +- | Got -> Format.sprintf "$S%d" pos +- | Expected -> Format.sprintf "$T%d" pos ++ | Got -> Fmt.asprintf "$S%d" pos ++ | Expected -> Fmt.asprintf "$T%d" pos + | Unneeded -> "..." + + (** Add shorthands to a patch *) +@@ -310,43 +359,43 @@ + (** Printing of arguments with shorthands *) + let pp ppx = function + | Original x -> ppx x +- | Synthetic s -> Format.dprintf "%s" s.name ++ | Synthetic s -> Fmt.dprintf "%s" s.name + + let pp_orig ppx = function + | Original x | Synthetic { item=x; _ } -> ppx x + + let definition x = match functor_param x with +- | Unit -> Format.dprintf "()" ++ | Unit -> Fmt.dprintf "()" + | Named(_,short_mty) -> + match short_mty with + | Original mty -> dmodtype mty + | Synthetic {name; item = mty} -> +- Format.dprintf ++ Fmt.dprintf + "%s@ =@ %t" name (dmodtype mty) + + let param x = match functor_param x with +- | Unit -> Format.dprintf "()" ++ | Unit -> Fmt.dprintf "()" + | Named (_, short_mty) -> + pp dmodtype short_mty + + let qualified_param x = match functor_param x with +- | Unit -> Format.dprintf "()" ++ | Unit -> Fmt.dprintf "()" + | Named (None, Original (Mty_signature []) ) -> +- Format.dprintf "(sig end)" ++ Fmt.dprintf "(sig end)" + | Named (None, short_mty) -> + pp dmodtype short_mty + | Named (Some p, short_mty) -> +- Format.dprintf "(%s : %t)" ++ Fmt.dprintf "(%s : %t)" + (Ident.name p) (pp dmodtype short_mty) + + let definition_of_argument ua = + let arg, mty = ua.item in + match (arg: Err.functor_arg_descr) with +- | Unit -> Format.dprintf "()" +- | Empty_struct -> Format.dprintf "(struct end)" ++ | Unit -> Fmt.dprintf "()" ++ | Empty_struct -> Fmt.dprintf "(struct end)" + | Named p -> + let mty = modtype { ua with item = mty } in +- Format.dprintf ++ Fmt.dprintf + "%a@ :@ %t" + Printtyp.path p + (pp_orig dmodtype mty) +@@ -355,14 +404,14 @@ + begin match short_mty with + | Original mty -> dmodtype mty + | Synthetic {name; item=mty} -> +- Format.dprintf "%s@ :@ %t" name (dmodtype mty) ++ Fmt.dprintf "%s@ :@ %t" name (dmodtype mty) + end + + let arg ua = + let arg, mty = ua.item in + match (arg: Err.functor_arg_descr) with +- | Unit -> Format.dprintf "()" +- | Empty_struct -> Format.dprintf "(struct end)" ++ | Unit -> Fmt.dprintf "()" ++ | Empty_struct -> Fmt.dprintf "(struct end)" + | Named p -> fun ppf -> Printtyp.path ppf p + | Anonymous -> + let short_mty = modtype { ua with item=mty } in +@@ -378,17 +427,38 @@ + | Types.Named (Some _ as x,_) -> x + | Types.(Unit | Named(None,_)) -> None + +- (** Print the list of params with style *) ++ ++(** Print a list of functor parameters with style while adjusting the printing ++ environment for each functor argument. ++ ++ Currently, we are disabling disambiguation for functor argument name to ++ avoid the need to track the moving association between identifiers and ++ syntactic names in situation like: ++ ++ got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T) ++ expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T) ++*) + let pretty_params sep proj printer patch = +- let elt (x,param) = ++ let pp_param (x,param) = + let sty = Diffing.(style @@ classify x) in +- Format.dprintf "%a%t%a" +- Format.pp_open_stag (Style.Style sty) ++ Fmt.dprintf "%a%t%a" ++ Fmt.pp_open_stag (Style.Style sty) + (printer param) +- Format.pp_close_stag () ++ Fmt.pp_close_stag () ++ in ++ let rec pp_params = function ++ | [] -> ignore ++ | [_,param] -> pp_param param ++ | (id,param) :: q -> ++ Fmt.dprintf "%t%a%t" ++ (pp_param param) sep () (hide_id id q) ++ and hide_id id q = ++ match id with ++ | None -> pp_params q ++ | Some id -> Out_type.Ident_names.with_fuzzy id (fun () -> pp_params q) + in + let params = List.filter_map proj @@ List.map snd patch in +- Printtyp.functor_parameters ~sep elt params ++ pp_params params + + let expected d = + let extract: _ Diffing.change -> _ = function +@@ -424,17 +494,17 @@ + pretty_params space extract With_shorthand.qualified_param d + + let insert mty = +- Format.dprintf ++ Fmt.dprintf + "An argument appears to be missing with module type@;<1 2>@[%t@]" + (With_shorthand.definition mty) + + let delete mty = +- Format.dprintf ++ Fmt.dprintf + "An extra argument is provided of module type@;<1 2>@[%t@]" + (With_shorthand.definition mty) + + let ok x y = +- Format.dprintf ++ Fmt.dprintf + "Module types %t and %t match" + (With_shorthand.param x) + (With_shorthand.param y) +@@ -442,17 +512,17 @@ + let diff g e more = + let g = With_shorthand.definition g in + let e = With_shorthand.definition e in +- Format.dprintf ++ Fmt.dprintf + "Module types do not match:@ @[%t@]@;<1 -2>does not include@ \ + @[%t@]%t" + g e (more ()) + + let incompatible = function + | Types.Unit -> +- Format.dprintf ++ Fmt.dprintf + "The functor was expected to be applicative at this position" + | Types.Named _ -> +- Format.dprintf ++ Fmt.dprintf + "The functor was expected to be generative at this position" + + let patch env got expected = +@@ -478,7 +548,7 @@ + pretty_params space extract With_shorthand.arg d + + let delete mty = +- Format.dprintf ++ Fmt.dprintf + "The following extra argument is provided@;<1 2>@[%t@]" + (With_shorthand.definition_of_argument mty) + +@@ -487,10 +557,10 @@ + let ok x y = + let pp_orig_name = match With_shorthand.functor_param y with + | With_shorthand.Named (_, Original mty) -> +- Format.dprintf " %t" (dmodtype mty) ++ Fmt.dprintf " %t" (dmodtype mty) + | _ -> ignore + in +- Format.dprintf ++ Fmt.dprintf + "Module %t matches the expected module type%t" + (With_shorthand.arg x) + pp_orig_name +@@ -498,7 +568,7 @@ + let diff g e more = + let g = With_shorthand.definition_of_argument g in + let e = With_shorthand.definition e in +- Format.dprintf ++ Fmt.dprintf + "Modules do not match:@ @[%t@]@;<1 -2>\ + is not included in@ @[%t@]%t" + g e (more ()) +@@ -509,10 +579,10 @@ + let single_diff g e more = + let _arg, mty = g.With_shorthand.item in + let e = match e.With_shorthand.item with +- | Types.Unit -> Format.dprintf "()" ++ | Types.Unit -> Fmt.dprintf "()" + | Types.Named(_, mty) -> dmodtype mty + in +- Format.dprintf ++ Fmt.dprintf + "Modules do not match:@ @[%t@]@;<1 -2>\ + is not included in@ @[%t@]%t" + (dmodtype mty) e (more ()) +@@ -520,10 +590,10 @@ + + let incompatible = function + | Unit -> +- Format.dprintf ++ Fmt.dprintf + "The functor was expected to be applicative at this position" + | Named _ | Anonymous -> +- Format.dprintf ++ Fmt.dprintf + "The functor was expected to be generative at this position" + | Empty_struct -> + (* an empty structure can be used in both applicative and generative +@@ -533,18 +603,18 @@ + + let subcase sub ~expansion_token env (pos, diff) = + Location.msg "%a%a%a%a@[%t@]%a" +- Format.pp_print_tab () +- Format.pp_open_tbox () ++ Fmt.pp_print_tab () ++ Fmt.pp_open_tbox () + Diffing.prefix (pos, Diffing.classify diff) +- Format.pp_set_tab () ++ Fmt.pp_set_tab () + (Printtyp.wrap_printing_env env ~error:true + (fun () -> sub ~expansion_token env diff) + ) +- Format.pp_close_tbox () ++ Fmt.pp_close_tbox () + + let onlycase sub ~expansion_token env (_, diff) = + Location.msg "%a@[%t@]" +- Format.pp_print_tab () ++ Fmt.pp_print_tab () + (Printtyp.wrap_printing_env env ~error:true + (fun () -> sub ~expansion_token env diff) + ) +@@ -591,122 +661,113 @@ + | [] -> ignore + | before -> + let ctx ppf = +- Format.pp_print_list ~pp_sep:space +- (fun ppf x -> x.Location.txt ppf) ++ Fmt.pp_print_list ~pp_sep:space ++ (fun ppf x -> Fmt.pp_doc ppf x.Location.txt) + ppf before in + ctx + + let subcase_list l ppf = match l with + | [] -> () + | _ :: _ -> +- Format.fprintf ppf "@;<1 -2>@[%a@]" +- (Format.pp_print_list ~pp_sep:space +- (fun ppf f -> f.Location.txt ppf) +- ) ++ let pp_msg ppf lmsg = Fmt.pp_doc ppf lmsg.Location.txt in ++ Fmt.fprintf ppf "@;<1 -2>@[%a@]" ++ (Fmt.pp_print_list ~pp_sep:space pp_msg) + (List.rev l) + + (* Printers for leaves *) + let core env id x = + match x with + | Err.Value_descriptions diff -> +- Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" ++ Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" + "Values do not match" + !Oprint.out_sig_item +- (Printtyp.tree_of_value_description id diff.got) ++ (Out_type.tree_of_value_description id diff.got) + "is not included in" + !Oprint.out_sig_item +- (Printtyp.tree_of_value_description id diff.expected) ++ (Out_type.tree_of_value_description id diff.expected) + (Includecore.report_value_mismatch + "the first" "the second" env) diff.symptom + show_locs (diff.got.val_loc, diff.expected.val_loc) +- Printtyp.Conflicts.print_explanations + | Err.Type_declarations diff -> +- Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" ++ Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" + "Type declarations do not match" + !Oprint.out_sig_item +- (Printtyp.tree_of_type_declaration id diff.got Trec_first) ++ (Out_type.tree_of_type_declaration id diff.got Trec_first) + "is not included in" + !Oprint.out_sig_item +- (Printtyp.tree_of_type_declaration id diff.expected Trec_first) ++ (Out_type.tree_of_type_declaration id diff.expected Trec_first) + (Includecore.report_type_mismatch + "the first" "the second" "declaration" env) diff.symptom + show_locs (diff.got.type_loc, diff.expected.type_loc) +- Printtyp.Conflicts.print_explanations + | Err.Extension_constructors diff -> +- Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a%t@]" ++ Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]" + "Extension declarations do not match" + !Oprint.out_sig_item +- (Printtyp.tree_of_extension_constructor id diff.got Text_first) ++ (Out_type.tree_of_extension_constructor id diff.got Text_first) + "is not included in" + !Oprint.out_sig_item +- (Printtyp.tree_of_extension_constructor id diff.expected Text_first) ++ (Out_type.tree_of_extension_constructor id diff.expected Text_first) + (Includecore.report_extension_constructor_mismatch + "the first" "the second" "declaration" env) diff.symptom + show_locs (diff.got.ext_loc, diff.expected.ext_loc) +- Printtyp.Conflicts.print_explanations + | Err.Class_type_declarations diff -> +- Format.dprintf ++ Fmt.dprintf + "@[Class type declarations do not match:@ \ +- %a@;<1 -2>does not match@ %a@]@ %a%t" ++ %a@;<1 -2>does not match@ %a@]@ %a" + !Oprint.out_sig_item +- (Printtyp.tree_of_cltype_declaration id diff.got Trec_first) ++ (Out_type.tree_of_cltype_declaration id diff.got Trec_first) + !Oprint.out_sig_item +- (Printtyp.tree_of_cltype_declaration id diff.expected Trec_first) +- (Includeclass.report_error Type_scheme) diff.symptom +- Printtyp.Conflicts.print_explanations ++ (Out_type.tree_of_cltype_declaration id diff.expected Trec_first) ++ (Includeclass.report_error_doc Type_scheme) diff.symptom + | Err.Class_declarations {got;expected;symptom} -> +- let t1 = Printtyp.tree_of_class_declaration id got Trec_first in +- let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in +- Format.dprintf ++ let t1 = Out_type.tree_of_class_declaration id got Trec_first in ++ let t2 = Out_type.tree_of_class_declaration id expected Trec_first in ++ Fmt.dprintf + "@[Class declarations do not match:@ \ +- %a@;<1 -2>does not match@ %a@]@ %a%t" ++ %a@;<1 -2>does not match@ %a@]@ %a" + !Oprint.out_sig_item t1 + !Oprint.out_sig_item t2 +- (Includeclass.report_error Type_scheme) symptom +- Printtyp.Conflicts.print_explanations ++ (Includeclass.report_error_doc Type_scheme) symptom + + let missing_field ppf item = + let id, loc, kind = Includemod.item_ident_name item in +- Format.fprintf ppf "The %s %a is required but not provided%a" ++ Fmt.fprintf ppf "The %s %a is required but not provided%a" + (Includemod.kind_of_field_desc kind) + (Style.as_inline_code Printtyp.ident) id + (show_loc "Expected declaration") loc + + let module_types {Err.got=mty1; expected=mty2} = +- Format.dprintf ++ Fmt.dprintf + "@[Modules do not match:@ \ + %a@;<1 -2>is not included in@ %a@]" +- !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) +- !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) ++ !Oprint.out_module_type (Out_type.tree_of_modtype mty1) ++ !Oprint.out_module_type (Out_type.tree_of_modtype mty2) + + let eq_module_types {Err.got=mty1; expected=mty2} = +- Format.dprintf ++ Fmt.dprintf + "@[Module types do not match:@ \ + %a@;<1 -2>is not equal to@ %a@]" +- !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) +- !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) ++ !Oprint.out_module_type (Out_type.tree_of_modtype mty1) ++ !Oprint.out_module_type (Out_type.tree_of_modtype mty2) + + let module_type_declarations id {Err.got=d1 ; expected=d2} = +- Format.dprintf ++ Fmt.dprintf + "@[Module type declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]" +- !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1) +- !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2) ++ !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration id d1) ++ !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration id d2) + + let interface_mismatch ppf (diff: _ Err.diff) = +- Format.fprintf ppf ++ Fmt.fprintf ppf + "The implementation %a@ does not match the interface %a:@ " + Style.inline_code diff.got Style.inline_code diff.expected + + let core_module_type_symptom (x:Err.core_module_type_symptom) = + match x with + | Not_an_alias | Not_an_identifier | Abstract_module_type +- | Incompatible_aliases -> +- if Printtyp.Conflicts.exists () then +- Some Printtyp.Conflicts.print_explanations +- else None ++ | Incompatible_aliases -> None + | Unbound_module_path path -> +- Some(Format.dprintf "Unbound module %a" ++ Some(Fmt.dprintf "Unbound module %a" + (Style.as_inline_code Printtyp.path) path + ) + +@@ -748,7 +809,7 @@ + module_type ~eqmode ~expansion_token ~env ~before ~ctx diff + | Invalid_module_alias path -> + let printer = +- Format.dprintf "Module %a cannot be aliased" ++ Fmt.dprintf "Module %a cannot be aliased" + (Style.as_inline_code Printtyp.path) path + in + dwith_context ctx printer :: before +@@ -758,10 +819,10 @@ + let actual = Functor_suberror.Inclusion.got d in + let expected = Functor_suberror.expected d in + let main = +- Format.dprintf ++ Fmt.dprintf + "@[Modules do not match:@ \ +- @[functor@ %t@ -> ...@]@;<1 -2>is not included in@ \ +- @[functor@ %t@ -> ...@]@]" ++ @[%t@ -> ...@]@;<1 -2>is not included in@ \ ++ @[%t@ -> ...@]@]" + actual expected + in + let msgs = dwith_context ctx main :: before in +@@ -784,8 +845,8 @@ + if expansion_token then + let init_missings, last_missing = Misc.split_last missings in + List.map (Location.msg "%a" missing_field) init_missings +- @ [ with_context ctx missing_field last_missing ] +- @ before ++ @ with_context ctx missing_field last_missing ++ :: before + else + before + | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a +@@ -825,7 +886,7 @@ + | None -> assert false + | Some mty -> + with_context (Modtype id::ctx) +- (Illegal_permutation.pp Context.alt_pp env) (mty,c) ++ (Runtime_coercion.illegal_permutation Context.alt_pp env) (mty,c) + :: before + end + +@@ -874,7 +935,7 @@ + let mty = diff.got in + let main = + with_context [Modtype id] +- (Illegal_permutation.pp Context.alt_pp env) (mty,c) in ++ (Runtime_coercion.illegal_permutation Context.alt_pp env) (mty,c) in + [main] + + let all env = function +@@ -897,29 +958,32 @@ + + (* General error reporting *) + +-let err_msgs (env, err) = +- Printtyp.Conflicts.reset(); ++let err_msgs ppf (env, err) = + Printtyp.wrap_printing_env ~error:true env +- (fun () -> coalesce @@ all env err) ++ (fun () -> (coalesce @@ all env err) ppf) + +-let report_error err = +- let main = err_msgs err in +- Location.errorf ~loc:Location.(in_file !input_name) "%t" main ++let report_error_doc err = ++ Location.errorf ++ ~loc:Location.(in_file !input_name) ++ ~footnote:Out_type.Ident_conflicts.err_msg ++ "%a" err_msgs err + +-let report_apply_error ~loc env (app_name, mty_f, args) = ++let report_apply_error_doc ~loc env (app_name, mty_f, args) = ++ let footnote = Out_type.Ident_conflicts.err_msg in + let d = Functor_suberror.App.patch env ~f:mty_f ~args in + match d with + (* We specialize the one change and one argument case to remove the + presentation of the functor arguments *) + | [ _, Change (_, _, Err.Incompatible_params (i,_)) ] -> +- Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i) ++ Location.errorf ~loc ~footnote "%t" (Functor_suberror.App.incompatible i) + | [ _, Change (g, e, Err.Mismatch mty_diff) ] -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token:true ~env ~before:[] + ~ctx:[] mty_diff.symptom + in +- Location.errorf ~loc "%t" (Functor_suberror.App.single_diff g e more) ++ Location.errorf ~loc ~footnote "%t" ++ (Functor_suberror.App.single_diff g e more) + | _ -> + let not_functor = + List.for_all (function _, Diffing.Delete _ -> true | _ -> false) d +@@ -943,12 +1007,12 @@ + let intro ppf = + match app_name with + | Includemod.Anonymous_functor -> +- Format.fprintf ppf "This functor application is ill-typed." ++ Fmt.fprintf ppf "This functor application is ill-typed." + | Includemod.Full_application_path lid -> +- Format.fprintf ppf "The functor application %a is ill-typed." ++ Fmt.fprintf ppf "The functor application %a is ill-typed." + (Style.as_inline_code Printtyp.longident) lid + | Includemod.Named_leftmost_functor lid -> +- Format.fprintf ppf ++ Fmt.fprintf ppf + "This application of the functor %a is ill-typed." + (Style.as_inline_code Printtyp.longident) lid + in +@@ -958,20 +1022,24 @@ + List.rev @@ + Functor_suberror.params functor_app_diff env ~expansion_token:true d + in +- Location.errorf ~loc ~sub ++ Location.errorf ~loc ~sub ~footnote + "@[%t@ \ + These arguments:@;<1 2>@[%t@]@ \ +- do not match these parameters:@;<1 2>@[functor@ %t@ -> ...@]@]" ++ do not match these parameters:@;<1 2>@[%t@ -> ...@]@]" + intro + actual expected + ++let coercion_in_package_subtype env mty c = ++ Format_doc.doc_printf "%t" @@ ++ Runtime_coercion.in_package_subtype Context.alt_pp env mty c ++ + let register () = + Location.register_error_of_exn + (function +- | Includemod.Error err -> Some (report_error err) ++ | Includemod.Error err -> Some (report_error_doc err) + | Includemod.Apply_error {loc; env; app_name; mty_f; args} -> + Some (Printtyp.wrap_printing_env env ~error:true (fun () -> +- report_apply_error ~loc env (app_name, mty_f, args)) ++ report_apply_error_doc ~loc env (app_name, mty_f, args)) + ) + | _ -> None + ) diff --git a/upstream/patches_503/typing/includemod_errorprinter.mli.patch b/upstream/patches_503/typing/includemod_errorprinter.mli.patch new file mode 100644 index 000000000..5004a4faa --- /dev/null +++ b/upstream/patches_503/typing/includemod_errorprinter.mli.patch @@ -0,0 +1,11 @@ +--- ocaml_502/typing/includemod_errorprinter.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/includemod_errorprinter.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -13,5 +13,7 @@ + (* *) + (**************************************************************************) + +-val err_msgs: Includemod.explanation -> Format.formatter -> unit ++val err_msgs: Includemod.explanation Format_doc.printer ++val coercion_in_package_subtype: ++ Env.t -> Types.module_type -> Typedtree.module_coercion -> Format_doc.doc + val register: unit -> unit diff --git a/upstream/patches_503/typing/mtype.ml.patch b/upstream/patches_503/typing/mtype.ml.patch new file mode 100644 index 000000000..cb31b8eb3 --- /dev/null +++ b/upstream/patches_503/typing/mtype.ml.patch @@ -0,0 +1,51 @@ +--- ocaml_502/typing/mtype.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/mtype.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -456,9 +456,11 @@ + and bindings = ref Ident.empty in + (* let rt = Ident.create "Root" in + and prefix = ref (Path.Pident rt) in *) ++ with_type_mark begin fun mark -> ++ let super = type_iterators mark in + let it_path p = paths := Path.Set.union (get_arg_paths p) !paths + and it_signature_item it si = +- type_iterators.it_signature_item it si; ++ super.it_signature_item it si; + match si with + | Sig_module (id, _, {md_type=Mty_alias p}, _, _) -> + bindings := Ident.add id p !bindings +@@ -471,11 +473,11 @@ + sg + | _ -> () + in +- let it = {type_iterators with it_path; it_signature_item} in ++ let it = {super with it_path; it_signature_item} in + it.it_module_type it mty; +- it.it_module_type unmark_iterators mty; + Path.Set.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p)) + !paths Ident.Set.empty ++ end + + type remove_alias_args = + { mutable modified: bool; +@@ -552,14 +554,16 @@ + + let lower_nongen nglev mty = + let open Btype in +- let it_type_expr it ty = ++ with_type_mark begin fun mark -> ++ let super = type_iterators mark in ++ let it_do_type_expr it ty = + match get_desc ty with + Tvar _ -> + let level = get_level ty in + if level < generic_level && level > nglev then set_level ty nglev + | _ -> +- type_iterators.it_type_expr it ty ++ super.it_do_type_expr it ty + in +- let it = {type_iterators with it_type_expr} in +- it.it_module_type it mty; +- it.it_module_type unmark_iterators mty ++ let it = {super with it_do_type_expr} in ++ it.it_module_type it mty ++ end diff --git a/upstream/patches_503/typing/oprint.ml.patch b/upstream/patches_503/typing/oprint.ml.patch new file mode 100644 index 000000000..d0f3bf159 --- /dev/null +++ b/upstream/patches_503/typing/oprint.ml.patch @@ -0,0 +1,126 @@ +--- ocaml_502/typing/oprint.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/oprint.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -13,7 +13,7 @@ + (* *) + (**************************************************************************) + +-open Format ++open Format_doc + open Outcometree + + exception Ellipsis +@@ -37,28 +37,9 @@ + + let out_ident = ref print_ident + +-(* Check a character matches the [identchar_latin1] class from the lexer *) +-let is_ident_char c = +- match c with +- | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' +- | '\248'..'\255' | '\'' | '0'..'9' -> true +- | _ -> false +- +-let all_ident_chars s = +- let rec loop s len i = +- if i < len then begin +- if is_ident_char s.[i] then loop s len (i+1) +- else false +- end else begin +- true +- end +- in +- let len = String.length s in +- loop s len 0 +- + let parenthesized_ident name = + (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) +- || not (all_ident_chars name) ++ || not (Misc.Utf8_lexeme.is_valid_identifier name) + + let value_ident ppf name = + if parenthesized_ident name then +@@ -249,7 +230,7 @@ + in + cautious print_tree_1 ppf tree + +-let out_value = ref print_out_value ++let out_value = ref (compat print_out_value) + + (* Types *) + +@@ -267,7 +248,7 @@ + let pr_present = + print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") + +-let pr_var = Pprintast.tyvar ++let pr_var = Pprintast.Doc.tyvar + let ty_var ~non_gen ppf s = + pr_var ppf (if non_gen then "_" ^ s else s) + +@@ -404,10 +385,13 @@ + pp_print_char ppf ')'; + pp_close_box ppf (); + pp_print_space ppf () +-and print_out_label ppf (name, mut, arg) = +- fprintf ppf "@[<2>%s%a :@ %a@];" (if mut then "mutable " else "") +- print_lident name +- print_out_type arg ++and print_out_label ppf {olab_name; olab_mut; olab_type} = ++ fprintf ppf "@[<2>%s%a :@ %a@];" ++ (match olab_mut with ++ | Mutable -> "mutable " ++ | Immutable -> "") ++ print_lident olab_name ++ print_out_type olab_type + + let out_label = ref print_out_label + +@@ -555,7 +539,7 @@ + print_args l + | _ :: _ as non_anonymous_functor -> + let args, anons = split_anon_functor_arguments non_anonymous_functor in +- fprintf ppf "@[<2>functor@ %a@]@ ->@ %a" ++ fprintf ppf "@[%a@]@ ->@ %a" + (pp_print_list ~pp_sep:pp_print_space print_nonanon_arg) args + print_args anons + in +@@ -813,6 +797,8 @@ + + (* Phrases *) + ++open Format ++ + let print_out_exception ppf exn outv = + match exn with + Sys.Break -> fprintf ppf "Interrupted.@." +@@ -847,23 +833,26 @@ + otyext_constructors = exts; + otyext_private = ext.oext_private } + in +- fprintf ppf "@[%a@]" !out_type_extension te; ++ fprintf ppf "@[%a@]" (Format_doc.compat !out_type_extension) te; + if items <> [] then fprintf ppf "@ %a" print_items items + | (tree, valopt) :: items -> + begin match valopt with + Some v -> +- fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree ++ fprintf ppf "@[<2>%a =@ %a@]" (Format_doc.compat !out_sig_item) tree + !out_value v +- | None -> fprintf ppf "@[%a@]" !out_sig_item tree ++ | None -> fprintf ppf "@[%a@]" (Format_doc.compat !out_sig_item) tree + end; + if items <> [] then fprintf ppf "@ %a" print_items items + + let print_out_phrase ppf = + function + Ophr_eval (outv, ty) -> +- fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv ++ fprintf ppf "@[- : %a@ =@ %a@]@." (compat !out_type) ty !out_value outv + | Ophr_signature [] -> () + | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items + | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv + + let out_phrase = ref print_out_phrase ++ ++type 'a printer = 'a Format_doc.printer ref ++type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref diff --git a/upstream/patches_503/typing/oprint.mli.patch b/upstream/patches_503/typing/oprint.mli.patch new file mode 100644 index 000000000..887766db0 --- /dev/null +++ b/upstream/patches_503/typing/oprint.mli.patch @@ -0,0 +1,43 @@ +--- ocaml_502/typing/oprint.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/oprint.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -13,24 +13,24 @@ + (* *) + (**************************************************************************) + +-open Format + open Outcometree + +-val out_ident : (formatter -> out_ident -> unit) ref +-val out_value : (formatter -> out_value -> unit) ref +-val out_label : (formatter -> string * bool * out_type -> unit) ref +-val out_type : (formatter -> out_type -> unit) ref +-val out_type_args : (formatter -> out_type list -> unit) ref +-val out_constr : (formatter -> out_constructor -> unit) ref +-val out_class_type : (formatter -> out_class_type -> unit) ref +-val out_module_type : (formatter -> out_module_type -> unit) ref +-val out_sig_item : (formatter -> out_sig_item -> unit) ref +-val out_signature : (formatter -> out_sig_item list -> unit) ref ++type 'a printer = 'a Format_doc.printer ref ++type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref ++ ++val out_ident: out_ident printer ++val out_value : out_value toplevel_printer ++val out_label : out_label printer ++val out_type : out_type printer ++val out_type_args : out_type list printer ++val out_constr : out_constructor printer ++val out_class_type : out_class_type printer ++val out_module_type : out_module_type printer ++val out_sig_item : out_sig_item printer ++val out_signature :out_sig_item list printer + val out_functor_parameters : +- (formatter -> +- (string option * Outcometree.out_module_type) option list -> unit) +- ref +-val out_type_extension : (formatter -> out_type_extension -> unit) ref +-val out_phrase : (formatter -> out_phrase -> unit) ref ++ (string option * Outcometree.out_module_type) option list printer ++val out_type_extension : out_type_extension printer ++val out_phrase : out_phrase toplevel_printer + + val parenthesized_ident : string -> bool diff --git a/upstream/patches_503/typing/out_type.ml.patch b/upstream/patches_503/typing/out_type.ml.patch new file mode 100644 index 000000000..6083e9183 --- /dev/null +++ b/upstream/patches_503/typing/out_type.ml.patch @@ -0,0 +1,1976 @@ +--- ocaml_502/typing/out_type.ml 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/typing/out_type.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -0,0 +1,1973 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) ++(* *) ++(* Copyright 1996 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* Compute a spanning tree representation of types *) ++ ++open Misc ++open Ctype ++open Longident ++open Path ++open Asttypes ++open Types ++open Btype ++open Outcometree ++ ++module String = Misc.Stdlib.String ++module Sig_component_kind = Shape.Sig_component_kind ++module Style = Misc.Style ++ ++(* Print a long identifier *) ++ ++module Fmt = Format_doc ++open Format_doc ++ ++let longident = Pprintast.Doc.longident ++ ++let () = Env.print_longident := longident ++ ++(* Print an identifier avoiding name collisions *) ++ ++module Out_name = struct ++ let create x = { printed_name = x } ++ let print x = x.printed_name ++end ++ ++(** Some identifiers may require hiding when printing *) ++type bound_ident = { hide:bool; ident:Ident.t } ++ ++(* printing environment for path shortening and naming *) ++let printing_env = ref Env.empty ++ ++(* When printing, it is important to only observe the ++ current printing environment, without reading any new ++ cmi present on the file system *) ++let in_printing_env f = Env.without_cmis f !printing_env ++ ++ type namespace = Sig_component_kind.t = ++ | Value ++ | Type ++ | Constructor ++ | Label ++ | Module ++ | Module_type ++ | Extension_constructor ++ | Class ++ | Class_type ++ ++ ++module Namespace = struct ++ ++ let id = function ++ | Type -> 0 ++ | Module -> 1 ++ | Module_type -> 2 ++ | Class -> 3 ++ | Class_type -> 4 ++ | Extension_constructor | Value | Constructor | Label -> 5 ++ (* we do not handle those component *) ++ ++ let size = 1 + id Value ++ ++ ++ let pp ppf x = ++ Fmt.pp_print_string ppf (Shape.Sig_component_kind.to_string x) ++ ++ (** The two functions below should never access the filesystem, ++ and thus use {!in_printing_env} rather than directly ++ accessing the printing environment *) ++ let lookup = ++ let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in ++ function ++ | Some Type -> to_lookup Env.find_type_by_name ++ | Some Module -> to_lookup Env.find_module_by_name ++ | Some Module_type -> to_lookup Env.find_modtype_by_name ++ | Some Class -> to_lookup Env.find_class_by_name ++ | Some Class_type -> to_lookup Env.find_cltype_by_name ++ | None | Some(Value|Extension_constructor|Constructor|Label) -> ++ fun _ -> raise Not_found ++ ++ let location namespace id = ++ let path = Path.Pident id in ++ try Some ( ++ match namespace with ++ | Some Type -> (in_printing_env @@ Env.find_type path).type_loc ++ | Some Module -> (in_printing_env @@ Env.find_module path).md_loc ++ | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc ++ | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc ++ | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc ++ | Some (Extension_constructor|Value|Constructor|Label) | None -> ++ Location.none ++ ) with Not_found -> None ++ ++ let best_class_namespace = function ++ | Papply _ | Pdot _ -> Some Module ++ | Pextra_ty _ -> assert false (* Only in type path *) ++ | Pident c -> ++ match location (Some Class) c with ++ | Some _ -> Some Class ++ | None -> Some Class_type ++ ++end ++ ++(** {2 Ident conflicts printing} ++ ++ Ident conflicts arise when multiple {!Ident.t}s are attributed the same name. ++ The following module stores the global conflict references and provides the ++ printing functions for explaining the source of the conflicts. ++*) ++module Ident_conflicts = struct ++ module M = String.Map ++ type explanation = ++ { kind: namespace; name:string; root_name:string; location:Location.t} ++ let explanations = ref M.empty ++ ++ let add namespace name id = ++ match Namespace.location (Some namespace) id with ++ | None -> () ++ | Some location -> ++ let explanation = ++ { kind = namespace; location; name; root_name=Ident.name id} ++ in ++ explanations := M.add name explanation !explanations ++ ++ let collect_explanation namespace id ~name = ++ let root_name = Ident.name id in ++ (* if [name] is of the form "root_name/%d", we register both ++ [id] and the identifier in scope for [root_name]. ++ *) ++ if root_name <> name && not (M.mem name !explanations) then ++ begin ++ add namespace name id; ++ if not (M.mem root_name !explanations) then ++ (* lookup the identifier in scope with name [root_name] and ++ add it too ++ *) ++ match Namespace.lookup (Some namespace) root_name with ++ | Pident root_id -> add namespace root_name root_id ++ | exception Not_found | _ -> () ++ end ++ ++ let pp_explanation ppf r= ++ Fmt.fprintf ppf "@[%a:@,Definition of %s %a@]" ++ Location.Doc.loc r.location (Sig_component_kind.to_string r.kind) ++ Style.inline_code r.name ++ ++ let print_located_explanations ppf l = ++ Fmt.fprintf ppf "@[%a@]" ++ (Fmt.pp_print_list pp_explanation) l ++ ++ let reset () = explanations := M.empty ++ let list_explanations () = ++ let c = !explanations in ++ reset (); ++ c |> M.bindings |> List.map snd |> List.sort Stdlib.compare ++ ++ ++ let print_toplevel_hint ppf l = ++ let conj ppf () = Fmt.fprintf ppf " and@ " in ++ let pp_namespace_plural ppf n = Fmt.fprintf ppf "%as" Namespace.pp n in ++ let root_names = List.map (fun r -> r.kind, r.root_name) l in ++ let unique_root_names = List.sort_uniq Stdlib.compare root_names in ++ let submsgs = Array.make Namespace.size [] in ++ let () = List.iter (fun (n,_ as x) -> ++ submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) ++ ) unique_root_names in ++ let pp_submsg ppf names = ++ match names with ++ | [] -> () ++ | [namespace, a] -> ++ Fmt.fprintf ppf ++ "@,\ ++ @[<2>@{Hint@}: The %a %a has been defined multiple times@ \ ++ in@ this@ toplevel@ session.@ \ ++ Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ ++ @ Did you try to redefine them?@]" ++ Namespace.pp namespace ++ Style.inline_code a Namespace.pp namespace ++ | (namespace, _) :: _ :: _ -> ++ Fmt.fprintf ppf ++ "@,\ ++ @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ ++ in@ this@ toplevel@ session.@ \ ++ Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ ++ @ Did you try to redefine them?@]" ++ pp_namespace_plural namespace ++ Fmt.(pp_print_list ~pp_sep:conj Style.inline_code) ++ (List.map snd names) ++ pp_namespace_plural namespace in ++ Array.iter (pp_submsg ppf) submsgs ++ ++ let err_msg () = ++ let ltop, l = ++ (* isolate toplevel locations, since they are too imprecise *) ++ let from_toplevel a = ++ a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in ++ List.partition from_toplevel (list_explanations ()) ++ in ++ match l, ltop with ++ | [], [] -> None ++ | _ -> ++ Some ++ (Fmt.doc_printf "%a%a" ++ print_located_explanations l ++ print_toplevel_hint ltop ++ ) ++ let err_print ppf = Option.iter Fmt.(fprintf ppf "@,%a" pp_doc) (err_msg ()) ++ ++ let exists () = M.cardinal !explanations >0 ++end ++ ++module Ident_names = struct ++ ++module M = String.Map ++module S = String.Set ++ ++let enabled = ref true ++let enable b = enabled := b ++ ++(* Names bound in recursive definitions should be considered as bound ++ in the environment when printing identifiers but not when trying ++ to find shortest path. ++ For instance, if we define ++ [{ ++ module Avoid__me = struct ++ type t = A ++ end ++ type t = X ++ type u = [` A of t * t ] ++ module M = struct ++ type t = A of [ u | `B ] ++ type r = Avoid__me.t ++ end ++ }] ++ It is is important that in the definition of [t] that the outer type [t] is ++ printed as [t/2] reserving the name [t] to the type being defined in the ++ current recursive definition. ++ Contrarily, in the definition of [r], one should not shorten the ++ path [Avoid__me.t] to [r] until the end of the definition of [r]. ++ The [bound_in_recursion] bridges the gap between those two slightly different ++ notions of printing environment. ++*) ++let bound_in_recursion = ref M.empty ++ ++(* When dealing with functor arguments, identity becomes fuzzy because the same ++ syntactic argument may be represented by different identifiers during the ++ error processing, we are thus disabling disambiguation on the argument name ++*) ++let fuzzy = ref S.empty ++let with_fuzzy id f = ++ protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f ++let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy ++ ++let with_hidden ids f = ++ let update m id = M.add (Ident.name id.ident) id.ident m in ++ let updated = List.fold_left update !bound_in_recursion ids in ++ protect_refs [ R(bound_in_recursion, updated )] f ++ ++let human_id id index = ++ (* The identifier with index [k] is the (k+1)-th most recent identifier in ++ the printing environment. We print them as [name/(k+1)] except for [k=0] ++ which is printed as [name] rather than [name/1]. ++ *) ++ if index = 0 then ++ Ident.name id ++ else ++ let ordinal = index + 1 in ++ String.concat "/" [Ident.name id; string_of_int ordinal] ++ ++let indexed_name namespace id = ++ let find namespace id env = match namespace with ++ | Type -> Env.find_type_index id env ++ | Module -> Env.find_module_index id env ++ | Module_type -> Env.find_modtype_index id env ++ | Class -> Env.find_class_index id env ++ | Class_type-> Env.find_cltype_index id env ++ | Value | Extension_constructor | Constructor | Label -> None ++ in ++ let index = ++ match M.find_opt (Ident.name id) !bound_in_recursion with ++ | Some rec_bound_id -> ++ (* the identifier name appears in the current group of recursive ++ definition *) ++ if Ident.same rec_bound_id id then ++ Some 0 ++ else ++ (* the current recursive definition shadows one more time the ++ previously existing identifier with the same name *) ++ Option.map succ (in_printing_env (find namespace id)) ++ | None -> ++ in_printing_env (find namespace id) ++ in ++ let index = ++ (* If [index] is [None] at this point, it might indicate that ++ the identifier id is not defined in the environment, while there ++ are other identifiers in scope that share the same name. ++ Currently, this kind of partially incoherent environment happens ++ within functor error messages where the left and right hand side ++ have a different views of the environment at the source level. ++ Printing the source-level by using a default index of `0` ++ seems like a reasonable compromise in this situation however.*) ++ Option.value index ~default:0 ++ in ++ human_id id index ++ ++let ident_name namespace id = ++ match namespace, !enabled with ++ | None, _ | _, false -> Out_name.create (Ident.name id) ++ | Some namespace, true -> ++ if fuzzy_id namespace id then Out_name.create (Ident.name id) ++ else ++ let name = indexed_name namespace id in ++ Ident_conflicts.collect_explanation namespace id ~name; ++ Out_name.create name ++end ++let ident_name = Ident_names.ident_name ++ ++(* Print a path *) ++ ++let ident_stdlib = Ident.create_persistent "Stdlib" ++ ++let non_shadowed_stdlib namespace = function ++ | Pdot(Pident id, s) as path -> ++ Ident.same id ident_stdlib && ++ (match Namespace.lookup namespace s with ++ | path' -> Path.same path path' ++ | exception Not_found -> true) ++ | _ -> false ++ ++let find_double_underscore s = ++ let len = String.length s in ++ let rec loop i = ++ if i + 1 >= len then ++ None ++ else if s.[i] = '_' && s.[i + 1] = '_' then ++ Some i ++ else ++ loop (i + 1) ++ in ++ loop 0 ++ ++let rec module_path_is_an_alias_of env path ~alias_of = ++ match Env.find_module path env with ++ | { md_type = Mty_alias path'; _ } -> ++ Path.same path' alias_of || ++ module_path_is_an_alias_of env path' ~alias_of ++ | _ -> false ++ | exception Not_found -> false ++ ++(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias ++ for Foo__bar. This pattern is used by the stdlib. *) ++let rec rewrite_double_underscore_paths env p = ++ match p with ++ | Pdot (p, s) -> ++ Pdot (rewrite_double_underscore_paths env p, s) ++ | Papply (a, b) -> ++ Papply (rewrite_double_underscore_paths env a, ++ rewrite_double_underscore_paths env b) ++ | Pextra_ty (p, extra) -> ++ Pextra_ty (rewrite_double_underscore_paths env p, extra) ++ | Pident id -> ++ let name = Ident.name id in ++ match find_double_underscore name with ++ | None -> p ++ | Some i -> ++ let better_lid = ++ Ldot ++ (Lident (String.sub name 0 i), ++ Unit_info.modulize ++ (String.sub name (i + 2) (String.length name - i - 2))) ++ in ++ match Env.find_module_by_name better_lid env with ++ | exception Not_found -> p ++ | p', _ -> ++ if module_path_is_an_alias_of env p' ~alias_of:p then ++ p' ++ else ++ p ++ ++let rewrite_double_underscore_paths env p = ++ if env == Env.empty then ++ p ++ else ++ rewrite_double_underscore_paths env p ++ ++let rec tree_of_path ?(disambiguation=true) namespace p = ++ let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in ++ let namespace = if disambiguation then namespace else None in ++ match p with ++ | Pident id -> ++ Oide_ident (ident_name namespace id) ++ | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> ++ Oide_ident (Out_name.create s) ++ | Pdot(p, s) -> ++ Oide_dot (tree_of_path (Some Module) p, s) ++ | Papply(p1, p2) -> ++ let t1 = tree_of_path (Some Module) p1 in ++ let t2 = tree_of_path (Some Module) p2 in ++ Oide_apply (t1, t2) ++ | Pextra_ty (p, extra) -> begin ++ (* inline record types are syntactically prevented from escaping their ++ binding scope, and are never shown to users. *) ++ match extra with ++ Pcstr_ty s -> ++ Oide_dot (tree_of_path (Some Type) p, s) ++ | Pext_ty -> ++ tree_of_path None p ++ end ++ ++let tree_of_path ?disambiguation namespace p = ++ tree_of_path ?disambiguation namespace ++ (rewrite_double_underscore_paths !printing_env p) ++ ++ ++(* Print a recursive annotation *) ++ ++let tree_of_rec = function ++ | Trec_not -> Orec_not ++ | Trec_first -> Orec_first ++ | Trec_next -> Orec_next ++ ++(* Normalize paths *) ++ ++type param_subst = Id | Nth of int | Map of int list ++ ++let is_nth = function ++ Nth _ -> true ++ | _ -> false ++ ++let compose l1 = function ++ | Id -> Map l1 ++ | Map l2 -> Map (List.map (List.nth l1) l2) ++ | Nth n -> Nth (List.nth l1 n) ++ ++let apply_subst s1 tyl = ++ if tyl = [] then [] ++ (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) ++ else ++ match s1 with ++ Nth n1 -> [List.nth tyl n1] ++ | Map l1 -> List.map (List.nth tyl) l1 ++ | Id -> tyl ++ ++type best_path = Paths of Path.t list | Best of Path.t ++ ++(** Short-paths cache: the five mutable variables below implement a one-slot ++ cache for short-paths ++ *) ++let printing_old = ref Env.empty ++let printing_pers = ref String.Set.empty ++(** {!printing_old} and {!printing_pers} are the keys of the one-slot cache *) ++ ++let printing_depth = ref 0 ++let printing_cont = ref ([] : Env.iter_cont list) ++let printing_map = ref Path.Map.empty ++(** ++ - {!printing_map} is the main value stored in the cache. ++ Note that it is evaluated lazily and its value is updated during printing. ++ - {!printing_dep} is the current exploration depth of the environment, ++ it is used to determine whenever the {!printing_map} should be evaluated ++ further before completing a request. ++ - {!printing_cont} is the list of continuations needed to evaluate ++ the {!printing_map} one level further (see also {!Env.run_iter_cont}) ++*) ++ ++let rec index l x = ++ match l with ++ [] -> raise Not_found ++ | a :: l -> if eq_type x a then 0 else 1 + index l x ++ ++let rec uniq = function ++ [] -> true ++ | a :: l -> not (List.memq (a : int) l) && uniq l ++ ++let rec normalize_type_path ?(cache=false) env p = ++ try ++ let (params, ty, _) = Env.find_type_expansion p env in ++ match get_desc ty with ++ Tconstr (p1, tyl, _) -> ++ if List.length params = List.length tyl ++ && List.for_all2 eq_type params tyl ++ then normalize_type_path ~cache env p1 ++ else if cache || List.length params <= List.length tyl ++ || not (uniq (List.map get_id tyl)) then (p, Id) ++ else ++ let l1 = List.map (index params) tyl in ++ let (p2, s2) = normalize_type_path ~cache env p1 in ++ (p2, compose l1 s2) ++ | _ -> ++ (p, Nth (index params ty)) ++ with ++ Not_found -> ++ (Env.normalize_type_path None env p, Id) ++ ++let penalty s = ++ if s <> "" && s.[0] = '_' then ++ 10 ++ else ++ match find_double_underscore s with ++ | None -> 1 ++ | Some _ -> 10 ++ ++let rec path_size = function ++ Pident id -> ++ penalty (Ident.name id), -Ident.scope id ++ | Pdot (p, _) | Pextra_ty (p, Pcstr_ty _) -> ++ let (l, b) = path_size p in (1+l, b) ++ | Papply (p1, p2) -> ++ let (l, b) = path_size p1 in ++ (l + fst (path_size p2), b) ++ | Pextra_ty (p, _) -> path_size p ++ ++let same_printing_env env = ++ let used_pers = Env.used_persistent () in ++ Env.same_types !printing_old env && String.Set.equal !printing_pers used_pers ++ ++let set_printing_env env = ++ printing_env := env; ++ if !Clflags.real_paths || ++ !printing_env == Env.empty || ++ same_printing_env env then ++ () ++ else begin ++ (* printf "Reset printing_map@."; *) ++ printing_old := env; ++ printing_pers := Env.used_persistent (); ++ printing_map := Path.Map.empty; ++ printing_depth := 0; ++ (* printf "Recompute printing_map.@."; *) ++ let cont = ++ Env.iter_types ++ (fun p (p', _decl) -> ++ let (p1, s1) = normalize_type_path env p' ~cache:true in ++ (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) ++ if s1 = Id then ++ try ++ let r = Path.Map.find p1 !printing_map in ++ match !r with ++ Paths l -> r := Paths (p :: l) ++ | Best p' -> r := Paths [p; p'] (* assert false *) ++ with Not_found -> ++ printing_map := Path.Map.add p1 (ref (Paths [p])) !printing_map) ++ env in ++ printing_cont := [cont]; ++ end ++ ++let wrap_printing_env env f = ++ set_printing_env env; ++ try_finally f ~always:(fun () -> set_printing_env Env.empty) ++ ++let wrap_printing_env ~error env f = ++ if error then Env.without_cmis (wrap_printing_env env) f ++ else wrap_printing_env env f ++ ++let rec lid_of_path = function ++ Path.Pident id -> ++ Longident.Lident (Ident.name id) ++ | Path.Pdot (p1, s) | Path.Pextra_ty (p1, Pcstr_ty s) -> ++ Longident.Ldot (lid_of_path p1, s) ++ | Path.Papply (p1, p2) -> ++ Longident.Lapply (lid_of_path p1, lid_of_path p2) ++ | Path.Pextra_ty (p, Pext_ty) -> lid_of_path p ++ ++let is_unambiguous path env = ++ let l = Env.find_shadowed_types path env in ++ List.exists (Path.same path) l || (* concrete paths are ok *) ++ match l with ++ [] -> true ++ | p :: rem -> ++ (* allow also coherent paths: *) ++ let normalize p = fst (normalize_type_path ~cache:true env p) in ++ let p' = normalize p in ++ List.for_all (fun p -> Path.same (normalize p) p') rem || ++ (* also allow repeatedly defining and opening (for toplevel) *) ++ let id = lid_of_path p in ++ List.for_all (fun p -> lid_of_path p = id) rem && ++ Path.same p (fst (Env.find_type_by_name id env)) ++ ++let rec get_best_path r = ++ match !r with ++ Best p' -> p' ++ | Paths [] -> raise Not_found ++ | Paths l -> ++ r := Paths []; ++ List.iter ++ (fun p -> ++ (* Format.eprintf "evaluating %a@." path p; *) ++ match !r with ++ Best p' when path_size p >= path_size p' -> () ++ | _ -> if is_unambiguous p !printing_env then r := Best p) ++ (* else Format.eprintf "%a ignored as ambiguous@." path p *) ++ l; ++ get_best_path r ++ ++let best_type_path p = ++ if !printing_env == Env.empty ++ then (p, Id) ++ else if !Clflags.real_paths ++ then (p, Id) ++ else ++ let (p', s) = normalize_type_path !printing_env p in ++ let get_path () = get_best_path (Path.Map.find p' !printing_map) in ++ while !printing_cont <> [] && ++ try fst (path_size (get_path ())) > !printing_depth with Not_found -> true ++ do ++ printing_cont := List.map snd (Env.run_iter_cont !printing_cont); ++ incr printing_depth; ++ done; ++ let p'' = try get_path () with Not_found -> p' in ++ (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) ++ (p'', s) ++ ++(* When building a tree for a best type path, we should not disambiguate ++ identifiers whenever the short-path algorithm detected a better path than ++ the original one.*) ++let tree_of_best_type_path p p' = ++ if Path.same p p' then tree_of_path (Some Type) p' ++ else tree_of_path ~disambiguation:false None p' ++ ++(* Print a type expression *) ++ ++let proxy ty = Transient_expr.repr (proxy ty) ++ ++(* When printing a type scheme, we print weak names. When printing a plain ++ type, we do not. This type controls that behavior *) ++type type_or_scheme = Type | Type_scheme ++ ++let is_non_gen mode ty = ++ match mode with ++ | Type_scheme -> is_Tvar ty && get_level ty <> generic_level ++ | Type -> false ++ ++let nameable_row row = ++ row_name row <> None && ++ List.for_all ++ (fun (_, f) -> ++ match row_field_repr f with ++ | Reither(c, l, _) -> ++ row_closed row && if c then l = [] else List.length l = 1 ++ | _ -> true) ++ (row_fields row) ++ ++(* This specialized version of [Btype.iter_type_expr] normalizes and ++ short-circuits the traversal of the [type_expr], so that it covers only the ++ subterms that would be printed by the type printer. *) ++let printer_iter_type_expr f ty = ++ match get_desc ty with ++ | Tconstr(p, tyl, _) -> ++ let (_p', s) = best_type_path p in ++ List.iter f (apply_subst s tyl) ++ | Tvariant row -> begin ++ match row_name row with ++ | Some(_p, tyl) when nameable_row row -> ++ List.iter f tyl ++ | _ -> ++ iter_row f row ++ end ++ | Tobject (fi, nm) -> begin ++ match !nm with ++ | None -> ++ let fields, _ = flatten_fields fi in ++ List.iter ++ (fun (_, kind, ty) -> ++ if field_kind_repr kind = Fpublic then ++ f ty) ++ fields ++ | Some (_, l) -> ++ List.iter f (List.tl l) ++ end ++ | Tfield(_, kind, ty1, ty2) -> ++ if field_kind_repr kind = Fpublic then ++ f ty1; ++ f ty2 ++ | _ -> ++ Btype.iter_type_expr f ty ++ ++let quoted_ident ppf x = ++ Style.as_inline_code !Oprint.out_ident ppf x ++ ++module Internal_names : sig ++ ++ val reset : unit -> unit ++ ++ val add : Path.t -> unit ++ ++ val print_explanations : Env.t -> Fmt.formatter -> unit ++ ++end = struct ++ ++ let names = ref Ident.Set.empty ++ ++ let reset () = ++ names := Ident.Set.empty ++ ++ let add p = ++ match p with ++ | Pident id -> ++ let name = Ident.name id in ++ if String.length name > 0 && name.[0] = '$' then begin ++ names := Ident.Set.add id !names ++ end ++ | Pdot _ | Papply _ | Pextra_ty _ -> () ++ ++ let print_explanations env ppf = ++ let constrs = ++ Ident.Set.fold ++ (fun id acc -> ++ let p = Pident id in ++ match Env.find_type p env with ++ | exception Not_found -> acc ++ | decl -> ++ match type_origin decl with ++ | Existential constr -> ++ let prev = String.Map.find_opt constr acc in ++ let prev = Option.value ~default:[] prev in ++ String.Map.add constr (tree_of_path None p :: prev) acc ++ | Definition | Rec_check_regularity -> acc) ++ !names String.Map.empty ++ in ++ String.Map.iter ++ (fun constr out_idents -> ++ match out_idents with ++ | [] -> () ++ | [out_ident] -> ++ fprintf ppf ++ "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ ++ bound by the constructor@ %a.@]" ++ quoted_ident out_ident ++ Style.inline_code constr ++ | out_ident :: out_idents -> ++ fprintf ppf ++ "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ ++ bound by the constructor@ %a.@]" ++ (Fmt.pp_print_list ++ ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") ++ quoted_ident) ++ (List.rev out_idents) ++ quoted_ident out_ident ++ Style.inline_code constr) ++ constrs ++ ++end ++ ++module Variable_names : sig ++ val reset_names : unit -> unit ++ ++ val add_subst : (type_expr * type_expr) list -> unit ++ ++ val new_name : unit -> string ++ val new_var_name : non_gen:bool -> type_expr -> unit -> string ++ ++ val name_of_type : (unit -> string) -> transient_expr -> string ++ val check_name_of_type : non_gen:bool -> transient_expr -> unit ++ ++ ++ val reserve: type_expr -> unit ++ ++ val remove_names : transient_expr list -> unit ++ ++ val with_local_names : (unit -> 'a) -> 'a ++ ++ (* Refresh the weak variable map in the toplevel; for [print_items], which is ++ itself for the toplevel *) ++ val refresh_weak : unit -> unit ++end = struct ++ (* We map from types to names, but not directly; we also store a substitution, ++ which maps from types to types. The lookup process is ++ "type -> apply substitution -> find name". The substitution is presumed to ++ be one-shot. *) ++ let names = ref ([] : (transient_expr * string) list) ++ let name_subst = ref ([] : (transient_expr * transient_expr) list) ++ let name_counter = ref 0 ++ let named_vars = ref ([] : string list) ++ let visited_for_named_vars = ref ([] : transient_expr list) ++ ++ let weak_counter = ref 1 ++ let weak_var_map = ref TypeMap.empty ++ let named_weak_vars = ref String.Set.empty ++ ++ let reset_names () = ++ names := []; ++ name_subst := []; ++ name_counter := 0; ++ named_vars := []; ++ visited_for_named_vars := [] ++ ++ let add_named_var tty = ++ match tty.desc with ++ Tvar (Some name) | Tunivar (Some name) -> ++ if List.mem name !named_vars then () else ++ named_vars := name :: !named_vars ++ | _ -> () ++ ++ let rec add_named_vars ty = ++ let tty = Transient_expr.repr ty in ++ let px = proxy ty in ++ if not (List.memq px !visited_for_named_vars) then begin ++ visited_for_named_vars := px :: !visited_for_named_vars; ++ match tty.desc with ++ | Tvar _ | Tunivar _ -> ++ add_named_var tty ++ | _ -> ++ printer_iter_type_expr add_named_vars ty ++ end ++ ++ let substitute ty = ++ match List.assq ty !name_subst with ++ | ty' -> ty' ++ | exception Not_found -> ty ++ ++ let add_subst subst = ++ name_subst := ++ List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) ++ subst ++ @ !name_subst ++ ++ let name_is_already_used name = ++ List.mem name !named_vars ++ || List.exists (fun (_, name') -> name = name') !names ++ || String.Set.mem name !named_weak_vars ++ ++ let rec new_name () = ++ let name = Misc.letter_of_int !name_counter in ++ incr name_counter; ++ if name_is_already_used name then new_name () else name ++ ++ let rec new_weak_name ty () = ++ let name = "weak" ^ Int.to_string !weak_counter in ++ incr weak_counter; ++ if name_is_already_used name then new_weak_name ty () ++ else begin ++ named_weak_vars := String.Set.add name !named_weak_vars; ++ weak_var_map := TypeMap.add ty name !weak_var_map; ++ name ++ end ++ ++ let new_var_name ~non_gen ty () = ++ if non_gen then new_weak_name ty () ++ else new_name () ++ ++ let name_of_type name_generator t = ++ (* We've already been through repr at this stage, so t is our representative ++ of the union-find class. *) ++ let t = substitute t in ++ try List.assq t !names with Not_found -> ++ try TransientTypeMap.find t !weak_var_map with Not_found -> ++ let name = ++ match t.desc with ++ Tvar (Some name) | Tunivar (Some name) -> ++ (* Some part of the type we've already printed has assigned another ++ * unification variable to that name. We want to keep the name, so ++ * try adding a number until we find a name that's not taken. *) ++ let available name = ++ List.for_all ++ (fun (_, name') -> name <> name') ++ !names ++ in ++ if available name then name ++ else ++ let suffixed i = name ^ Int.to_string i in ++ let i = Misc.find_first_mono (fun i -> available (suffixed i)) in ++ suffixed i ++ | _ -> ++ (* No name available, create a new one *) ++ name_generator () ++ in ++ (* Exception for type declarations *) ++ if name <> "_" then names := (t, name) :: !names; ++ name ++ ++ let check_name_of_type ~non_gen px = ++ let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in ++ ignore(name_of_type name_gen px) ++ ++ let remove_names tyl = ++ let tyl = List.map substitute tyl in ++ names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names ++ ++ let with_local_names f = ++ let old_names = !names in ++ let old_subst = !name_subst in ++ names := []; ++ name_subst := []; ++ try_finally ++ ~always:(fun () -> ++ names := old_names; ++ name_subst := old_subst) ++ f ++ ++ let refresh_weak () = ++ let refresh t name (m,s) = ++ if is_non_gen Type_scheme t then ++ begin ++ TypeMap.add t name m, ++ String.Set.add name s ++ end ++ else m, s in ++ let m, s = ++ TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in ++ named_weak_vars := s; ++ weak_var_map := m ++ ++ let reserve ty = ++ normalize_type ty; ++ add_named_vars ty ++end ++ ++module Aliases = struct ++ let visited_objects = ref ([] : transient_expr list) ++ let aliased = ref ([] : transient_expr list) ++ let delayed = ref ([] : transient_expr list) ++ let printed_aliases = ref ([] : transient_expr list) ++ ++(* [printed_aliases] is a subset of [aliased] that records only those aliased ++ types that have actually been printed; this allows us to avoid naming loops ++ that the user will never see. *) ++ ++ let is_delayed t = List.memq t !delayed ++ ++ let remove_delay t = ++ if is_delayed t then ++ delayed := List.filter ((!=) t) !delayed ++ ++ let add_delayed t = ++ if not (is_delayed t) then delayed := t :: !delayed ++ ++ let is_aliased_proxy px = List.memq px !aliased ++ let is_printed_proxy px = List.memq px !printed_aliases ++ ++ let add_proxy px = ++ if not (is_aliased_proxy px) then ++ aliased := px :: !aliased ++ ++ let add ty = add_proxy (proxy ty) ++ ++ let add_printed_proxy ~non_gen px = ++ Variable_names.check_name_of_type ~non_gen px; ++ printed_aliases := px :: !printed_aliases ++ ++ let mark_as_printed px = ++ if is_aliased_proxy px then (add_printed_proxy ~non_gen:false) px ++ ++ let add_printed ty = add_printed_proxy (proxy ty) ++ ++ let aliasable ty = ++ match get_desc ty with ++ Tvar _ | Tunivar _ | Tpoly _ -> false ++ | Tconstr (p, _, _) -> ++ not (is_nth (snd (best_type_path p))) ++ | _ -> true ++ ++ let should_visit_object ty = ++ match get_desc ty with ++ | Tvariant row -> not (static_row row) ++ | Tobject _ -> opened_object ty ++ | _ -> false ++ ++ let rec mark_loops_rec visited ty = ++ let px = proxy ty in ++ if List.memq px visited && aliasable ty then add_proxy px else ++ let tty = Transient_expr.repr ty in ++ let visited = px :: visited in ++ match tty.desc with ++ | Tvariant _ | Tobject _ -> ++ if List.memq px !visited_objects then add_proxy px else begin ++ if should_visit_object ty then ++ visited_objects := px :: !visited_objects; ++ printer_iter_type_expr (mark_loops_rec visited) ty ++ end ++ | Tpoly(ty, tyl) -> ++ List.iter add tyl; ++ mark_loops_rec visited ty ++ | _ -> ++ printer_iter_type_expr (mark_loops_rec visited) ty ++ ++ let mark_loops ty = ++ mark_loops_rec [] ty ++ ++ let reset () = ++ visited_objects := []; aliased := []; delayed := []; printed_aliases := [] ++ ++end ++ ++let prepare_type ty = ++ Variable_names.reserve ty; ++ Aliases.mark_loops ty ++ ++ ++let reset_except_conflicts () = ++ Variable_names.reset_names (); Aliases.reset (); Internal_names.reset () ++ ++let reset () = ++ Ident_conflicts.reset (); ++ reset_except_conflicts () ++ ++let prepare_for_printing tyl = ++ reset_except_conflicts (); ++ List.iter prepare_type tyl ++ ++let add_type_to_preparation = prepare_type ++ ++(* Disabled in classic mode when printing an unification error *) ++let print_labels = ref true ++let with_labels b f = Misc.protect_refs [R (print_labels,b)] f ++ ++let alias_nongen_row mode px ty = ++ match get_desc ty with ++ | Tvariant _ | Tobject _ -> ++ if is_non_gen mode (Transient_expr.type_expr px) then ++ Aliases.add_proxy px ++ | _ -> () ++ ++let rec tree_of_typexp mode ty = ++ let px = proxy ty in ++ if Aliases.is_printed_proxy px && not (Aliases.is_delayed px) then ++ let non_gen = is_non_gen mode (Transient_expr.type_expr px) in ++ let name = Variable_names.(name_of_type (new_var_name ~non_gen ty)) px in ++ Otyp_var (non_gen, name) else ++ ++ let pr_typ () = ++ let tty = Transient_expr.repr ty in ++ match tty.desc with ++ | Tvar _ -> ++ let non_gen = is_non_gen mode ty in ++ let name_gen = Variable_names.new_var_name ~non_gen ty in ++ Otyp_var (non_gen, Variable_names.name_of_type name_gen tty) ++ | Tarrow(l, ty1, ty2, _) -> ++ let lab = ++ if !print_labels || is_optional l then l else Nolabel ++ in ++ let t1 = ++ if is_optional l then ++ match get_desc ty1 with ++ | Tconstr(path, [ty], _) ++ when Path.same path Predef.path_option -> ++ tree_of_typexp mode ty ++ | _ -> Otyp_stuff "" ++ else tree_of_typexp mode ty1 in ++ Otyp_arrow (lab, t1, tree_of_typexp mode ty2) ++ | Ttuple tyl -> ++ Otyp_tuple (tree_of_typlist mode tyl) ++ | Tconstr(p, tyl, _abbrev) -> ++ let p', s = best_type_path p in ++ let tyl' = apply_subst s tyl in ++ if is_nth s && not (tyl'=[]) ++ then tree_of_typexp mode (List.hd tyl') ++ else begin ++ Internal_names.add p'; ++ Otyp_constr (tree_of_best_type_path p p', tree_of_typlist mode tyl') ++ end ++ | Tvariant row -> ++ let Row {fields; name; closed; _} = row_repr row in ++ let fields = ++ if closed then ++ List.filter (fun (_, f) -> row_field_repr f <> Rabsent) ++ fields ++ else fields in ++ let present = ++ List.filter ++ (fun (_, f) -> ++ match row_field_repr f with ++ | Rpresent _ -> true ++ | _ -> false) ++ fields in ++ let all_present = List.length present = List.length fields in ++ begin match name with ++ | Some(p, tyl) when nameable_row row -> ++ let (p', s) = best_type_path p in ++ let id = tree_of_best_type_path p p' in ++ let args = tree_of_typlist mode (apply_subst s tyl) in ++ let out_variant = ++ if is_nth s then List.hd args else Otyp_constr (id, args) in ++ if closed && all_present then ++ out_variant ++ else ++ let tags = ++ if all_present then None else Some (List.map fst present) in ++ Otyp_variant (Ovar_typ out_variant, closed, tags) ++ | _ -> ++ let fields = List.map (tree_of_row_field mode) fields in ++ let tags = ++ if all_present then None else Some (List.map fst present) in ++ Otyp_variant (Ovar_fields fields, closed, tags) ++ end ++ | Tobject (fi, nm) -> ++ tree_of_typobject mode fi !nm ++ | Tnil | Tfield _ -> ++ tree_of_typobject mode ty None ++ | Tsubst _ -> ++ (* This case should only happen when debugging the compiler *) ++ Otyp_stuff "" ++ | Tlink _ -> ++ fatal_error "Out_type.tree_of_typexp" ++ | Tpoly (ty, []) -> ++ tree_of_typexp mode ty ++ | Tpoly (ty, tyl) -> ++ (*let print_names () = ++ List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; ++ prerr_string "; " in *) ++ if tyl = [] then tree_of_typexp mode ty else begin ++ let tyl = List.map Transient_expr.repr tyl in ++ let old_delayed = !Aliases.delayed in ++ (* Make the names delayed, so that the real type is ++ printed once when used as proxy *) ++ List.iter Aliases.add_delayed tyl; ++ let tl = List.map Variable_names.(name_of_type new_name) tyl in ++ let tr = Otyp_poly (tl, tree_of_typexp mode ty) in ++ (* Forget names when we leave scope *) ++ Variable_names.remove_names tyl; ++ Aliases.delayed := old_delayed; tr ++ end ++ | Tunivar _ -> ++ Otyp_var (false, Variable_names.(name_of_type new_name) tty) ++ | Tpackage (p, fl) -> ++ let fl = ++ List.map ++ (fun (li, ty) -> ( ++ String.concat "." (Longident.flatten li), ++ tree_of_typexp mode ty ++ )) fl in ++ Otyp_module (tree_of_path (Some Module_type) p, fl) ++ in ++ Aliases.remove_delay px; ++ alias_nongen_row mode px ty; ++ if Aliases.(is_aliased_proxy px && aliasable ty) then begin ++ let non_gen = is_non_gen mode (Transient_expr.type_expr px) in ++ Aliases.add_printed_proxy ~non_gen px; ++ (* add_printed_alias chose a name, thus the name generator ++ doesn't matter.*) ++ let alias = Variable_names.(name_of_type (new_var_name ~non_gen ty)) px in ++ Otyp_alias {non_gen; aliased = pr_typ (); alias } end ++ else pr_typ () ++ ++and tree_of_row_field mode (l, f) = ++ match row_field_repr f with ++ | Rpresent None | Reither(true, [], _) -> (l, false, []) ++ | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) ++ | Reither(c, tyl, _) -> ++ if c (* contradiction: constant constructor with an argument *) ++ then (l, true, tree_of_typlist mode tyl) ++ else (l, false, tree_of_typlist mode tyl) ++ | Rabsent -> (l, false, [] (* actually, an error *)) ++ ++and tree_of_typlist mode tyl = ++ List.map (tree_of_typexp mode) tyl ++ ++and tree_of_typobject mode fi nm = ++ begin match nm with ++ | None -> ++ let pr_fields fi = ++ let (fields, rest) = flatten_fields fi in ++ let present_fields = ++ List.fold_right ++ (fun (n, k, t) l -> ++ match field_kind_repr k with ++ | Fpublic -> (n, t) :: l ++ | _ -> l) ++ fields [] in ++ let sorted_fields = ++ List.sort ++ (fun (n, _) (n', _) -> String.compare n n') present_fields in ++ tree_of_typfields mode rest sorted_fields in ++ let (fields, open_row) = pr_fields fi in ++ Otyp_object {fields; open_row} ++ | Some (p, _ty :: tyl) -> ++ let args = tree_of_typlist mode tyl in ++ let (p', s) = best_type_path p in ++ assert (s = Id); ++ Otyp_class (tree_of_best_type_path p p', args) ++ | _ -> ++ fatal_error "Out_type.tree_of_typobject" ++ end ++ ++and tree_of_typfields mode rest = function ++ | [] -> ++ let open_row = ++ match get_desc rest with ++ | Tvar _ | Tunivar _ | Tconstr _-> true ++ | Tnil -> false ++ | _ -> fatal_error "typfields (1)" ++ in ++ ([], open_row) ++ | (s, t) :: l -> ++ let field = (s, tree_of_typexp mode t) in ++ let (fields, rest) = tree_of_typfields mode rest l in ++ (field :: fields, rest) ++ ++let typexp mode ppf ty = ++ !Oprint.out_type ppf (tree_of_typexp mode ty) ++ ++let prepared_type_expr ppf ty = typexp Type ppf ty ++ ++(* "Half-prepared" type expression: [ty] should have had its names reserved, but ++ should not have had its loops marked. *) ++let type_expr_with_reserved_names ppf ty = ++ Aliases.reset (); ++ Aliases.mark_loops ty; ++ prepared_type_expr ppf ty ++ ++ ++let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty ++ ++(* Print one type declaration *) ++ ++let tree_of_constraints params = ++ List.fold_right ++ (fun ty list -> ++ let ty' = unalias ty in ++ if proxy ty != proxy ty' then ++ let tr = tree_of_typexp Type_scheme ty in ++ (tr, tree_of_typexp Type_scheme ty') :: list ++ else list) ++ params [] ++ ++let filter_params tyl = ++ let params = ++ List.fold_left ++ (fun tyl ty -> ++ if List.exists (eq_type ty) tyl ++ then newty2 ~level:generic_level (Ttuple [ty]) :: tyl ++ else ty :: tyl) ++ (* Two parameters might be identical due to a constraint but we need to ++ print them differently in order to make the output syntactically valid. ++ We use [Ttuple [ty]] because it is printed as [ty]. *) ++ (* Replacing fold_left by fold_right does not work! *) ++ [] tyl ++ in List.rev params ++ ++let prepare_type_constructor_arguments = function ++ | Cstr_tuple l -> List.iter prepare_type l ++ | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l ++ ++let tree_of_label l = ++ { ++ olab_name = Ident.name l.ld_id; ++ olab_mut = l.ld_mutable; ++ olab_type = tree_of_typexp Type l.ld_type; ++ } ++ ++let tree_of_constructor_arguments = function ++ | Cstr_tuple l -> tree_of_typlist Type l ++ | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] ++ ++let tree_of_single_constructor cd = ++ let name = Ident.name cd.cd_id in ++ let ret = Option.map (tree_of_typexp Type) cd.cd_res in ++ let args = tree_of_constructor_arguments cd.cd_args in ++ { ++ ocstr_name = name; ++ ocstr_args = args; ++ ocstr_return_type = ret; ++ } ++ ++(* When printing GADT constructor, we need to forget the naming decision we took ++ for the type parameters and constraints. Indeed, in ++ {[ ++ type 'a t = X: 'a -> 'b t ++ ]} ++ It is fine to print both the type parameter ['a] and the existentially ++ quantified ['a] in the definition of the constructor X as ['a] ++ *) ++let tree_of_constructor_in_decl cd = ++ match cd.cd_res with ++ | None -> tree_of_single_constructor cd ++ | Some _ -> ++ Variable_names.with_local_names (fun () -> tree_of_single_constructor cd) ++ ++let prepare_decl id decl = ++ let params = filter_params decl.type_params in ++ begin match decl.type_manifest with ++ | Some ty -> ++ let vars = free_variables ty in ++ List.iter ++ (fun ty -> ++ if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars ++ then set_type_desc ty (Tvar None)) ++ params ++ | None -> () ++ end; ++ List.iter Aliases.add params; ++ List.iter prepare_type params; ++ List.iter (Aliases.add_printed ~non_gen:false) params; ++ let ty_manifest = ++ match decl.type_manifest with ++ | None -> None ++ | Some ty -> ++ let ty = ++ (* Special hack to hide variant name *) ++ match get_desc ty with ++ Tvariant row -> ++ begin match row_name row with ++ Some (Pident id', _) when Ident.same id id' -> ++ newgenty (Tvariant (set_row_name row None)) ++ | _ -> ty ++ end ++ | _ -> ty ++ in ++ prepare_type ty; ++ Some ty ++ in ++ begin match decl.type_kind with ++ | Type_abstract _ -> () ++ | Type_variant (cstrs, _rep) -> ++ List.iter ++ (fun c -> ++ prepare_type_constructor_arguments c.cd_args; ++ Option.iter prepare_type c.cd_res) ++ cstrs ++ | Type_record(l, _rep) -> ++ List.iter (fun l -> prepare_type l.ld_type) l ++ | Type_open -> () ++ end; ++ ty_manifest, params ++ ++let tree_of_type_decl id decl = ++ let ty_manifest, params = prepare_decl id decl in ++ let type_param ot_variance = ++ function ++ | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} ++ | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} ++ in ++ let type_defined decl = ++ let abstr = ++ match decl.type_kind with ++ Type_abstract _ -> ++ decl.type_manifest = None || decl.type_private = Private ++ | Type_record _ -> ++ decl.type_private = Private ++ | Type_variant (tll, _rep) -> ++ decl.type_private = Private || ++ List.exists (fun cd -> cd.cd_res <> None) tll ++ | Type_open -> ++ decl.type_manifest = None ++ in ++ let vari = ++ List.map2 ++ (fun ty v -> ++ let is_var = is_Tvar ty in ++ if abstr || not is_var then ++ let inj = ++ type_kind_is_abstract decl && Variance.mem Inj v && ++ match decl.type_manifest with ++ | None -> true ++ | Some ty -> (* only abstract or private row types *) ++ decl.type_private = Private && ++ Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty) ++ and (co, cn) = Variance.get_upper v in ++ (if not cn then Covariant else ++ if not co then Contravariant else NoVariance), ++ (if inj then Injective else NoInjectivity) ++ else (NoVariance, NoInjectivity)) ++ decl.type_params decl.type_variance ++ in ++ (Ident.name id, ++ List.map2 (fun ty cocn -> type_param cocn (tree_of_typexp Type ty)) ++ params vari) ++ in ++ let tree_of_manifest ty1 = ++ match ty_manifest with ++ | None -> ty1 ++ | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) ++ in ++ let (name, args) = type_defined decl in ++ let constraints = tree_of_constraints params in ++ let ty, priv, unboxed = ++ match decl.type_kind with ++ | Type_abstract _ -> ++ begin match ty_manifest with ++ | None -> (Otyp_abstract, Public, false) ++ | Some ty -> ++ tree_of_typexp Type ty, decl.type_private, false ++ end ++ | Type_variant (cstrs, rep) -> ++ tree_of_manifest ++ (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), ++ decl.type_private, ++ (rep = Variant_unboxed) ++ | Type_record(lbls, rep) -> ++ tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), ++ decl.type_private, ++ (match rep with Record_unboxed _ -> true | _ -> false) ++ | Type_open -> ++ tree_of_manifest Otyp_open, ++ decl.type_private, ++ false ++ in ++ { otype_name = name; ++ otype_params = args; ++ otype_type = ty; ++ otype_private = priv; ++ otype_immediate = Type_immediacy.of_attributes decl.type_attributes; ++ otype_unboxed = unboxed; ++ otype_cstrs = constraints } ++ ++let add_type_decl_to_preparation id decl = ++ ignore @@ prepare_decl id decl ++ ++let tree_of_prepared_type_decl id decl = ++ tree_of_type_decl id decl ++ ++let tree_of_type_decl id decl = ++ reset_except_conflicts(); ++ tree_of_type_decl id decl ++ ++let add_constructor_to_preparation c = ++ prepare_type_constructor_arguments c.cd_args; ++ Option.iter prepare_type c.cd_res ++ ++let prepared_constructor ppf c = ++ !Oprint.out_constr ppf (tree_of_single_constructor c) ++ ++ ++let tree_of_type_declaration id decl rs = ++ Osig_type (tree_of_type_decl id decl, tree_of_rec rs) ++ ++let tree_of_prepared_type_declaration id decl rs = ++ Osig_type (tree_of_prepared_type_decl id decl, tree_of_rec rs) ++ ++let add_type_declaration_to_preparation id decl = ++ add_type_decl_to_preparation id decl ++ ++let prepared_type_declaration id ppf decl = ++ !Oprint.out_sig_item ppf ++ (tree_of_prepared_type_declaration id decl Trec_first) ++ ++ ++(* When printing extension constructor, it is important to ensure that ++after printing the constructor, we are still in the scope of the constructor. ++For GADT constructor, this can be done by printing the type parameters inside ++their own isolated scope. This ensures that in ++{[ ++ type 'b t += A: 'b -> 'b any t ++]} ++the type parameter `'b` is not bound when printing the type variable `'b` from ++the constructor definition from the type parameter. ++ ++Contrarily, for non-gadt constructor, we must keep the same scope for ++the type parameters and the constructor because a type constraint may ++have changed the name of the type parameter: ++{[ ++type -'a t = .. constraint 'a> = 'a ++(* the universal 'a is here to steal the name 'a from the type parameter *) ++type 'a t = X of 'a ++]} *) ++let add_extension_constructor_to_preparation ext = ++ let ty_params = filter_params ext.ext_type_params in ++ List.iter Aliases.add ty_params; ++ List.iter prepare_type ty_params; ++ prepare_type_constructor_arguments ext.ext_args; ++ Option.iter prepare_type ext.ext_ret_type ++ ++let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = ++ let ret = Option.map (tree_of_typexp Type) ext_ret_type in ++ let args = tree_of_constructor_arguments ext_args in ++ (args, ret) ++ ++let prepared_tree_of_extension_constructor ++ id ext es ++ = ++ let ty_name = Path.name ext.ext_type_path in ++ let ty_params = filter_params ext.ext_type_params in ++ let type_param = ++ function ++ | Otyp_var (_, id) -> id ++ | _ -> "?" ++ in ++ let param_scope f = ++ match ext.ext_ret_type with ++ | None -> ++ (* normal constructor: same scope for parameters and the constructor *) ++ f () ++ | Some _ -> ++ (* gadt constructor: isolated scope for the type parameters *) ++ Variable_names.with_local_names f ++ in ++ let ty_params = ++ param_scope ++ (fun () -> ++ List.iter (Aliases.add_printed ~non_gen:false) ty_params; ++ List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params ++ ) ++ in ++ let name = Ident.name id in ++ let args, ret = ++ extension_constructor_args_and_ret_type_subtree ++ ext.ext_args ++ ext.ext_ret_type ++ in ++ let ext = ++ { oext_name = name; ++ oext_type_name = ty_name; ++ oext_type_params = ty_params; ++ oext_args = args; ++ oext_ret_type = ret; ++ oext_private = ext.ext_private } ++ in ++ let es = ++ match es with ++ Text_first -> Oext_first ++ | Text_next -> Oext_next ++ | Text_exception -> Oext_exception ++ in ++ Osig_typext (ext, es) ++ ++let tree_of_extension_constructor id ext es = ++ reset_except_conflicts (); ++ add_extension_constructor_to_preparation ext; ++ prepared_tree_of_extension_constructor id ext es ++ ++let prepared_extension_constructor id ppf ext = ++ !Oprint.out_sig_item ppf ++ (prepared_tree_of_extension_constructor id ext Text_first) ++ ++(* Print a value declaration *) ++ ++let tree_of_value_description id decl = ++ (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) ++ let id = Ident.name id in ++ let () = prepare_for_printing [decl.val_type] in ++ let ty = tree_of_typexp Type_scheme decl.val_type in ++ let vd = ++ { oval_name = id; ++ oval_type = ty; ++ oval_prims = []; ++ oval_attributes = [] } ++ in ++ let vd = ++ match decl.val_kind with ++ | Val_prim p -> Primitive.print p vd ++ | _ -> vd ++ in ++ Osig_value vd ++ ++(* Print a class type *) ++ ++let method_type priv ty = ++ match priv, get_desc ty with ++ | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) ++ | _ , _ -> (ty, []) ++ ++let prepare_method _lab (priv, _virt, ty) = ++ let ty, _ = method_type priv ty in ++ prepare_type ty ++ ++let tree_of_method mode (lab, priv, virt, ty) = ++ let (ty, tyl) = method_type priv ty in ++ let tty = tree_of_typexp mode ty in ++ Variable_names.remove_names (List.map Transient_expr.repr tyl); ++ let priv = priv <> Mpublic in ++ let virt = virt = Virtual in ++ Ocsg_method (lab, priv, virt, tty) ++ ++let rec prepare_class_type params = function ++ | Cty_constr (_p, tyl, cty) -> ++ let row = Btype.self_type_row cty in ++ if List.memq (proxy row) !Aliases.visited_objects ++ || not (List.for_all is_Tvar params) ++ || List.exists (deep_occur row) tyl ++ then prepare_class_type params cty ++ else List.iter prepare_type tyl ++ | Cty_signature sign -> ++ (* Self may have a name *) ++ let px = proxy sign.csig_self_row in ++ if List.memq px !Aliases.visited_objects then Aliases.add_proxy px ++ else Aliases.(visited_objects := px :: !visited_objects); ++ Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; ++ Meths.iter prepare_method sign.csig_meths ++ | Cty_arrow (_, ty, cty) -> ++ prepare_type ty; ++ prepare_class_type params cty ++ ++let rec tree_of_class_type mode params = ++ function ++ | Cty_constr (p', tyl, cty) -> ++ let row = Btype.self_type_row cty in ++ if List.memq (proxy row) !Aliases.visited_objects ++ || not (List.for_all is_Tvar params) ++ then ++ tree_of_class_type mode params cty ++ else ++ let namespace = Namespace.best_class_namespace p' in ++ Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) ++ | Cty_signature sign -> ++ let px = proxy sign.csig_self_row in ++ let self_ty = ++ if Aliases.is_aliased_proxy px then ++ Some ++ (Otyp_var (false, Variable_names.(name_of_type new_name) px)) ++ else None ++ in ++ let csil = [] in ++ let csil = ++ List.fold_left ++ (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) ++ csil (tree_of_constraints params) ++ in ++ let all_vars = ++ Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] ++ in ++ (* Consequence of PR#3607: order of Map.fold has changed! *) ++ let all_vars = List.rev all_vars in ++ let csil = ++ List.fold_left ++ (fun csil (l, m, v, t) -> ++ Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) ++ :: csil) ++ csil all_vars ++ in ++ let all_meths = ++ Meths.fold ++ (fun l (p, v, t) all -> (l, p, v, t) :: all) ++ sign.csig_meths [] ++ in ++ let all_meths = List.rev all_meths in ++ let csil = ++ List.fold_left ++ (fun csil meth -> tree_of_method mode meth :: csil) ++ csil all_meths ++ in ++ Octy_signature (self_ty, List.rev csil) ++ | Cty_arrow (l, ty, cty) -> ++ let lab = ++ if !print_labels || is_optional l then l else Nolabel ++ in ++ let tr = ++ if is_optional l then ++ match get_desc ty with ++ | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ++ tree_of_typexp mode ty ++ | _ -> Otyp_stuff "" ++ else tree_of_typexp mode ty in ++ Octy_arrow (lab, tr, tree_of_class_type mode params cty) ++ ++ ++let tree_of_class_param param variance = ++ let ot_variance = ++ if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in ++ match tree_of_typexp Type_scheme param with ++ Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} ++ | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} ++ ++let class_variance = ++ let open Variance in let open Asttypes in ++ List.map (fun v -> ++ (if not (mem May_pos v) then Contravariant else ++ if not (mem May_neg v) then Covariant else NoVariance), ++ NoInjectivity) ++ ++let tree_of_class_declaration id cl rs = ++ let params = filter_params cl.cty_params in ++ ++ reset_except_conflicts (); ++ List.iter Aliases.add params; ++ prepare_class_type params cl.cty_type; ++ let px = proxy (Btype.self_type_row cl.cty_type) in ++ List.iter prepare_type params; ++ ++ List.iter (Aliases.add_printed ~non_gen:false) params; ++ if Aliases.is_aliased_proxy px then ++ Aliases.add_printed_proxy ~non_gen:false px; ++ ++ let vir_flag = cl.cty_new = None in ++ Osig_class ++ (vir_flag, Ident.name id, ++ List.map2 tree_of_class_param params (class_variance cl.cty_variance), ++ tree_of_class_type Type_scheme params cl.cty_type, ++ tree_of_rec rs) ++ ++let tree_of_cltype_declaration id cl rs = ++ let params = cl.clty_params in ++ ++ reset_except_conflicts (); ++ List.iter Aliases.add params; ++ prepare_class_type params cl.clty_type; ++ let px = proxy (Btype.self_type_row cl.clty_type) in ++ List.iter prepare_type params; ++ ++ List.iter (Aliases.add_printed ~non_gen:false) params; ++ Aliases.mark_as_printed px; ++ ++ let sign = Btype.signature_of_class_type cl.clty_type in ++ let has_virtual_vars = ++ Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) ++ sign.csig_vars false ++ in ++ let has_virtual_meths = ++ Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) ++ sign.csig_meths false ++ in ++ Osig_class_type ++ (has_virtual_vars || has_virtual_meths, Ident.name id, ++ List.map2 tree_of_class_param params (class_variance cl.clty_variance), ++ tree_of_class_type Type_scheme params cl.clty_type, ++ tree_of_rec rs) ++ ++(* Print a module type *) ++ ++let wrap_env fenv ftree arg = ++ (* We save the current value of the short-path cache *) ++ (* From keys *) ++ let env = !printing_env in ++ let old_pers = !printing_pers in ++ (* to data *) ++ let old_map = !printing_map in ++ let old_depth = !printing_depth in ++ let old_cont = !printing_cont in ++ set_printing_env (fenv env); ++ let tree = ftree arg in ++ if !Clflags.real_paths ++ || same_printing_env env then () ++ (* our cached key is still live in the cache, and we want to keep all ++ progress made on the computation of the [printing_map] *) ++ else begin ++ (* we restore the snapshotted cache before calling set_printing_env *) ++ printing_old := env; ++ printing_pers := old_pers; ++ printing_depth := old_depth; ++ printing_cont := old_cont; ++ printing_map := old_map ++ end; ++ set_printing_env env; ++ tree ++ ++let dummy = ++ { ++ type_params = []; ++ type_arity = 0; ++ type_kind = Type_abstract Definition; ++ type_private = Public; ++ type_manifest = None; ++ type_variance = []; ++ type_separability = []; ++ type_is_newtype = false; ++ type_expansion_scope = Btype.lowest_level; ++ type_loc = Location.none; ++ type_attributes = []; ++ type_immediate = Unknown; ++ type_unboxed_default = false; ++ type_uid = Uid.internal_not_actually_unique; ++ } ++ ++(** we hide items being defined from short-path to avoid shortening ++ [type t = Path.To.t] into [type t = t]. ++*) ++ ++let ident_sigitem = function ++ | Types.Sig_type(ident,_,_,_) -> {hide=true;ident} ++ | Types.Sig_class(ident,_,_,_) ++ | Types.Sig_class_type (ident,_,_,_) ++ | Types.Sig_module(ident,_, _,_,_) ++ | Types.Sig_value (ident,_,_) ++ | Types.Sig_modtype (ident,_,_) ++ | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } ++ ++let hide ids env = ++ let hide_id id env = ++ (* Global idents cannot be renamed *) ++ if id.hide && not (Ident.global id.ident) then ++ Env.add_type ~check:false (Ident.rename id.ident) dummy env ++ else env ++ in ++ List.fold_right hide_id ids env ++ ++let with_hidden_items ids f = ++ let with_hidden_in_printing_env ids f = ++ wrap_env (hide ids) (Ident_names.with_hidden ids) f ++ in ++ if not !Clflags.real_paths then ++ with_hidden_in_printing_env ids f ++ else ++ Ident_names.with_hidden ids f ++ ++ ++let add_sigitem env x = ++ Env.add_signature (Signature_group.flatten x) env ++ ++let rec tree_of_modtype ?(ellipsis=false) = function ++ | Mty_ident p -> ++ Omty_ident (tree_of_path (Some Module_type) p) ++ | Mty_signature sg -> ++ Omty_signature (if ellipsis then [Osig_ellipsis] ++ else tree_of_signature sg) ++ | Mty_functor(param, ty_res) -> ++ let param, env = ++ tree_of_functor_parameter param ++ in ++ let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in ++ Omty_functor (param, res) ++ | Mty_alias p -> ++ Omty_alias (tree_of_path (Some Module) p) ++ ++and tree_of_functor_parameter = function ++ | Unit -> ++ None, fun k -> k ++ | Named (param, ty_arg) -> ++ let name, env = ++ match param with ++ | None -> None, fun env -> env ++ | Some id -> ++ Some (Ident.name id), ++ Env.add_module ~arg:true id Mp_present ty_arg ++ in ++ Some (name, tree_of_modtype ~ellipsis:false ty_arg), env ++ ++and tree_of_signature sg = ++ wrap_env (fun env -> env)(fun sg -> ++ let tree_groups = tree_of_signature_rec !printing_env sg in ++ List.concat_map (fun (_env,l) -> List.map snd l) tree_groups ++ ) sg ++ ++and tree_of_signature_rec env' sg = ++ let structured = List.of_seq (Signature_group.seq sg) in ++ let collect_trees_of_rec_group group = ++ let env = !printing_env in ++ let env', group_trees = ++ trees_of_recursive_sigitem_group env group ++ in ++ set_printing_env env'; ++ (env, group_trees) in ++ set_printing_env env'; ++ List.map collect_trees_of_rec_group structured ++ ++and trees_of_recursive_sigitem_group env ++ (syntactic_group: Signature_group.rec_group) = ++ let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in ++ let env = Env.add_signature syntactic_group.pre_ghosts env in ++ match syntactic_group.group with ++ | Not_rec x -> add_sigitem env x, [display x] ++ | Rec_group items -> ++ let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in ++ List.fold_left add_sigitem env items, ++ with_hidden_items ids (fun () -> List.map display items) ++ ++and tree_of_sigitem = function ++ | Sig_value(id, decl, _) -> ++ tree_of_value_description id decl ++ | Sig_type(id, decl, rs, _) -> ++ tree_of_type_declaration id decl rs ++ | Sig_typext(id, ext, es, _) -> ++ tree_of_extension_constructor id ext es ++ | Sig_module(id, _, md, rs, _) -> ++ let ellipsis = ++ List.exists (function ++ | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true ++ | _ -> false) ++ md.md_attributes in ++ tree_of_module id md.md_type rs ~ellipsis ++ | Sig_modtype(id, decl, _) -> ++ tree_of_modtype_declaration id decl ++ | Sig_class(id, decl, rs, _) -> ++ tree_of_class_declaration id decl rs ++ | Sig_class_type(id, decl, rs, _) -> ++ tree_of_cltype_declaration id decl rs ++ ++and tree_of_modtype_declaration id decl = ++ let mty = ++ match decl.mtd_type with ++ | None -> Omty_abstract ++ | Some mty -> tree_of_modtype mty ++ in ++ Osig_modtype (Ident.name id, mty) ++ ++and tree_of_module id ?ellipsis mty rs = ++ Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) ++ ++(* For the toplevel: merge with tree_of_signature? *) ++let print_items showval env x = ++ Variable_names.refresh_weak(); ++ Ident_conflicts.reset (); ++ let extend_val env (sigitem,outcome) = outcome, showval env sigitem in ++ let post_process (env,l) = List.map (extend_val env) l in ++ List.concat_map post_process @@ tree_of_signature_rec env x ++ ++let same_path t t' = ++ let open Types in ++ eq_type t t' || ++ match get_desc t, get_desc t' with ++ Tconstr(p,tl,_), Tconstr(p',tl',_) -> ++ let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in ++ begin match s1, s2 with ++ Nth n1, Nth n2 when n1 = n2 -> true ++ | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> ++ let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in ++ List.length tl = List.length tl' && ++ List.for_all2 eq_type tl tl' ++ | _ -> false ++ end ++ | _ -> ++ false ++ ++type 'a diff = Same of 'a | Diff of 'a * 'a ++ ++let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = ++ Aliases.reset (); ++ Aliases.mark_loops t; ++ if same_path t t' ++ then begin Aliases.add_delayed (proxy t); Same (tree_of_typexp mode t) end ++ else begin ++ Aliases.mark_loops t'; ++ let t' = if proxy t == proxy t' then unalias t' else t' in ++ (* beware order matter due to side effect, ++ e.g. when printing object types *) ++ let first = tree_of_typexp mode t in ++ let second = tree_of_typexp mode t' in ++ if first = second then Same first ++ else Diff(first,second) ++ end ++ ++let pp_type ppf t = ++ Style.as_inline_code !Oprint.out_type ppf t ++ ++let pp_type_expansion ppf = function ++ | Same t -> pp_type ppf t ++ | Diff(t,t') -> ++ fprintf ppf "@[<2>%a@ =@ %a@]" ++ pp_type t ++ pp_type t' ++ ++(* Hide variant name and var, to force printing the expanded type *) ++let hide_variant_name t = ++ let open Types in ++ match get_desc t with ++ | Tvariant row -> ++ let Row {fields; more; name; fixed; closed} = row_repr row in ++ if name = None then t else ++ Btype.newty2 ~level:(get_level t) ++ (Tvariant ++ (create_row ~fields ~fixed ~closed ~name:None ++ ~more:(Ctype.newvar2 (get_level more)))) ++ | _ -> t ++ ++let prepare_expansion Errortrace.{ty; expanded} = ++ let expanded = hide_variant_name expanded in ++ Variable_names.reserve ty; ++ if not (same_path ty expanded) then Variable_names.reserve expanded; ++ Errortrace.{ty; expanded} ++ ++ ++(* Adapt functions to exposed interface *) ++let namespaced_tree_of_path n = tree_of_path (Some n) ++let tree_of_path ?disambiguation p = tree_of_path ?disambiguation None p ++let tree_of_modtype = tree_of_modtype ~ellipsis:false ++let tree_of_type_declaration ident td rs = ++ with_hidden_items [{hide=true; ident}] ++ (fun () -> tree_of_type_declaration ident td rs) ++ ++let tree_of_class_type kind cty = tree_of_class_type kind [] cty ++let prepare_class_type cty = prepare_class_type [] cty ++ ++let tree_of_type_path p = ++ let (p', s) = best_type_path p in ++ let p'' = if (s = Id) then p' else p in ++ tree_of_best_type_path p p'' diff --git a/upstream/patches_503/typing/out_type.mli.patch b/upstream/patches_503/typing/out_type.mli.patch new file mode 100644 index 000000000..5c3fe4ff5 --- /dev/null +++ b/upstream/patches_503/typing/out_type.mli.patch @@ -0,0 +1,262 @@ +--- ocaml_502/typing/out_type.mli 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/typing/out_type.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -0,0 +1,259 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) ++(* *) ++(* Copyright 1996 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(** Functions for representing type expressions and module types as outcometree ++ (with [as 'a] aliases for cycles) and printing them. All functions below ++ depends on global contexts that keep track of ++ ++- If labels are disabled ++- Current printing environment ++- Shortest equivalent paths ++ ++- Conflicts for identifier names ++- Names chosen for type variables ++- Aliases used for representing cycles or row variables ++- Uses of internal names ++ ++Whenever possible, it is advised to use the simpler functions available in ++{!Printtyp} which take care of setting up this naming context. The functions ++below are needed when one needs to share a common naming context (or part of it) ++between different calls to printing functions (or in order to implement ++{!Printtyp}). ++*) ++ ++open Format_doc ++open Types ++open Outcometree ++ ++(** {1 Wrapping functions}*) ++ ++val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a ++(** Call the function using the environment for type path shortening ++ This affects all the printing and tree cration functions functions below ++ Also, if [~error:true], then disable the loading of cmis *) ++ ++ ++(** [with_labels false] disable labels in function types *) ++val with_labels: bool -> (unit -> 'a) -> 'a ++ ++(** {1 Printing idents and paths } *) ++ ++val ident_name: Shape.Sig_component_kind.t option -> Ident.t -> out_name ++val tree_of_path: ?disambiguation:bool -> Path.t -> out_ident ++val namespaced_tree_of_path: Shape.Sig_component_kind.t -> Path.t -> out_ident ++val tree_of_type_path: Path.t -> out_ident ++(** Specialized functions for printing types with [short-paths] *) ++ ++(** [same_path ty ty2] is true when there is an equation [ty]=[ty2] in the ++ short-path scope*) ++val same_path: type_expr -> type_expr -> bool ++ ++(** Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias ++ for Foo__bar. This pattern is used by the stdlib. *) ++val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t ++ ++(** {1 Printing type expressions} *) ++ ++(** Printing type expressions requires to translate the internal graph based ++ representation into to an {!Outcometree} closer to the source syntax. In ++ order to do so, the printing is generally split in three phase: ++ - A preparation phase which in particular ++ - marks cycles ++ - chooses user-facing names for type variables ++ - An outcometree generation phase, where we emit an outcometree as a ++ ready-for-printing representation of trees (represented by the various ++ [tree_of_*] functions) ++ - Printing proper ++*) ++ ++(** [prepare_for_printing] resets the global naming environment, a la ++ {!reset_except_conflicts}, and prepares the types for printing by reserving ++ variable names and marking cycles. Any type variables that are shared ++ between multiple types in the input list will be given the same name when ++ printed with {!prepared_type_expr}. *) ++val prepare_for_printing: type_expr list -> unit ++ ++(** [add_type_to_preparation ty] extend a previous type expression preparation ++ to the type expression [ty] ++*) ++val add_type_to_preparation: type_expr -> unit ++ ++(** In [Type_scheme] mode, non-generic types variables are printed as weakly ++ polymorphic type variables. *) ++type type_or_scheme = Type | Type_scheme ++val tree_of_typexp: type_or_scheme -> type_expr -> out_type ++(** [tree_of_typexp] generate the [outcometree] for a prepared type ++ expression.*) ++ ++val prepared_type_scheme: type_expr printer ++val prepared_type_expr: type_expr printer ++(** The printers [prepared_type_expr] and [prepared_type_scheme] should only be ++ used on prepared types. Types can be prepared by initially calling ++ {!prepare_for_printing} or adding them later to the preparation with ++ {!add_type_to_preparation}. ++ ++ Calling this function on non-prepared types may cause a stack overflow (see ++ #8860) due to cycles in the printed types. ++ ++ See {!Printtyp.type_expr} for a safer but less flexible printer. *) ++ ++(** [type_expr_with_reserved_names] can print "half-prepared" type expression. A ++ "half-prepared" type expression should have had its names reserved (with ++ {!Variable_names.reserve}), but should not have had its cycles marked. *) ++val type_expr_with_reserved_names: type_expr printer ++ ++type 'a diff = Same of 'a | Diff of 'a * 'a ++val trees_of_type_expansion: ++ type_or_scheme -> Errortrace.expanded_type -> out_type diff ++val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type ++val pp_type_expansion: out_type diff printer ++val hide_variant_name: Types.type_expr -> Types.type_expr ++ ++ ++(** {1: Label and constructors }*) ++val prepare_type_constructor_arguments: constructor_arguments -> unit ++val tree_of_constructor_arguments: constructor_arguments -> out_type list ++ ++val tree_of_label: label_declaration -> out_label ++ ++val add_constructor_to_preparation : constructor_declaration -> unit ++val prepared_constructor : constructor_declaration printer ++ ++val tree_of_extension_constructor: ++ Ident.t -> extension_constructor -> ext_status -> out_sig_item ++val extension_constructor_args_and_ret_type_subtree: ++ constructor_arguments -> type_expr option -> out_type list * out_type option ++val add_extension_constructor_to_preparation : ++ extension_constructor -> unit ++val prepared_extension_constructor: ++ Ident.t -> extension_constructor printer ++ ++ ++(** {1 Declarations }*) ++ ++val tree_of_type_declaration: ++ Ident.t -> type_declaration -> rec_status -> out_sig_item ++val add_type_declaration_to_preparation : ++ Ident.t -> type_declaration -> unit ++val prepared_type_declaration: Ident.t -> type_declaration printer ++ ++val tree_of_value_description: Ident.t -> value_description -> out_sig_item ++val tree_of_modtype_declaration: ++ Ident.t -> modtype_declaration -> out_sig_item ++val tree_of_class_declaration: ++ Ident.t -> class_declaration -> rec_status -> out_sig_item ++val tree_of_cltype_declaration: ++ Ident.t -> class_type_declaration -> rec_status -> out_sig_item ++ ++(** {1 Module types }*) ++ ++val tree_of_module: ++ Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item ++val tree_of_modtype: module_type -> out_module_type ++val tree_of_signature: Types.signature -> out_sig_item list ++ ++val tree_of_class_type: type_or_scheme -> class_type -> out_class_type ++val prepare_class_type: class_type -> unit ++ ++(** {1 Toplevel printing} *) ++val print_items: (Env.t -> signature_item -> 'a option) -> ++ Env.t -> signature_item list -> (out_sig_item * 'a option) list ++ ++(** {1 Naming contexts }*) ++ ++(** Path name, which were mutable at some point *) ++module Out_name: sig ++ val create: string -> out_name ++ val print: out_name -> string ++end ++ ++(** Disambiguation for identifiers, e.g. the two type constructors named [t] ++in the type of [f] in ++{[ ++ type t = A ++ module M = struct ++ type t = B ++ let f A = B ++ end ++]} ++should be disambiguated to [t/2->t] *) ++module Ident_names: sig ++ val enable: bool -> unit ++ (** When contextual names are enabled, the mapping between identifiers ++ and names is ensured to be one-to-one. *) ++ ++ (** [with_fuzzy id f] locally disable ident disambiguation for [id] within ++ [f] *) ++ val with_fuzzy: Ident.t -> (unit -> 'a) -> 'a ++end ++ ++(** The [Ident_conflicts] module keeps track of conflicts arising when ++ attributing names to identifiers and provides functions that can print ++ explanations for these conflict in error messages *) ++module Ident_conflicts: sig ++ val exists: unit -> bool ++ (** [exists()] returns true if the current naming context renamed ++ an identifier to avoid a name collision *) ++ ++ type explanation = ++ { kind: Shape.Sig_component_kind.t; ++ name:string; ++ root_name:string; ++ location:Location.t ++ } ++ ++ val list_explanations: unit -> explanation list ++(** [list_explanations()] return the list of conflict explanations ++ collected up to this point, and reset the list of collected ++ explanations *) ++ ++ val print_located_explanations: explanation list printer ++ ++ val err_print: formatter -> unit ++ val err_msg: unit -> doc option ++ (** [err_msg ()] return an error message if there are pending conflict ++ explanations at this point. It is often important to check for conflicts ++ after all printing is done, thus the delayed nature of [err_msg]*) ++ ++ val reset: unit -> unit ++end ++ ++(** Naming choice for type variable names (['a], ['b], ...), for instance the ++ two classes of distinct type variables in ++ {[let repeat x y = x, y, y, x]} ++ should be printed printed as ['a -> 'b -> 'a * 'b * 'b * 'a]. ++*) ++module Variable_names: sig ++ ++ (** Add external type equalities*) ++ val add_subst: (type_expr * type_expr) list -> unit ++ ++ (** [reserve ty] registers the variable names appearing in [ty] *) ++ val reserve: type_expr -> unit ++end ++ ++(** Register internal typechecker names ([$0],[$a]) appearing in the ++ [outcometree] *) ++module Internal_names: sig ++ val add: Path.t -> unit ++ val reset: unit -> unit ++ val print_explanations: Env.t -> formatter -> unit ++end ++ ++(** Reset all contexts *) ++val reset: unit -> unit ++ ++(** Reset all contexts except for conflicts *) ++val reset_except_conflicts: unit -> unit diff --git a/upstream/patches_503/typing/outcometree.mli.patch b/upstream/patches_503/typing/outcometree.mli.patch new file mode 100644 index 000000000..a9f2be2a2 --- /dev/null +++ b/upstream/patches_503/typing/outcometree.mli.patch @@ -0,0 +1,33 @@ +--- ocaml_502/typing/outcometree.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/outcometree.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -49,7 +49,7 @@ + | Oval_int64 of int64 + | Oval_nativeint of nativeint + | Oval_list of out_value list +- | Oval_printer of (Format.formatter -> unit) ++ | Oval_printer of (Format_doc.formatter -> unit) + | Oval_record of (out_ident * out_value) list + | Oval_string of string * int * out_string (* string, size-to-print, kind *) + | Oval_stuff of string +@@ -72,7 +72,7 @@ + | Otyp_constr of out_ident * out_type list + | Otyp_manifest of out_type * out_type + | Otyp_object of { fields: (string * out_type) list; open_row:bool} +- | Otyp_record of (string * bool * out_type) list ++ | Otyp_record of out_label list + | Otyp_stuff of string + | Otyp_sum of out_constructor list + | Otyp_tuple of out_type list +@@ -82,6 +82,12 @@ + | Otyp_module of out_ident * (string * out_type) list + | Otyp_attribute of out_type * out_attribute + ++and out_label = { ++ olab_name: string; ++ olab_mut: Asttypes.mutable_flag; ++ olab_type: out_type; ++} ++ + and out_constructor = { + ocstr_name: string; + ocstr_args: out_type list; diff --git a/upstream/patches_503/typing/parmatch.ml.patch b/upstream/patches_503/typing/parmatch.ml.patch new file mode 100644 index 000000000..76983238c --- /dev/null +++ b/upstream/patches_503/typing/parmatch.ml.patch @@ -0,0 +1,88 @@ +--- ocaml_502/typing/parmatch.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/parmatch.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -504,26 +504,15 @@ + | _,_ -> + fatal_error "Parmatch.read_args" + +-let do_set_args ~erase_mutable q r = match q with ++let set_args q r = match q with + | {pat_desc = Tpat_tuple omegas} -> + let args,rest = read_args omegas r in + make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest + | {pat_desc = Tpat_record (omegas,closed)} -> + let args,rest = read_args omegas r in +- make_pat +- (Tpat_record +- (List.map2 (fun (lid, lbl,_) arg -> +- if +- erase_mutable && +- (match lbl.lbl_mut with +- | Mutable -> true | Immutable -> false) +- then +- lid, lbl, omega +- else +- lid, lbl, arg) +- omegas args, closed)) +- q.pat_type q.pat_env:: +- rest ++ let args = ++ List.map2 (fun (lid, lbl, _) arg -> (lid, lbl, arg)) omegas args in ++ make_pat (Tpat_record (args, closed)) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_construct (lid, c, omegas, _)} -> + let args,rest = read_args omegas r in + make_pat +@@ -548,7 +537,6 @@ + end + | {pat_desc = Tpat_array omegas} -> + let args,rest = read_args omegas r in +- let args = if erase_mutable then omegas else args in + make_pat + (Tpat_array args) q.pat_type q.pat_env:: + rest +@@ -557,9 +545,6 @@ + | {pat_desc = (Tpat_var _ | Tpat_alias _ | Tpat_or _); _} -> + fatal_error "Parmatch.set_args" + +-let set_args q r = do_set_args ~erase_mutable:false q r +-and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r +- + (* Given a matrix of non-empty rows + p1 :: r1... + p2 :: r2... +@@ -1899,22 +1884,20 @@ + | Seq.Cons (v, _rest) -> + if Warnings.is_active (Warnings.Partial_match "") then begin + let errmsg = +- try +- let buf = Buffer.create 16 in +- let fmt = Format.formatter_of_buffer buf in +- Format.fprintf fmt "%a@?" Printpat.pretty_pat v; +- if do_match (initial_only_guarded casel) [v] then +- Buffer.add_string buf +- "\n(However, some guarded clause may match this value.)"; +- if contains_extension v then +- Buffer.add_string buf +- "\nMatching over values of extensible variant types \ +- (the *extension* above)\n\ +- must include a wild card pattern in order to be exhaustive." +- ; +- Buffer.contents buf +- with _ -> +- "" ++ let doc = ref Format_doc.Doc.empty in ++ let fmt = Format_doc.formatter doc in ++ Format_doc.fprintf fmt "@[%a" Printpat.top_pretty v; ++ if do_match (initial_only_guarded casel) [v] then ++ Format_doc.fprintf fmt ++ "@,(However, some guarded clause may match this value.)"; ++ if contains_extension v then ++ Format_doc.fprintf fmt ++ "@,@[Matching over values of extensible variant types \ ++ (the *extension* above)@,\ ++ must include a wild card pattern@ in order to be exhaustive.@]" ++ ; ++ Format_doc.fprintf fmt "@]"; ++ Format_doc.(asprintf "%a" pp_doc) !doc + in + Location.prerr_warning loc (Warnings.Partial_match errmsg) + end; diff --git a/upstream/patches_503/typing/parmatch.mli.patch b/upstream/patches_503/typing/parmatch.mli.patch new file mode 100644 index 000000000..3ad5218cd --- /dev/null +++ b/upstream/patches_503/typing/parmatch.mli.patch @@ -0,0 +1,17 @@ +--- ocaml_502/typing/parmatch.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/parmatch.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -75,13 +75,11 @@ + + val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list + +-(** Those two functions recombine one pattern and its arguments: ++(** This function recombines one pattern and its arguments: + For instance: + (_,_)::p1::p2::rem -> (p1, p2)::rem +- The second one will replace mutable arguments by '_' + *) + val set_args : pattern -> pattern list -> pattern list +-val set_args_erase_mutable : pattern -> pattern list -> pattern list + + val pat_of_constr : pattern -> constructor_description -> pattern + val complete_constrs : diff --git a/upstream/patches_503/typing/path.ml.patch b/upstream/patches_503/typing/path.ml.patch new file mode 100644 index 000000000..35d969451 --- /dev/null +++ b/upstream/patches_503/typing/path.ml.patch @@ -0,0 +1,13 @@ +--- ocaml_502/typing/path.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/path.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -104,8 +104,8 @@ + let rec print ppf = function + | Pident id -> Ident.print_with_scope ppf id + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> +- Format.fprintf ppf "%a.%s" print p s +- | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2 ++ Format_doc.fprintf ppf "%a.%s" print p s ++ | Papply(p1, p2) -> Format_doc.fprintf ppf "%a(%a)" print p1 print p2 + | Pextra_ty (p, Pext_ty) -> print ppf p + + let rec head = function diff --git a/upstream/patches_503/typing/path.mli.patch b/upstream/patches_503/typing/path.mli.patch new file mode 100644 index 000000000..5c4481bd6 --- /dev/null +++ b/upstream/patches_503/typing/path.mli.patch @@ -0,0 +1,11 @@ +--- ocaml_502/typing/path.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/path.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -68,7 +68,7 @@ + (* [paren] tells whether a path suffix needs parentheses *) + val head: t -> Ident.t + +-val print: Format.formatter -> t -> unit ++val print: t Format_doc.printer + + val heads: t -> Ident.t list + diff --git a/upstream/patches_503/typing/persistent_env.ml.patch b/upstream/patches_503/typing/persistent_env.ml.patch new file mode 100644 index 000000000..20f737b8c --- /dev/null +++ b/upstream/patches_503/typing/persistent_env.ml.patch @@ -0,0 +1,70 @@ +--- ocaml_502/typing/persistent_env.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/persistent_env.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -243,25 +243,27 @@ + let warn = Warnings.No_cmi_file(name, None) in + Location.prerr_warning loc warn + | Cmi_format.Error err -> +- let msg = Format.asprintf "%a" Cmi_format.report_error err in ++ let msg = Format.asprintf "%a" ++ Cmi_format.report_error err in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + | Error err -> + let msg = + match err with + | Illegal_renaming(name, ps_name, filename) -> +- Format.asprintf ++ Format_doc.doc_printf + " %a@ contains the compiled interface for @ \ + %a when %a was expected" +- (Style.as_inline_code Location.print_filename) filename ++ Location.Doc.quoted_filename filename + Style.inline_code ps_name + Style.inline_code name + | Inconsistent_import _ -> assert false + | Need_recursive_types name -> +- Format.asprintf ++ Format_doc.doc_printf + "%a uses recursive types" + Style.inline_code name + in ++ let msg = Format_doc.(asprintf "%a" pp_doc) msg in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + +@@ -349,20 +351,20 @@ + ) + ~exceptionally:(fun () -> remove_file filename) + +-let report_error ppf = +- let open Format in ++let report_error_doc ppf = ++ let open Format_doc in + function + | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf + "Wrong file naming: %a@ contains the compiled interface for@ \ + %a when %a was expected" +- (Style.as_inline_code Location.print_filename) filename ++ Location.Doc.quoted_filename filename + Style.inline_code ps_name + Style.inline_code modname + | Inconsistent_import(name, source1, source2) -> fprintf ppf + "@[The files %a@ and %a@ \ + make inconsistent assumptions@ over interface %a@]" +- (Style.as_inline_code Location.print_filename) source1 +- (Style.as_inline_code Location.print_filename) source2 ++ Location.Doc.quoted_filename source1 ++ Location.Doc.quoted_filename source2 + Style.inline_code name + | Need_recursive_types(import) -> + fprintf ppf +@@ -375,6 +377,8 @@ + Location.register_error_of_exn + (function + | Error err -> +- Some (Location.error_of_printer_file report_error err) ++ Some (Location.error_of_printer_file report_error_doc err) + | _ -> None + ) ++ ++let report_error = Format_doc.compat report_error_doc diff --git a/upstream/patches_503/typing/persistent_env.mli.patch b/upstream/patches_503/typing/persistent_env.mli.patch new file mode 100644 index 000000000..b1387ee2e --- /dev/null +++ b/upstream/patches_503/typing/persistent_env.mli.patch @@ -0,0 +1,12 @@ +--- ocaml_502/typing/persistent_env.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/persistent_env.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -27,7 +27,8 @@ + + exception Error of error + +-val report_error: Format.formatter -> error -> unit ++val report_error: error Format_doc.format_printer ++val report_error_doc: error Format_doc.printer + + module Persistent_signature : sig + type t = diff --git a/upstream/patches_503/typing/predef.ml.patch b/upstream/patches_503/typing/predef.ml.patch new file mode 100644 index 000000000..34e556ce2 --- /dev/null +++ b/upstream/patches_503/typing/predef.ml.patch @@ -0,0 +1,96 @@ +--- ocaml_502/typing/predef.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/predef.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -35,6 +35,8 @@ + and ident_bool = ident_create "bool" + and ident_unit = ident_create "unit" + and ident_exn = ident_create "exn" ++and ident_eff = ident_create "eff" ++and ident_continuation = ident_create "continuation" + and ident_array = ident_create "array" + and ident_list = ident_create "list" + and ident_option = ident_create "option" +@@ -53,6 +55,8 @@ + and path_bool = Pident ident_bool + and path_unit = Pident ident_unit + and path_exn = Pident ident_exn ++and path_eff = Pident ident_eff ++and path_continuation = Pident ident_continuation + and path_array = Pident ident_array + and path_list = Pident ident_list + and path_option = Pident ident_option +@@ -71,6 +75,9 @@ + and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil)) + and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil)) + and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) ++and type_eff t = newgenty (Tconstr(path_eff, [t], ref Mnil)) ++and type_continuation t1 t2 = ++ newgenty (Tconstr(path_continuation, [t1; t2], ref Mnil)) + and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) + and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) + and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) +@@ -96,6 +103,8 @@ + and ident_assert_failure = ident_create "Assert_failure" + and ident_undefined_recursive_module = + ident_create "Undefined_recursive_module" ++and ident_continuation_already_taken = ident_create "Continuation_already_taken" ++ + + let all_predef_exns = [ + ident_match_failure; +@@ -110,6 +119,7 @@ + ident_sys_blocked_io; + ident_assert_failure; + ident_undefined_recursive_module; ++ ident_continuation_already_taken; + ] + + let path_match_failure = Pident ident_match_failure +@@ -178,6 +188,28 @@ + } + in + add_type type_ident decl env ++ and add_continuation type_ident env = ++ let tvar1 = newgenvar() in ++ let tvar2 = newgenvar() in ++ let arity = 2 in ++ let decl = ++ {type_params = [tvar1; tvar2]; ++ type_arity = arity; ++ type_kind = Type_abstract Definition; ++ type_loc = Location.none; ++ type_private = Asttypes.Public; ++ type_manifest = None; ++ type_variance = [Variance.contravariant; Variance.covariant]; ++ type_separability = Types.Separability.default_signature ~arity; ++ type_is_newtype = false; ++ type_expansion_scope = lowest_level; ++ type_attributes = []; ++ type_immediate = Unknown; ++ type_unboxed_default = false; ++ type_uid = Uid.of_predef_id type_ident; ++ } ++ in ++ add_type type_ident decl env + in + let add_extension id l = + add_extension id +@@ -204,6 +236,11 @@ + ~kind:(variant [cstr ident_false []; cstr ident_true []]) + |> add_type ident_char ~immediate:Always + |> add_type ident_exn ~kind:Type_open ++ |> add_type1 ident_eff ++ ~variance:Variance.full ++ ~separability:Separability.Ind ++ ~kind:(fun _ -> Type_open) ++ |> add_continuation ident_continuation + |> add_type ident_extension_constructor + |> add_type ident_float + |> add_type ident_floatarray +@@ -245,6 +282,7 @@ + |> add_extension ident_sys_error [type_string] + |> add_extension ident_undefined_recursive_module + [newgenty (Ttuple[type_string; type_int; type_int])] ++ |> add_extension ident_continuation_already_taken [] + + let builtin_values = + List.map (fun id -> (Ident.name id, id)) all_predef_exns diff --git a/upstream/patches_503/typing/predef.mli.patch b/upstream/patches_503/typing/predef.mli.patch new file mode 100644 index 000000000..9d087f010 --- /dev/null +++ b/upstream/patches_503/typing/predef.mli.patch @@ -0,0 +1,27 @@ +--- ocaml_502/typing/predef.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/predef.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -25,6 +25,8 @@ + val type_bool: type_expr + val type_unit: type_expr + val type_exn: type_expr ++val type_eff: type_expr -> type_expr ++val type_continuation: type_expr -> type_expr -> type_expr + val type_array: type_expr -> type_expr + val type_list: type_expr -> type_expr + val type_option: type_expr -> type_expr +@@ -43,6 +45,7 @@ + val path_bool: Path.t + val path_unit: Path.t + val path_exn: Path.t ++val path_eff: Path.t + val path_array: Path.t + val path_list: Path.t + val path_option: Path.t +@@ -52,6 +55,7 @@ + val path_lazy_t: Path.t + val path_extension_constructor: Path.t + val path_floatarray: Path.t ++val path_continuation: Path.t + + val path_match_failure: Path.t + val path_assert_failure : Path.t diff --git a/upstream/patches_503/typing/primitive.ml.patch b/upstream/patches_503/typing/primitive.ml.patch new file mode 100644 index 000000000..02a3cda1d --- /dev/null +++ b/upstream/patches_503/typing/primitive.ml.patch @@ -0,0 +1,22 @@ +--- ocaml_502/typing/primitive.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/primitive.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -232,16 +232,16 @@ + let report_error ppf err = + match err with + | Old_style_float_with_native_repr_attribute -> +- Format.fprintf ppf "Cannot use %a in conjunction with %a/%a." ++ Format_doc.fprintf ppf "Cannot use %a in conjunction with %a/%a." + Style.inline_code "float" + Style.inline_code "[@unboxed]" + Style.inline_code "[@untagged]" + | Old_style_noalloc_with_noalloc_attribute -> +- Format.fprintf ppf "Cannot use %a in conjunction with %a." ++ Format_doc.fprintf ppf "Cannot use %a in conjunction with %a." + Style.inline_code "noalloc" + Style.inline_code "[@@noalloc]" + | No_native_primitive_with_repr_attribute -> +- Format.fprintf ppf ++ Format_doc.fprintf ppf + "@[The native code version of the primitive is mandatory@ \ + when attributes %a or %a are present.@]" + Style.inline_code "[@untagged]" diff --git a/upstream/patches_503/typing/printpat.ml.patch b/upstream/patches_503/typing/printpat.ml.patch new file mode 100644 index 000000000..fd571db7e --- /dev/null +++ b/upstream/patches_503/typing/printpat.ml.patch @@ -0,0 +1,59 @@ +--- ocaml_502/typing/printpat.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/printpat.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -18,7 +18,7 @@ + open Asttypes + open Typedtree + open Types +-open Format ++open Format_doc + + let is_cons = function + | {cstr_name = "::"} -> true +@@ -99,7 +99,7 @@ + | Tpat_lazy v -> + fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v + | Tpat_alias (v, x,_,_) -> +- fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x ++ fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.doc_print x + | Tpat_value v -> + fprintf ppf "%a" pretty_val (v :> pattern) + | Tpat_exception v -> +@@ -144,20 +144,30 @@ + fprintf ppf "%s=%a;@ %a" + lbl.lbl_name pretty_val v pretty_lvals rest + ++let top_pretty ppf v = ++ fprintf ppf "@[%a@]" pretty_val v ++ + let pretty_pat ppf p = +- fprintf ppf "@[%a@]" pretty_val p ++ top_pretty ppf p ; ++ pp_print_flush ppf () + + type 'k matrix = 'k general_pattern list list + + let pretty_line ppf line = +- Format.fprintf ppf "@["; ++ fprintf ppf "@["; + List.iter (fun p -> +- Format.fprintf ppf "<%a>@ " +- pretty_val p +- ) line; +- Format.fprintf ppf "@]" ++ fprintf ppf "<%a>@ " ++ pretty_val p ++ ) line; ++ fprintf ppf "@]" + + let pretty_matrix ppf (pss : 'k matrix) = +- Format.fprintf ppf "@[ %a@]" +- (Format.pp_print_list ~pp_sep:Format.pp_print_cut pretty_line) ++ fprintf ppf "@[ %a@]" ++ (pp_print_list ~pp_sep:pp_print_cut pretty_line) + pss ++ ++module Compat = struct ++ let pretty_pat ppf x = compat pretty_pat ppf x ++ let pretty_line ppf x = compat pretty_line ppf x ++ let pretty_matrix ppf x = compat pretty_matrix ppf x ++end diff --git a/upstream/patches_503/typing/printpat.mli.patch b/upstream/patches_503/typing/printpat.mli.patch new file mode 100644 index 000000000..574bdb9df --- /dev/null +++ b/upstream/patches_503/typing/printpat.mli.patch @@ -0,0 +1,22 @@ +--- ocaml_502/typing/printpat.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/printpat.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -17,11 +17,12 @@ + + val pretty_const + : Asttypes.constant -> string +-val pretty_val : Format.formatter -> 'k Typedtree.general_pattern -> unit + +-val pretty_pat +- : Format.formatter -> 'k Typedtree.general_pattern -> unit +-val pretty_line +- : Format.formatter -> 'k Typedtree.general_pattern list -> unit +-val pretty_matrix +- : Format.formatter -> 'k Typedtree.general_pattern list list -> unit ++val top_pretty: 'k Typedtree.general_pattern Format_doc.printer ++ ++module Compat: sig ++ val pretty_pat: Format.formatter -> 'k Typedtree.general_pattern -> unit ++ val pretty_line: Format.formatter -> 'k Typedtree.general_pattern list -> unit ++ val pretty_matrix: ++ Format.formatter -> 'k Typedtree.general_pattern list list -> unit ++end diff --git a/upstream/patches_503/typing/printtyp.ml.patch b/upstream/patches_503/typing/printtyp.ml.patch new file mode 100644 index 000000000..e8d6aac61 --- /dev/null +++ b/upstream/patches_503/typing/printtyp.ml.patch @@ -0,0 +1,2841 @@ +--- ocaml_502/typing/printtyp.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/printtyp.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -2,9 +2,9 @@ + (* *) + (* OCaml *) + (* *) +-(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) ++(* Florian Angeletti, projet Cambium, INRIA Paris *) + (* *) +-(* Copyright 1996 Institut National de Recherche en Informatique et *) ++(* Copyright 2024 Institut National de Recherche en Informatique et *) + (* en Automatique. *) + (* *) + (* All rights reserved. This file is distributed under the terms of *) +@@ -13,2708 +13,162 @@ + (* *) + (**************************************************************************) + +-(* Printing functions *) ++open Out_type ++module Fmt = Format_doc + +-open Misc +-open Ctype +-open Format +-open Longident +-open Path +-open Asttypes +-open Types +-open Btype +-open Outcometree +- +-module String = Misc.Stdlib.String +-module Sig_component_kind = Shape.Sig_component_kind +-module Style = Misc.Style +- +-(* Print a long identifier *) +-let longident = Pprintast.longident +- +-let () = Env.print_longident := longident +- +-(* Print an identifier avoiding name collisions *) +- +-module Out_name = struct +- let create x = { printed_name = x } +- let print x = x.printed_name +-end ++let namespaced_ident namespace id = ++ Out_name.print (ident_name (Some namespace) id) + +-(** Some identifiers may require hiding when printing *) +-type bound_ident = { hide:bool; ident:Ident.t } ++module Doc = struct ++ let wrap_printing_env = wrap_printing_env + +-(* printing environment for path shortening and naming *) +-let printing_env = ref Env.empty ++ let longident = Pprintast.Doc.longident + +-(* When printing, it is important to only observe the +- current printing environment, without reading any new +- cmi present on the file system *) +-let in_printing_env f = Env.without_cmis f !printing_env +- +- type namespace = Sig_component_kind.t = +- | Value +- | Type +- | Constructor +- | Label +- | Module +- | Module_type +- | Extension_constructor +- | Class +- | Class_type +- +- +-module Namespace = struct +- +- let id = function +- | Type -> 0 +- | Module -> 1 +- | Module_type -> 2 +- | Class -> 3 +- | Class_type -> 4 +- | Extension_constructor | Value | Constructor | Label -> 5 +- (* we do not handle those component *) +- +- let size = 1 + id Value +- +- +- let pp ppf x = +- Format.pp_print_string ppf (Shape.Sig_component_kind.to_string x) +- +- (** The two functions below should never access the filesystem, +- and thus use {!in_printing_env} rather than directly +- accessing the printing environment *) +- let lookup = +- let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in +- function +- | Some Type -> to_lookup Env.find_type_by_name +- | Some Module -> to_lookup Env.find_module_by_name +- | Some Module_type -> to_lookup Env.find_modtype_by_name +- | Some Class -> to_lookup Env.find_class_by_name +- | Some Class_type -> to_lookup Env.find_cltype_by_name +- | None | Some(Value|Extension_constructor|Constructor|Label) -> +- fun _ -> raise Not_found +- +- let location namespace id = +- let path = Path.Pident id in +- try Some ( +- match namespace with +- | Some Type -> (in_printing_env @@ Env.find_type path).type_loc +- | Some Module -> (in_printing_env @@ Env.find_module path).md_loc +- | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc +- | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc +- | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc +- | Some (Extension_constructor|Value|Constructor|Label) | None -> +- Location.none +- ) with Not_found -> None +- +- let best_class_namespace = function +- | Papply _ | Pdot _ -> Some Module +- | Pextra_ty _ -> assert false (* Only in type path *) +- | Pident c -> +- match location (Some Class) c with +- | Some _ -> Some Class +- | None -> Some Class_type ++ let ident ppf id = Fmt.pp_print_string ppf ++ (Out_name.print (ident_name None id)) + +-end + +-(** {2 Conflicts printing} +- Conflicts arise when multiple items are attributed the same name, +- the following module stores the global conflict references and +- provides the printing functions for explaining the source of +- the conflicts. +-*) +-module Conflicts = struct +- module M = String.Map +- type explanation = +- { kind: namespace; name:string; root_name:string; location:Location.t} +- let explanations = ref M.empty + +- let add namespace name id = +- match Namespace.location (Some namespace) id with +- | None -> () +- | Some location -> +- let explanation = +- { kind = namespace; location; name; root_name=Ident.name id} +- in +- explanations := M.add name explanation !explanations +- +- let collect_explanation namespace id ~name = +- let root_name = Ident.name id in +- (* if [name] is of the form "root_name/%d", we register both +- [id] and the identifier in scope for [root_name]. +- *) +- if root_name <> name && not (M.mem name !explanations) then +- begin +- add namespace name id; +- if not (M.mem root_name !explanations) then +- (* lookup the identifier in scope with name [root_name] and +- add it too +- *) +- match Namespace.lookup (Some namespace) root_name with +- | Pident root_id -> add namespace root_name root_id +- | exception Not_found | _ -> () +- end +- +- let pp_explanation ppf r= +- Format.fprintf ppf "@[%a:@,Definition of %s %a@]" +- Location.print_loc r.location (Sig_component_kind.to_string r.kind) +- Style.inline_code r.name +- +- let print_located_explanations ppf l = +- Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l +- +- let reset () = explanations := M.empty +- let list_explanations () = +- let c = !explanations in +- reset (); +- c |> M.bindings |> List.map snd |> List.sort Stdlib.compare ++ let typexp mode ppf ty = ++ !Oprint.out_type ppf (tree_of_typexp mode ty) + ++ let type_expansion k ppf e = ++ pp_type_expansion ppf (trees_of_type_expansion k e) + +- let print_toplevel_hint ppf l = +- let conj ppf () = Format.fprintf ppf " and@ " in +- let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in +- let root_names = List.map (fun r -> r.kind, r.root_name) l in +- let unique_root_names = List.sort_uniq Stdlib.compare root_names in +- let submsgs = Array.make Namespace.size [] in +- let () = List.iter (fun (n,_ as x) -> +- submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) +- ) unique_root_names in +- let pp_submsg ppf names = +- match names with +- | [] -> () +- | [namespace, a] -> +- Format.fprintf ppf +- "@ \ +- @[<2>@{Hint@}: The %a %a has been defined multiple times@ \ +- in@ this@ toplevel@ session.@ \ +- Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ +- @ Did you try to redefine them?@]" +- Namespace.pp namespace +- Style.inline_code a Namespace.pp namespace +- | (namespace, _) :: _ :: _ -> +- Format.fprintf ppf +- "@ \ +- @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ +- in@ this@ toplevel@ session.@ \ +- Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ +- @ Did you try to redefine them?@]" +- pp_namespace_plural namespace +- Format.(pp_print_list ~pp_sep:conj Style.inline_code) +- (List.map snd names) +- pp_namespace_plural namespace in +- Array.iter (pp_submsg ppf) submsgs +- +- let print_explanations ppf = +- let ltop, l = +- (* isolate toplevel locations, since they are too imprecise *) +- let from_toplevel a = +- a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in +- List.partition from_toplevel (list_explanations ()) +- in +- begin match l with +- | [] -> () +- | l -> Format.fprintf ppf "@,%a" print_located_explanations l +- end; +- (* if there are name collisions in a toplevel session, +- display at least one generic hint by namespace *) +- print_toplevel_hint ppf ltop ++ let type_declaration id ppf decl = ++ !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) + +- let exists () = M.cardinal !explanations >0 +-end ++ let type_expr ppf ty = ++ (* [type_expr] is used directly by error message printers, ++ we mark eventual loops ourself to avoid any misuse and stack overflow *) ++ prepare_for_printing [ty]; ++ prepared_type_expr ppf ty + +-module Naming_context = struct ++ let shared_type_scheme ppf ty = ++ add_type_to_preparation ty; ++ typexp Type_scheme ppf ty + +-module M = String.Map +-module S = String.Set ++ let type_scheme ppf ty = ++ prepare_for_printing [ty]; ++ prepared_type_scheme ppf ty + +-let enabled = ref true +-let enable b = enabled := b ++ let path ppf p = ++ !Oprint.out_ident ppf (tree_of_path ~disambiguation:false p) + +-(* Names bound in recursive definitions should be considered as bound +- in the environment when printing identifiers but not when trying +- to find shortest path. +- For instance, if we define +- [{ +- module Avoid__me = struct +- type t = A +- end +- type t = X +- type u = [` A of t * t ] +- module M = struct +- type t = A of [ u | `B ] +- type r = Avoid__me.t +- end +- }] +- It is is important that in the definition of [t] that the outer type [t] is +- printed as [t/2] reserving the name [t] to the type being defined in the +- current recursive definition. +- Contrarily, in the definition of [r], one should not shorten the +- path [Avoid__me.t] to [r] until the end of the definition of [r]. +- The [bound_in_recursion] bridges the gap between those two slightly different +- notions of printing environment. +-*) +-let bound_in_recursion = ref M.empty +- +-(* When dealing with functor arguments, identity becomes fuzzy because the same +- syntactic argument may be represented by different identifiers during the +- error processing, we are thus disabling disambiguation on the argument name +-*) +-let fuzzy = ref S.empty +-let with_arg id f = +- protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f +-let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy +- +-let with_hidden ids f = +- let update m id = M.add (Ident.name id.ident) id.ident m in +- let updated = List.fold_left update !bound_in_recursion ids in +- protect_refs [ R(bound_in_recursion, updated )] f +- +-let human_id id index = +- (* The identifier with index [k] is the (k+1)-th most recent identifier in +- the printing environment. We print them as [name/(k+1)] except for [k=0] +- which is printed as [name] rather than [name/1]. +- *) +- if index = 0 then +- Ident.name id +- else +- let ordinal = index + 1 in +- String.concat "/" [Ident.name id; string_of_int ordinal] +- +-let indexed_name namespace id = +- let find namespace id env = match namespace with +- | Type -> Env.find_type_index id env +- | Module -> Env.find_module_index id env +- | Module_type -> Env.find_modtype_index id env +- | Class -> Env.find_class_index id env +- | Class_type-> Env.find_cltype_index id env +- | Value | Extension_constructor | Constructor | Label -> None +- in +- let index = +- match M.find_opt (Ident.name id) !bound_in_recursion with +- | Some rec_bound_id -> +- (* the identifier name appears in the current group of recursive +- definition *) +- if Ident.same rec_bound_id id then +- Some 0 +- else +- (* the current recursive definition shadows one more time the +- previously existing identifier with the same name *) +- Option.map succ (in_printing_env (find namespace id)) +- | None -> +- in_printing_env (find namespace id) +- in +- let index = +- (* If [index] is [None] at this point, it might indicate that +- the identifier id is not defined in the environment, while there +- are other identifiers in scope that share the same name. +- Currently, this kind of partially incoherent environment happens +- within functor error messages where the left and right hand side +- have a different views of the environment at the source level. +- Printing the source-level by using a default index of `0` +- seems like a reasonable compromise in this situation however.*) +- Option.value index ~default:0 +- in +- human_id id index +- +-let ident_name namespace id = +- match namespace, !enabled with +- | None, _ | _, false -> Out_name.create (Ident.name id) +- | Some namespace, true -> +- if fuzzy_id namespace id then Out_name.create (Ident.name id) +- else +- let name = indexed_name namespace id in +- Conflicts.collect_explanation namespace id ~name; +- Out_name.create name +-end +-let ident_name = Naming_context.ident_name ++ let () = Env.print_path := path + +-let ident ppf id = pp_print_string ppf +- (Out_name.print (Naming_context.ident_name None id)) ++ let type_path ppf p = !Oprint.out_ident ppf (tree_of_type_path p) + +-let namespaced_ident namespace id = +- Out_name.print (Naming_context.ident_name (Some namespace) id) ++ let value_description id ppf decl = ++ !Oprint.out_sig_item ppf (tree_of_value_description id decl) + ++ let class_type ppf cty = ++ reset (); ++ prepare_class_type cty; ++ !Oprint.out_class_type ppf (tree_of_class_type Type cty) + +-(* Print a path *) +- +-let ident_stdlib = Ident.create_persistent "Stdlib" +- +-let non_shadowed_stdlib namespace = function +- | Pdot(Pident id, s) as path -> +- Ident.same id ident_stdlib && +- (match Namespace.lookup namespace s with +- | path' -> Path.same path path' +- | exception Not_found -> true) +- | _ -> false +- +-let find_double_underscore s = +- let len = String.length s in +- let rec loop i = +- if i + 1 >= len then +- None +- else if s.[i] = '_' && s.[i + 1] = '_' then +- Some i +- else +- loop (i + 1) +- in +- loop 0 +- +-let rec module_path_is_an_alias_of env path ~alias_of = +- match Env.find_module path env with +- | { md_type = Mty_alias path'; _ } -> +- Path.same path' alias_of || +- module_path_is_an_alias_of env path' ~alias_of +- | _ -> false +- | exception Not_found -> false +- +-(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias +- for Foo__bar. This pattern is used by the stdlib. *) +-let rec rewrite_double_underscore_paths env p = +- match p with +- | Pdot (p, s) -> +- Pdot (rewrite_double_underscore_paths env p, s) +- | Papply (a, b) -> +- Papply (rewrite_double_underscore_paths env a, +- rewrite_double_underscore_paths env b) +- | Pextra_ty (p, extra) -> +- Pextra_ty (rewrite_double_underscore_paths env p, extra) +- | Pident id -> +- let name = Ident.name id in +- match find_double_underscore name with +- | None -> p +- | Some i -> +- let better_lid = +- Ldot +- (Lident (String.sub name 0 i), +- Unit_info.modulize +- (String.sub name (i + 2) (String.length name - i - 2))) +- in +- match Env.find_module_by_name better_lid env with +- | exception Not_found -> p +- | p', _ -> +- if module_path_is_an_alias_of env p' ~alias_of:p then +- p' +- else +- p +- +-let rewrite_double_underscore_paths env p = +- if env == Env.empty then +- p +- else +- rewrite_double_underscore_paths env p +- +-let rec tree_of_path ?(disambiguation=true) namespace p = +- let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in +- let namespace = if disambiguation then namespace else None in +- match p with +- | Pident id -> +- Oide_ident (ident_name namespace id) +- | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> +- Oide_ident (Out_name.create s) +- | Pdot(p, s) -> +- Oide_dot (tree_of_path (Some Module) p, s) +- | Papply(p1, p2) -> +- let t1 = tree_of_path (Some Module) p1 in +- let t2 = tree_of_path (Some Module) p2 in +- Oide_apply (t1, t2) +- | Pextra_ty (p, extra) -> begin +- (* inline record types are syntactically prevented from escaping their +- binding scope, and are never shown to users. *) +- match extra with +- Pcstr_ty s -> +- Oide_dot (tree_of_path (Some Type) p, s) +- | Pext_ty -> +- tree_of_path None p +- end +- +-let tree_of_path ?disambiguation namespace p = +- tree_of_path ?disambiguation namespace +- (rewrite_double_underscore_paths !printing_env p) +- +-let path ppf p = +- !Oprint.out_ident ppf (tree_of_path None p) +- +-let string_of_path p = +- Format.asprintf "%a" path p +- +-let strings_of_paths namespace p = +- let trees = List.map (tree_of_path namespace) p in +- List.map (Format.asprintf "%a" !Oprint.out_ident) trees ++ let class_declaration id ppf cl = ++ !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) + +-let () = Env.print_path := path ++ let cltype_declaration id ppf cl = ++ !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) + +-(* Print a recursive annotation *) ++ let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) ++ let modtype_declaration id ppf decl = ++ !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) + +-let tree_of_rec = function +- | Trec_not -> Orec_not +- | Trec_first -> Orec_first +- | Trec_next -> Orec_next +- +-(* Print a raw type expression, with sharing *) +- +-let raw_list pr ppf = function +- [] -> fprintf ppf "[]" +- | a :: l -> +- fprintf ppf "@[<1>[%a%t]@]" pr a +- (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) +- +-let kind_vars = ref [] +-let kind_count = ref 0 +- +-let string_of_field_kind v = +- match field_kind_repr v with +- | Fpublic -> "Fpublic" +- | Fabsent -> "Fabsent" +- | Fprivate -> "Fprivate" +- +-let rec safe_repr v t = +- match Transient_expr.coerce t with +- {desc = Tlink t} when not (List.memq t v) -> +- safe_repr (t::v) t +- | t' -> t' +- +-let rec list_of_memo = function +- Mnil -> [] +- | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem +- | Mlink rem -> list_of_memo !rem +- +-let print_name ppf = function +- None -> fprintf ppf "None" +- | Some name -> fprintf ppf "\"%s\"" name +- +-let string_of_label = function +- Nolabel -> "" +- | Labelled s -> s +- | Optional s -> "?"^s +- +-let visited = ref [] +-let rec raw_type ppf ty = +- let ty = safe_repr [] ty in +- if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin +- visited := ty :: !visited; +- fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;desc=@,%a}@]" ty.id ty.level +- ty.scope raw_type_desc ty.desc +- end +-and raw_type_list tl = raw_list raw_type tl +-and raw_lid_type_list tl = +- raw_list (fun ppf (lid, typ) -> +- fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) +- tl +-and raw_type_desc ppf = function +- Tvar name -> fprintf ppf "Tvar %a" print_name name +- | Tarrow(l,t1,t2,c) -> +- fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" +- (string_of_label l) raw_type t1 raw_type t2 +- (if is_commu_ok c then "Cok" else "Cunknown") +- | Ttuple tl -> +- fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl +- | Tconstr (p, tl, abbrev) -> +- fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p +- raw_type_list tl +- (raw_list path) (list_of_memo !abbrev) +- | Tobject (t, nm) -> +- fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t +- (fun ppf -> +- match !nm with None -> fprintf ppf " None" +- | Some(p,tl) -> +- fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) +- | Tfield (f, k, t1, t2) -> +- fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f +- (string_of_field_kind k) +- raw_type t1 raw_type t2 +- | Tnil -> fprintf ppf "Tnil" +- | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t +- | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t +- | Tsubst (t, Some t') -> +- fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' +- | Tunivar name -> fprintf ppf "Tunivar %a" print_name name +- | Tpoly (t, tl) -> +- fprintf ppf "@[Tpoly(@,%a,@,%a)@]" +- raw_type t +- raw_type_list tl +- | Tvariant row -> +- let Row {fields; more; name; fixed; closed} = row_repr row in +- fprintf ppf +- "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" +- "row_fields=" +- (raw_list (fun ppf (l, f) -> +- fprintf ppf "@[%s,@ %a@]" l raw_field f)) +- fields +- "row_more=" raw_type more +- "row_closed=" closed +- "row_fixed=" raw_row_fixed fixed +- "row_name=" +- (fun ppf -> +- match name with None -> fprintf ppf "None" +- | Some(p,tl) -> +- fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) +- | Tpackage (p, fl) -> +- fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl +-and raw_row_fixed ppf = function +-| None -> fprintf ppf "None" +-| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" +-| Some Types.Rigid -> fprintf ppf "Some Rigid" +-| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t +-| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p +- +-and raw_field ppf rf = +- match_row_field +- ~absent:(fun _ -> fprintf ppf "RFabsent") +- ~present:(function +- | None -> +- fprintf ppf "RFpresent None" +- | Some t -> +- fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) +- ~either:(fun c tl m e -> +- fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c +- raw_type_list tl m +- (fun ppf -> +- match e with None -> fprintf ppf " RFnone" +- | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) +- rf +- +-let raw_type_expr ppf t = +- visited := []; kind_vars := []; kind_count := 0; +- raw_type ppf t; +- visited := []; kind_vars := [] +- +-let () = Btype.print_raw := raw_type_expr +- +-(* Normalize paths *) +- +-type param_subst = Id | Nth of int | Map of int list +- +-let is_nth = function +- Nth _ -> true +- | _ -> false +- +-let compose l1 = function +- | Id -> Map l1 +- | Map l2 -> Map (List.map (List.nth l1) l2) +- | Nth n -> Nth (List.nth l1 n) +- +-let apply_subst s1 tyl = +- if tyl = [] then [] +- (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) +- else +- match s1 with +- Nth n1 -> [List.nth tyl n1] +- | Map l1 -> List.map (List.nth tyl) l1 +- | Id -> tyl +- +-type best_path = Paths of Path.t list | Best of Path.t +- +-(** Short-paths cache: the five mutable variables below implement a one-slot +- cache for short-paths +- *) +-let printing_old = ref Env.empty +-let printing_pers = ref String.Set.empty +-(** {!printing_old} and {!printing_pers} are the keys of the one-slot cache *) +- +-let printing_depth = ref 0 +-let printing_cont = ref ([] : Env.iter_cont list) +-let printing_map = ref Path.Map.empty +-(** +- - {!printing_map} is the main value stored in the cache. +- Note that it is evaluated lazily and its value is updated during printing. +- - {!printing_dep} is the current exploration depth of the environment, +- it is used to determine whenever the {!printing_map} should be evaluated +- further before completing a request. +- - {!printing_cont} is the list of continuations needed to evaluate +- the {!printing_map} one level further (see also {!Env.run_iter_cont}) +-*) +- +-let rec index l x = +- match l with +- [] -> raise Not_found +- | a :: l -> if eq_type x a then 0 else 1 + index l x +- +-let rec uniq = function +- [] -> true +- | a :: l -> not (List.memq (a : int) l) && uniq l +- +-let rec normalize_type_path ?(cache=false) env p = +- try +- let (params, ty, _) = Env.find_type_expansion p env in +- match get_desc ty with +- Tconstr (p1, tyl, _) -> +- if List.length params = List.length tyl +- && List.for_all2 eq_type params tyl +- then normalize_type_path ~cache env p1 +- else if cache || List.length params <= List.length tyl +- || not (uniq (List.map get_id tyl)) then (p, Id) +- else +- let l1 = List.map (index params) tyl in +- let (p2, s2) = normalize_type_path ~cache env p1 in +- (p2, compose l1 s2) +- | _ -> +- (p, Nth (index params ty)) +- with +- Not_found -> +- (Env.normalize_type_path None env p, Id) +- +-let penalty s = +- if s <> "" && s.[0] = '_' then +- 10 +- else +- match find_double_underscore s with +- | None -> 1 +- | Some _ -> 10 +- +-let rec path_size = function +- Pident id -> +- penalty (Ident.name id), -Ident.scope id +- | Pdot (p, _) | Pextra_ty (p, Pcstr_ty _) -> +- let (l, b) = path_size p in (1+l, b) +- | Papply (p1, p2) -> +- let (l, b) = path_size p1 in +- (l + fst (path_size p2), b) +- | Pextra_ty (p, _) -> path_size p +- +-let same_printing_env env = +- let used_pers = Env.used_persistent () in +- Env.same_types !printing_old env && String.Set.equal !printing_pers used_pers +- +-let set_printing_env env = +- printing_env := env; +- if !Clflags.real_paths || +- !printing_env == Env.empty || +- same_printing_env env then +- () +- else begin +- (* printf "Reset printing_map@."; *) +- printing_old := env; +- printing_pers := Env.used_persistent (); +- printing_map := Path.Map.empty; +- printing_depth := 0; +- (* printf "Recompute printing_map.@."; *) +- let cont = +- Env.iter_types +- (fun p (p', _decl) -> +- let (p1, s1) = normalize_type_path env p' ~cache:true in +- (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) +- if s1 = Id then +- try +- let r = Path.Map.find p1 !printing_map in +- match !r with +- Paths l -> r := Paths (p :: l) +- | Best p' -> r := Paths [p; p'] (* assert false *) +- with Not_found -> +- printing_map := Path.Map.add p1 (ref (Paths [p])) !printing_map) +- env in +- printing_cont := [cont]; +- end +- +-let wrap_printing_env env f = +- set_printing_env env; +- try_finally f ~always:(fun () -> set_printing_env Env.empty) +- +-let wrap_printing_env ~error env f = +- if error then Env.without_cmis (wrap_printing_env env) f +- else wrap_printing_env env f +- +-let rec lid_of_path = function +- Path.Pident id -> +- Longident.Lident (Ident.name id) +- | Path.Pdot (p1, s) | Path.Pextra_ty (p1, Pcstr_ty s) -> +- Longident.Ldot (lid_of_path p1, s) +- | Path.Papply (p1, p2) -> +- Longident.Lapply (lid_of_path p1, lid_of_path p2) +- | Path.Pextra_ty (p, Pext_ty) -> lid_of_path p +- +-let is_unambiguous path env = +- let l = Env.find_shadowed_types path env in +- List.exists (Path.same path) l || (* concrete paths are ok *) +- match l with +- [] -> true +- | p :: rem -> +- (* allow also coherent paths: *) +- let normalize p = fst (normalize_type_path ~cache:true env p) in +- let p' = normalize p in +- List.for_all (fun p -> Path.same (normalize p) p') rem || +- (* also allow repeatedly defining and opening (for toplevel) *) +- let id = lid_of_path p in +- List.for_all (fun p -> lid_of_path p = id) rem && +- Path.same p (fst (Env.find_type_by_name id env)) +- +-let rec get_best_path r = +- match !r with +- Best p' -> p' +- | Paths [] -> raise Not_found +- | Paths l -> +- r := Paths []; +- List.iter +- (fun p -> +- (* Format.eprintf "evaluating %a@." path p; *) +- match !r with +- Best p' when path_size p >= path_size p' -> () +- | _ -> if is_unambiguous p !printing_env then r := Best p) +- (* else Format.eprintf "%a ignored as ambiguous@." path p *) +- l; +- get_best_path r +- +-let best_type_path p = +- if !printing_env == Env.empty +- then (p, Id) +- else if !Clflags.real_paths +- then (p, Id) +- else +- let (p', s) = normalize_type_path !printing_env p in +- let get_path () = get_best_path (Path.Map.find p' !printing_map) in +- while !printing_cont <> [] && +- try fst (path_size (get_path ())) > !printing_depth with Not_found -> true +- do +- printing_cont := List.map snd (Env.run_iter_cont !printing_cont); +- incr printing_depth; +- done; +- let p'' = try get_path () with Not_found -> p' in +- (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) +- (p'', s) +- +-(* When building a tree for a best type path, we should not disambiguate +- identifiers whenever the short-path algorithm detected a better path than +- the original one.*) +-let tree_of_best_type_path p p' = +- if Path.same p p' then tree_of_path (Some Type) p' +- else tree_of_path ~disambiguation:false None p' +- +-(* Print a type expression *) +- +-let proxy ty = Transient_expr.repr (proxy ty) +- +-(* When printing a type scheme, we print weak names. When printing a plain +- type, we do not. This type controls that behavior *) +-type type_or_scheme = Type | Type_scheme +- +-let is_non_gen mode ty = +- match mode with +- | Type_scheme -> is_Tvar ty && get_level ty <> generic_level +- | Type -> false +- +-let nameable_row row = +- row_name row <> None && +- List.for_all +- (fun (_, f) -> +- match row_field_repr f with +- | Reither(c, l, _) -> +- row_closed row && if c then l = [] else List.length l = 1 +- | _ -> true) +- (row_fields row) +- +-(* This specialized version of [Btype.iter_type_expr] normalizes and +- short-circuits the traversal of the [type_expr], so that it covers only the +- subterms that would be printed by the type printer. *) +-let printer_iter_type_expr f ty = +- match get_desc ty with +- | Tconstr(p, tyl, _) -> +- let (_p', s) = best_type_path p in +- List.iter f (apply_subst s tyl) +- | Tvariant row -> begin +- match row_name row with +- | Some(_p, tyl) when nameable_row row -> +- List.iter f tyl +- | _ -> +- iter_row f row +- end +- | Tobject (fi, nm) -> begin +- match !nm with +- | None -> +- let fields, _ = flatten_fields fi in +- List.iter +- (fun (_, kind, ty) -> +- if field_kind_repr kind = Fpublic then +- f ty) +- fields +- | Some (_, l) -> +- List.iter f (List.tl l) +- end +- | Tfield(_, kind, ty1, ty2) -> +- if field_kind_repr kind = Fpublic then +- f ty1; +- f ty2 +- | _ -> +- Btype.iter_type_expr f ty +- +-module Internal_names : sig +- +- val reset : unit -> unit +- +- val add : Path.t -> unit +- +- val print_explanations : Env.t -> Format.formatter -> unit +- +-end = struct +- +- let names = ref Ident.Set.empty +- +- let reset () = +- names := Ident.Set.empty +- +- let add p = +- match p with +- | Pident id -> +- let name = Ident.name id in +- if String.length name > 0 && name.[0] = '$' then begin +- names := Ident.Set.add id !names +- end +- | Pdot _ | Papply _ | Pextra_ty _ -> () +- +- let print_explanations env ppf = +- let constrs = +- Ident.Set.fold +- (fun id acc -> +- let p = Pident id in +- match Env.find_type p env with +- | exception Not_found -> acc +- | decl -> +- match type_origin decl with +- | Existential constr -> +- let prev = String.Map.find_opt constr acc in +- let prev = Option.value ~default:[] prev in +- String.Map.add constr (tree_of_path None p :: prev) acc +- | Definition | Rec_check_regularity -> acc) +- !names String.Map.empty +- in +- String.Map.iter +- (fun constr out_idents -> +- match out_idents with +- | [] -> () +- | [out_ident] -> +- fprintf ppf +- "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ +- bound by the constructor@ %a.@]" +- (Style.as_inline_code !Oprint.out_ident) out_ident +- Style.inline_code constr +- | out_ident :: out_idents -> +- fprintf ppf +- "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ +- bound by the constructor@ %a.@]" +- (Format.pp_print_list +- ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") +- (Style.as_inline_code !Oprint.out_ident)) +- (List.rev out_idents) +- (Style.as_inline_code !Oprint.out_ident) out_ident +- Style.inline_code constr) +- constrs ++ let constructor ppf c = ++ reset_except_conflicts (); ++ add_constructor_to_preparation c; ++ prepared_constructor ppf c + +-end ++ let constructor_arguments ppf a = ++ let tys = tree_of_constructor_arguments a in ++ !Oprint.out_type ppf (Otyp_tuple tys) + +-module Names : sig +- val reset_names : unit -> unit ++ let label ppf l = ++ prepare_for_printing [l.Types.ld_type]; ++ !Oprint.out_label ppf (tree_of_label l) + +- val add_named_vars : type_expr -> unit +- val add_subst : (type_expr * type_expr) list -> unit ++ let extension_constructor id ppf ext = ++ !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) + +- val new_name : unit -> string +- val new_var_name : non_gen:bool -> type_expr -> unit -> string ++ (* Print an extension declaration *) + +- val name_of_type : (unit -> string) -> transient_expr -> string +- val check_name_of_type : non_gen:bool -> transient_expr -> unit +- +- val remove_names : transient_expr list -> unit +- +- val with_local_names : (unit -> 'a) -> 'a +- +- (* Refresh the weak variable map in the toplevel; for [print_items], which is +- itself for the toplevel *) +- val refresh_weak : unit -> unit +-end = struct +- (* We map from types to names, but not directly; we also store a substitution, +- which maps from types to types. The lookup process is +- "type -> apply substitution -> find name". The substitution is presumed to +- be acyclic. *) +- let names = ref ([] : (transient_expr * string) list) +- let name_subst = ref ([] : (transient_expr * transient_expr) list) +- let name_counter = ref 0 +- let named_vars = ref ([] : string list) +- let visited_for_named_vars = ref ([] : transient_expr list) +- +- let weak_counter = ref 1 +- let weak_var_map = ref TypeMap.empty +- let named_weak_vars = ref String.Set.empty +- +- let reset_names () = +- names := []; +- name_subst := []; +- name_counter := 0; +- named_vars := []; +- visited_for_named_vars := [] +- +- let add_named_var tty = +- match tty.desc with +- Tvar (Some name) | Tunivar (Some name) -> +- if List.mem name !named_vars then () else +- named_vars := name :: !named_vars +- | _ -> () +- +- let rec add_named_vars ty = +- let tty = Transient_expr.repr ty in +- let px = proxy ty in +- if not (List.memq px !visited_for_named_vars) then begin +- visited_for_named_vars := px :: !visited_for_named_vars; +- match tty.desc with +- | Tvar _ | Tunivar _ -> +- add_named_var tty +- | _ -> +- printer_iter_type_expr add_named_vars ty +- end +- +- let rec substitute ty = +- match List.assq ty !name_subst with +- | ty' -> substitute ty' +- | exception Not_found -> ty +- +- let add_subst subst = +- name_subst := +- List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) +- subst +- @ !name_subst +- +- let name_is_already_used name = +- List.mem name !named_vars +- || List.exists (fun (_, name') -> name = name') !names +- || String.Set.mem name !named_weak_vars +- +- let rec new_name () = +- let name = Misc.letter_of_int !name_counter in +- incr name_counter; +- if name_is_already_used name then new_name () else name +- +- let rec new_weak_name ty () = +- let name = "weak" ^ Int.to_string !weak_counter in +- incr weak_counter; +- if name_is_already_used name then new_weak_name ty () +- else begin +- named_weak_vars := String.Set.add name !named_weak_vars; +- weak_var_map := TypeMap.add ty name !weak_var_map; +- name +- end +- +- let new_var_name ~non_gen ty () = +- if non_gen then new_weak_name ty () +- else new_name () +- +- let name_of_type name_generator t = +- (* We've already been through repr at this stage, so t is our representative +- of the union-find class. *) +- let t = substitute t in +- try List.assq t !names with Not_found -> +- try TransientTypeMap.find t !weak_var_map with Not_found -> +- let name = +- match t.desc with +- Tvar (Some name) | Tunivar (Some name) -> +- (* Some part of the type we've already printed has assigned another +- * unification variable to that name. We want to keep the name, so +- * try adding a number until we find a name that's not taken. *) +- let available name = +- List.for_all +- (fun (_, name') -> name <> name') +- !names +- in +- if available name then name +- else +- let suffixed i = name ^ Int.to_string i in +- let i = Misc.find_first_mono (fun i -> available (suffixed i)) in +- suffixed i +- | _ -> +- (* No name available, create a new one *) +- name_generator () +- in +- (* Exception for type declarations *) +- if name <> "_" then names := (t, name) :: !names; +- name +- +- let check_name_of_type ~non_gen px = +- let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in +- ignore(name_of_type name_gen px) +- +- let remove_names tyl = +- let tyl = List.map substitute tyl in +- names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names +- +- let with_local_names f = +- let old_names = !names in +- let old_subst = !name_subst in +- names := []; +- name_subst := []; +- try_finally +- ~always:(fun () -> +- names := old_names; +- name_subst := old_subst) +- f +- +- let refresh_weak () = +- let refresh t name (m,s) = +- if is_non_gen Type_scheme t then +- begin +- TypeMap.add t name m, +- String.Set.add name s +- end +- else m, s in +- let m, s = +- TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in +- named_weak_vars := s; +- weak_var_map := m +-end + +-let reserve_names ty = +- normalize_type ty; +- Names.add_named_vars ty +- +-let visited_objects = ref ([] : transient_expr list) +-let aliased = ref ([] : transient_expr list) +-let delayed = ref ([] : transient_expr list) +-let printed_aliases = ref ([] : transient_expr list) +- +-(* [printed_aliases] is a subset of [aliased] that records only those aliased +- types that have actually been printed; this allows us to avoid naming loops +- that the user will never see. *) +- +-let add_delayed t = +- if not (List.memq t !delayed) then delayed := t :: !delayed +- +-let is_aliased_proxy px = List.memq px !aliased +- +-let add_alias_proxy px = +- if not (is_aliased_proxy px) then +- aliased := px :: !aliased +- +-let add_alias ty = add_alias_proxy (proxy ty) +- +-let add_printed_alias_proxy ~non_gen px = +- Names.check_name_of_type ~non_gen px; +- printed_aliases := px :: !printed_aliases +- +-let add_printed_alias ty = add_printed_alias_proxy (proxy ty) +- +-let aliasable ty = +- match get_desc ty with +- Tvar _ | Tunivar _ | Tpoly _ -> false +- | Tconstr (p, _, _) -> +- not (is_nth (snd (best_type_path p))) +- | _ -> true +- +-let should_visit_object ty = +- match get_desc ty with +- | Tvariant row -> not (static_row row) +- | Tobject _ -> opened_object ty +- | _ -> false +- +-let rec mark_loops_rec visited ty = +- let px = proxy ty in +- if List.memq px visited && aliasable ty then add_alias_proxy px else +- let tty = Transient_expr.repr ty in +- let visited = px :: visited in +- match tty.desc with +- | Tvariant _ | Tobject _ -> +- if List.memq px !visited_objects then add_alias_proxy px else begin +- if should_visit_object ty then +- visited_objects := px :: !visited_objects; +- printer_iter_type_expr (mark_loops_rec visited) ty +- end +- | Tpoly(ty, tyl) -> +- List.iter add_alias tyl; +- mark_loops_rec visited ty +- | _ -> +- printer_iter_type_expr (mark_loops_rec visited) ty +- +-let mark_loops ty = +- mark_loops_rec [] ty +- +-let prepare_type ty = +- reserve_names ty; +- mark_loops ty +- +-let reset_loop_marks () = +- visited_objects := []; aliased := []; delayed := []; printed_aliases := [] +- +-let reset_except_context () = +- Names.reset_names (); reset_loop_marks (); Internal_names.reset () +- +-let reset () = +- Conflicts.reset (); +- reset_except_context () +- +-let prepare_for_printing tyl = +- reset_except_context (); +- List.iter prepare_type tyl +- +-let add_type_to_preparation = prepare_type +- +-(* Disabled in classic mode when printing an unification error *) +-let print_labels = ref true +- +-let alias_nongen_row mode px ty = +- match get_desc ty with +- | Tvariant _ | Tobject _ -> +- if is_non_gen mode (Transient_expr.type_expr px) then +- add_alias_proxy px +- | _ -> () +- +-let rec tree_of_typexp mode ty = +- let px = proxy ty in +- if List.memq px !printed_aliases && not (List.memq px !delayed) then +- let non_gen = is_non_gen mode (Transient_expr.type_expr px) in +- let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in +- Otyp_var (non_gen, name) else +- +- let pr_typ () = +- let tty = Transient_expr.repr ty in +- match tty.desc with +- | Tvar _ -> +- let non_gen = is_non_gen mode ty in +- let name_gen = Names.new_var_name ~non_gen ty in +- Otyp_var (non_gen, Names.name_of_type name_gen tty) +- | Tarrow(l, ty1, ty2, _) -> +- let lab = +- if !print_labels || is_optional l then l else Nolabel +- in +- let t1 = +- if is_optional l then +- match get_desc ty1 with +- | Tconstr(path, [ty], _) +- when Path.same path Predef.path_option -> +- tree_of_typexp mode ty +- | _ -> Otyp_stuff "" +- else tree_of_typexp mode ty1 in +- Otyp_arrow (lab, t1, tree_of_typexp mode ty2) +- | Ttuple tyl -> +- Otyp_tuple (tree_of_typlist mode tyl) +- | Tconstr(p, tyl, _abbrev) -> +- let p', s = best_type_path p in +- let tyl' = apply_subst s tyl in +- if is_nth s && not (tyl'=[]) +- then tree_of_typexp mode (List.hd tyl') +- else begin +- Internal_names.add p'; +- Otyp_constr (tree_of_best_type_path p p', tree_of_typlist mode tyl') +- end +- | Tvariant row -> +- let Row {fields; name; closed; _} = row_repr row in +- let fields = +- if closed then +- List.filter (fun (_, f) -> row_field_repr f <> Rabsent) +- fields +- else fields in +- let present = +- List.filter +- (fun (_, f) -> +- match row_field_repr f with +- | Rpresent _ -> true +- | _ -> false) +- fields in +- let all_present = List.length present = List.length fields in +- begin match name with +- | Some(p, tyl) when nameable_row row -> +- let (p', s) = best_type_path p in +- let id = tree_of_best_type_path p p' in +- let args = tree_of_typlist mode (apply_subst s tyl) in +- let out_variant = +- if is_nth s then List.hd args else Otyp_constr (id, args) in +- if closed && all_present then +- out_variant +- else +- let tags = +- if all_present then None else Some (List.map fst present) in +- Otyp_variant (Ovar_typ out_variant, closed, tags) +- | _ -> +- let fields = List.map (tree_of_row_field mode) fields in +- let tags = +- if all_present then None else Some (List.map fst present) in +- Otyp_variant (Ovar_fields fields, closed, tags) +- end +- | Tobject (fi, nm) -> +- tree_of_typobject mode fi !nm +- | Tnil | Tfield _ -> +- tree_of_typobject mode ty None +- | Tsubst _ -> +- (* This case should only happen when debugging the compiler *) +- Otyp_stuff "" +- | Tlink _ -> +- fatal_error "Printtyp.tree_of_typexp" +- | Tpoly (ty, []) -> +- tree_of_typexp mode ty +- | Tpoly (ty, tyl) -> +- (*let print_names () = +- List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; +- prerr_string "; " in *) +- if tyl = [] then tree_of_typexp mode ty else begin +- let tyl = List.map Transient_expr.repr tyl in +- let old_delayed = !delayed in +- (* Make the names delayed, so that the real type is +- printed once when used as proxy *) +- List.iter add_delayed tyl; +- let tl = List.map (Names.name_of_type Names.new_name) tyl in +- let tr = Otyp_poly (tl, tree_of_typexp mode ty) in +- (* Forget names when we leave scope *) +- Names.remove_names tyl; +- delayed := old_delayed; tr +- end +- | Tunivar _ -> +- Otyp_var (false, Names.name_of_type Names.new_name tty) +- | Tpackage (p, fl) -> +- let fl = +- List.map +- (fun (li, ty) -> ( +- String.concat "." (Longident.flatten li), +- tree_of_typexp mode ty +- )) fl in +- Otyp_module (tree_of_path (Some Module_type) p, fl) +- in +- if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; +- alias_nongen_row mode px ty; +- if is_aliased_proxy px && aliasable ty then begin +- let non_gen = is_non_gen mode (Transient_expr.type_expr px) in +- add_printed_alias_proxy ~non_gen px; +- (* add_printed_alias chose a name, thus the name generator +- doesn't matter.*) +- let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in +- Otyp_alias {non_gen; aliased = pr_typ (); alias } end +- else pr_typ () +- +-and tree_of_row_field mode (l, f) = +- match row_field_repr f with +- | Rpresent None | Reither(true, [], _) -> (l, false, []) +- | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) +- | Reither(c, tyl, _) -> +- if c (* contradiction: constant constructor with an argument *) +- then (l, true, tree_of_typlist mode tyl) +- else (l, false, tree_of_typlist mode tyl) +- | Rabsent -> (l, false, [] (* actually, an error *)) +- +-and tree_of_typlist mode tyl = +- List.map (tree_of_typexp mode) tyl +- +-and tree_of_typobject mode fi nm = +- begin match nm with +- | None -> +- let pr_fields fi = +- let (fields, rest) = flatten_fields fi in +- let present_fields = +- List.fold_right +- (fun (n, k, t) l -> +- match field_kind_repr k with +- | Fpublic -> (n, t) :: l +- | _ -> l) +- fields [] in +- let sorted_fields = +- List.sort +- (fun (n, _) (n', _) -> String.compare n n') present_fields in +- tree_of_typfields mode rest sorted_fields in +- let (fields, open_row) = pr_fields fi in +- Otyp_object {fields; open_row} +- | Some (p, _ty :: tyl) -> +- let args = tree_of_typlist mode tyl in +- let (p', s) = best_type_path p in +- assert (s = Id); +- Otyp_class (tree_of_best_type_path p p', args) +- | _ -> +- fatal_error "Printtyp.tree_of_typobject" +- end +- +-and tree_of_typfields mode rest = function +- | [] -> +- let open_row = +- match get_desc rest with +- | Tvar _ | Tunivar _ | Tconstr _-> true +- | Tnil -> false +- | _ -> fatal_error "typfields (1)" +- in +- ([], open_row) +- | (s, t) :: l -> +- let field = (s, tree_of_typexp mode t) in +- let (fields, rest) = tree_of_typfields mode rest l in +- (field :: fields, rest) +- +-let typexp mode ppf ty = +- !Oprint.out_type ppf (tree_of_typexp mode ty) +- +-let prepared_type_expr ppf ty = typexp Type ppf ty +- +-let type_expr ppf ty = +- (* [type_expr] is used directly by error message printers, +- we mark eventual loops ourself to avoid any misuse and stack overflow *) +- prepare_for_printing [ty]; +- prepared_type_expr ppf ty +- +-(* "Half-prepared" type expression: [ty] should have had its names reserved, but +- should not have had its loops marked. *) +-let type_expr_with_reserved_names ppf ty = +- reset_loop_marks (); +- mark_loops ty; +- prepared_type_expr ppf ty +- +-let shared_type_scheme ppf ty = +- prepare_type ty; +- typexp Type_scheme ppf ty +- +-let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty +- +-let type_scheme ppf ty = +- prepare_for_printing [ty]; +- prepared_type_scheme ppf ty +- +-let type_path ppf p = +- let (p', s) = best_type_path p in +- let p'' = if (s = Id) then p' else p in +- let t = tree_of_best_type_path p p'' in +- !Oprint.out_ident ppf t +- +-let tree_of_type_scheme ty = +- prepare_for_printing [ty]; +- tree_of_typexp Type_scheme ty +- +-(* Print one type declaration *) +- +-let tree_of_constraints params = +- List.fold_right +- (fun ty list -> +- let ty' = unalias ty in +- if proxy ty != proxy ty' then +- let tr = tree_of_typexp Type_scheme ty in +- (tr, tree_of_typexp Type_scheme ty') :: list +- else list) +- params [] +- +-let filter_params tyl = +- let params = +- List.fold_left +- (fun tyl ty -> +- if List.exists (eq_type ty) tyl +- then newty2 ~level:generic_level (Ttuple [ty]) :: tyl +- else ty :: tyl) +- (* Two parameters might be identical due to a constraint but we need to +- print them differently in order to make the output syntactically valid. +- We use [Ttuple [ty]] because it is printed as [ty]. *) +- (* Replacing fold_left by fold_right does not work! *) +- [] tyl +- in List.rev params +- +-let prepare_type_constructor_arguments = function +- | Cstr_tuple l -> List.iter prepare_type l +- | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l +- +-let tree_of_label l = +- (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type) +- +-let tree_of_constructor_arguments = function +- | Cstr_tuple l -> tree_of_typlist Type l +- | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] +- +-let tree_of_single_constructor cd = +- let name = Ident.name cd.cd_id in +- let ret = Option.map (tree_of_typexp Type) cd.cd_res in +- let args = tree_of_constructor_arguments cd.cd_args in +- { +- ocstr_name = name; +- ocstr_args = args; +- ocstr_return_type = ret; +- } + +-(* When printing GADT constructor, we need to forget the naming decision we took +- for the type parameters and constraints. Indeed, in +- {[ +- type 'a t = X: 'a -> 'b t +- ]} +- It is fine to print both the type parameter ['a] and the existentially +- quantified ['a] in the definition of the constructor X as ['a] +- *) +-let tree_of_constructor_in_decl cd = +- match cd.cd_res with +- | None -> tree_of_single_constructor cd +- | Some _ -> Names.with_local_names (fun () -> tree_of_single_constructor cd) +- +-let prepare_decl id decl = +- let params = filter_params decl.type_params in +- begin match decl.type_manifest with +- | Some ty -> +- let vars = free_variables ty in +- List.iter +- (fun ty -> +- if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars +- then set_type_desc ty (Tvar None)) +- params +- | None -> () +- end; +- List.iter add_alias params; +- List.iter prepare_type params; +- List.iter (add_printed_alias ~non_gen:false) params; +- let ty_manifest = +- match decl.type_manifest with +- | None -> None +- | Some ty -> +- let ty = +- (* Special hack to hide variant name *) +- match get_desc ty with +- Tvariant row -> +- begin match row_name row with +- Some (Pident id', _) when Ident.same id id' -> +- newgenty (Tvariant (set_row_name row None)) +- | _ -> ty +- end +- | _ -> ty +- in +- prepare_type ty; +- Some ty +- in +- begin match decl.type_kind with +- | Type_abstract _ -> () +- | Type_variant (cstrs, _rep) -> +- List.iter +- (fun c -> +- prepare_type_constructor_arguments c.cd_args; +- Option.iter prepare_type c.cd_res) +- cstrs +- | Type_record(l, _rep) -> +- List.iter (fun l -> prepare_type l.ld_type) l +- | Type_open -> () +- end; +- ty_manifest, params +- +-let tree_of_type_decl id decl = +- let ty_manifest, params = prepare_decl id decl in +- let type_param ot_variance = +- function +- | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} +- | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} +- in +- let type_defined decl = +- let abstr = +- match decl.type_kind with +- Type_abstract _ -> +- decl.type_manifest = None || decl.type_private = Private +- | Type_record _ -> +- decl.type_private = Private +- | Type_variant (tll, _rep) -> +- decl.type_private = Private || +- List.exists (fun cd -> cd.cd_res <> None) tll +- | Type_open -> +- decl.type_manifest = None +- in +- let vari = +- List.map2 +- (fun ty v -> +- let is_var = is_Tvar ty in +- if abstr || not is_var then +- let inj = +- type_kind_is_abstract decl && Variance.mem Inj v && +- match decl.type_manifest with +- | None -> true +- | Some ty -> (* only abstract or private row types *) +- decl.type_private = Private && +- Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty) +- and (co, cn) = Variance.get_upper v in +- (if not cn then Covariant else +- if not co then Contravariant else NoVariance), +- (if inj then Injective else NoInjectivity) +- else (NoVariance, NoInjectivity)) +- decl.type_params decl.type_variance +- in +- (Ident.name id, +- List.map2 (fun ty cocn -> type_param cocn (tree_of_typexp Type ty)) +- params vari) +- in +- let tree_of_manifest ty1 = +- match ty_manifest with +- | None -> ty1 +- | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) +- in +- let (name, args) = type_defined decl in +- let constraints = tree_of_constraints params in +- let ty, priv, unboxed = +- match decl.type_kind with +- | Type_abstract _ -> +- begin match ty_manifest with +- | None -> (Otyp_abstract, Public, false) +- | Some ty -> +- tree_of_typexp Type ty, decl.type_private, false +- end +- | Type_variant (cstrs, rep) -> +- tree_of_manifest +- (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), +- decl.type_private, +- (rep = Variant_unboxed) +- | Type_record(lbls, rep) -> +- tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), +- decl.type_private, +- (match rep with Record_unboxed _ -> true | _ -> false) +- | Type_open -> +- tree_of_manifest Otyp_open, +- decl.type_private, +- false +- in +- { otype_name = name; +- otype_params = args; +- otype_type = ty; +- otype_private = priv; +- otype_immediate = Type_immediacy.of_attributes decl.type_attributes; +- otype_unboxed = unboxed; +- otype_cstrs = constraints } +- +-let add_type_decl_to_preparation id decl = +- ignore @@ prepare_decl id decl +- +-let tree_of_prepared_type_decl id decl = +- tree_of_type_decl id decl +- +-let tree_of_type_decl id decl = +- reset_except_context(); +- tree_of_type_decl id decl +- +-let add_constructor_to_preparation c = +- prepare_type_constructor_arguments c.cd_args; +- Option.iter prepare_type c.cd_res +- +-let prepared_constructor ppf c = +- !Oprint.out_constr ppf (tree_of_single_constructor c) +- +-let constructor ppf c = +- reset_except_context (); +- add_constructor_to_preparation c; +- prepared_constructor ppf c +- +-let label ppf l = +- reset_except_context (); +- prepare_type l.ld_type; +- !Oprint.out_label ppf (tree_of_label l) +- +-let tree_of_type_declaration id decl rs = +- Osig_type (tree_of_type_decl id decl, tree_of_rec rs) +- +-let tree_of_prepared_type_declaration id decl rs = +- Osig_type (tree_of_prepared_type_decl id decl, tree_of_rec rs) +- +-let type_declaration id ppf decl = +- !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) +- +-let add_type_declaration_to_preparation id decl = +- add_type_decl_to_preparation id decl +- +-let prepared_type_declaration id ppf decl = +- !Oprint.out_sig_item ppf +- (tree_of_prepared_type_declaration id decl Trec_first) +- +-let constructor_arguments ppf a = +- let tys = tree_of_constructor_arguments a in +- !Oprint.out_type ppf (Otyp_tuple tys) +- +-(* Print an extension declaration *) +- +-let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = +- let ret = Option.map (tree_of_typexp Type) ext_ret_type in +- let args = tree_of_constructor_arguments ext_args in +- (args, ret) +- +-(* When printing extension constructor, it is important to ensure that +-after printing the constructor, we are still in the scope of the constructor. +-For GADT constructor, this can be done by printing the type parameters inside +-their own isolated scope. This ensures that in +-{[ +- type 'b t += A: 'b -> 'b any t +-]} +-the type parameter `'b` is not bound when printing the type variable `'b` from +-the constructor definition from the type parameter. +- +-Contrarily, for non-gadt constructor, we must keep the same scope for +-the type parameters and the constructor because a type constraint may +-have changed the name of the type parameter: +-{[ +-type -'a t = .. constraint 'a> = 'a +-(* the universal 'a is here to steal the name 'a from the type parameter *) +-type 'a t = X of 'a +-]} *) +- +- +-let add_extension_constructor_to_preparation ext = +- let ty_params = filter_params ext.ext_type_params in +- List.iter add_alias ty_params; +- List.iter prepare_type ty_params; +- prepare_type_constructor_arguments ext.ext_args; +- Option.iter prepare_type ext.ext_ret_type +- +-let prepared_tree_of_extension_constructor +- id ext es +- = +- let ty_name = Path.name ext.ext_type_path in +- let ty_params = filter_params ext.ext_type_params in +- let type_param = +- function +- | Otyp_var (_, id) -> id +- | _ -> "?" +- in +- let param_scope f = +- match ext.ext_ret_type with +- | None -> +- (* normal constructor: same scope for parameters and the constructor *) +- f () +- | Some _ -> +- (* gadt constructor: isolated scope for the type parameters *) +- Names.with_local_names f +- in +- let ty_params = +- param_scope +- (fun () -> +- List.iter (add_printed_alias ~non_gen:false) ty_params; +- List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params +- ) +- in +- let name = Ident.name id in +- let args, ret = +- extension_constructor_args_and_ret_type_subtree +- ext.ext_args +- ext.ext_ret_type +- in +- let ext = +- { oext_name = name; +- oext_type_name = ty_name; +- oext_type_params = ty_params; +- oext_args = args; +- oext_ret_type = ret; +- oext_private = ext.ext_private } +- in +- let es = +- match es with +- Text_first -> Oext_first +- | Text_next -> Oext_next +- | Text_exception -> Oext_exception +- in +- Osig_typext (ext, es) +- +-let tree_of_extension_constructor id ext es = +- reset_except_context (); +- add_extension_constructor_to_preparation ext; +- prepared_tree_of_extension_constructor id ext es +- +-let extension_constructor id ppf ext = +- !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) +- +-let prepared_extension_constructor id ppf ext = +- !Oprint.out_sig_item ppf +- (prepared_tree_of_extension_constructor id ext Text_first) +- +-let extension_only_constructor id ppf ext = +- reset_except_context (); +- prepare_type_constructor_arguments ext.ext_args; +- Option.iter prepare_type ext.ext_ret_type; +- let name = Ident.name id in +- let args, ret = +- extension_constructor_args_and_ret_type_subtree +- ext.ext_args +- ext.ext_ret_type +- in +- Format.fprintf ppf "@[%a@]" +- !Oprint.out_constr { +- ocstr_name = name; ++ let extension_only_constructor id ppf (ext:Types.extension_constructor) = ++ reset_except_conflicts (); ++ prepare_type_constructor_arguments ext.ext_args; ++ Option.iter add_type_to_preparation ext.ext_ret_type; ++ let name = Ident.name id in ++ let args, ret = ++ extension_constructor_args_and_ret_type_subtree ++ ext.ext_args ++ ext.ext_ret_type ++ in ++ Fmt.fprintf ppf "@[%a@]" ++ !Oprint.out_constr { ++ Outcometree.ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +-(* Print a value declaration *) ++ (* Print a signature body (used by -i when compiling a .ml) *) + +-let tree_of_value_description id decl = +- (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) +- let id = Ident.name id in +- let ty = tree_of_type_scheme decl.val_type in +- let vd = +- { oval_name = id; +- oval_type = ty; +- oval_prims = []; +- oval_attributes = [] } +- in +- let vd = +- match decl.val_kind with +- | Val_prim p -> Primitive.print p vd +- | _ -> vd +- in +- Osig_value vd +- +-let value_description id ppf decl = +- !Oprint.out_sig_item ppf (tree_of_value_description id decl) +- +-(* Print a class type *) +- +-let method_type priv ty = +- match priv, get_desc ty with +- | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) +- | _ , _ -> (ty, []) +- +-let prepare_method _lab (priv, _virt, ty) = +- let ty, _ = method_type priv ty in +- prepare_type ty +- +-let tree_of_method mode (lab, priv, virt, ty) = +- let (ty, tyl) = method_type priv ty in +- let tty = tree_of_typexp mode ty in +- Names.remove_names (List.map Transient_expr.repr tyl); +- let priv = priv <> Mpublic in +- let virt = virt = Virtual in +- Ocsg_method (lab, priv, virt, tty) +- +-let rec prepare_class_type params = function +- | Cty_constr (_p, tyl, cty) -> +- let row = Btype.self_type_row cty in +- if List.memq (proxy row) !visited_objects +- || not (List.for_all is_Tvar params) +- || List.exists (deep_occur row) tyl +- then prepare_class_type params cty +- else List.iter prepare_type tyl +- | Cty_signature sign -> +- (* Self may have a name *) +- let px = proxy sign.csig_self_row in +- if List.memq px !visited_objects then add_alias_proxy px +- else visited_objects := px :: !visited_objects; +- Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; +- Meths.iter prepare_method sign.csig_meths +- | Cty_arrow (_, ty, cty) -> +- prepare_type ty; +- prepare_class_type params cty +- +-let rec tree_of_class_type mode params = +- function +- | Cty_constr (p', tyl, cty) -> +- let row = Btype.self_type_row cty in +- if List.memq (proxy row) !visited_objects +- || not (List.for_all is_Tvar params) +- then +- tree_of_class_type mode params cty +- else +- let namespace = Namespace.best_class_namespace p' in +- Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) +- | Cty_signature sign -> +- let px = proxy sign.csig_self_row in +- let self_ty = +- if is_aliased_proxy px then +- Some +- (Otyp_var (false, Names.name_of_type Names.new_name px)) +- else None +- in +- let csil = [] in +- let csil = +- List.fold_left +- (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) +- csil (tree_of_constraints params) +- in +- let all_vars = +- Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] +- in +- (* Consequence of PR#3607: order of Map.fold has changed! *) +- let all_vars = List.rev all_vars in +- let csil = +- List.fold_left +- (fun csil (l, m, v, t) -> +- Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) +- :: csil) +- csil all_vars +- in +- let all_meths = +- Meths.fold +- (fun l (p, v, t) all -> (l, p, v, t) :: all) +- sign.csig_meths [] +- in +- let all_meths = List.rev all_meths in +- let csil = +- List.fold_left +- (fun csil meth -> tree_of_method mode meth :: csil) +- csil all_meths +- in +- Octy_signature (self_ty, List.rev csil) +- | Cty_arrow (l, ty, cty) -> +- let lab = +- if !print_labels || is_optional l then l else Nolabel +- in +- let tr = +- if is_optional l then +- match get_desc ty with +- | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> +- tree_of_typexp mode ty +- | _ -> Otyp_stuff "" +- else tree_of_typexp mode ty in +- Octy_arrow (lab, tr, tree_of_class_type mode params cty) +- +-let class_type ppf cty = +- reset (); +- prepare_class_type [] cty; +- !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) +- +-let tree_of_class_param param variance = +- let ot_variance = +- if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in +- match tree_of_typexp Type_scheme param with +- Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} +- | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} +- +-let class_variance = +- let open Variance in let open Asttypes in +- List.map (fun v -> +- (if not (mem May_pos v) then Contravariant else +- if not (mem May_neg v) then Covariant else NoVariance), +- NoInjectivity) +- +-let tree_of_class_declaration id cl rs = +- let params = filter_params cl.cty_params in +- +- reset_except_context (); +- List.iter add_alias params; +- prepare_class_type params cl.cty_type; +- let px = proxy (Btype.self_type_row cl.cty_type) in +- List.iter prepare_type params; +- +- List.iter (add_printed_alias ~non_gen:false) params; +- if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px; +- +- let vir_flag = cl.cty_new = None in +- Osig_class +- (vir_flag, Ident.name id, +- List.map2 tree_of_class_param params (class_variance cl.cty_variance), +- tree_of_class_type Type_scheme params cl.cty_type, +- tree_of_rec rs) +- +-let class_declaration id ppf cl = +- !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) +- +-let tree_of_cltype_declaration id cl rs = +- let params = cl.clty_params in +- +- reset_except_context (); +- List.iter add_alias params; +- prepare_class_type params cl.clty_type; +- let px = proxy (Btype.self_type_row cl.clty_type) in +- List.iter prepare_type params; +- +- List.iter (add_printed_alias ~non_gen:false) params; +- if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px; +- +- let sign = Btype.signature_of_class_type cl.clty_type in +- let has_virtual_vars = +- Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) +- sign.csig_vars false +- in +- let has_virtual_meths = +- Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) +- sign.csig_meths false +- in +- Osig_class_type +- (has_virtual_vars || has_virtual_meths, Ident.name id, +- List.map2 tree_of_class_param params (class_variance cl.clty_variance), +- tree_of_class_type Type_scheme params cl.clty_type, +- tree_of_rec rs) +- +-let cltype_declaration id ppf cl = +- !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) +- +-(* Print a module type *) +- +-let wrap_env fenv ftree arg = +- (* We save the current value of the short-path cache *) +- (* From keys *) +- let env = !printing_env in +- let old_pers = !printing_pers in +- (* to data *) +- let old_map = !printing_map in +- let old_depth = !printing_depth in +- let old_cont = !printing_cont in +- set_printing_env (fenv env); +- let tree = ftree arg in +- if !Clflags.real_paths +- || same_printing_env env then () +- (* our cached key is still live in the cache, and we want to keep all +- progress made on the computation of the [printing_map] *) +- else begin +- (* we restore the snapshotted cache before calling set_printing_env *) +- printing_old := env; +- printing_pers := old_pers; +- printing_depth := old_depth; +- printing_cont := old_cont; +- printing_map := old_map +- end; +- set_printing_env env; +- tree +- +-let dummy = +- { +- type_params = []; +- type_arity = 0; +- type_kind = Type_abstract Definition; +- type_private = Public; +- type_manifest = None; +- type_variance = []; +- type_separability = []; +- type_is_newtype = false; +- type_expansion_scope = Btype.lowest_level; +- type_loc = Location.none; +- type_attributes = []; +- type_immediate = Unknown; +- type_unboxed_default = false; +- type_uid = Uid.internal_not_actually_unique; +- } +- +-(** we hide items being defined from short-path to avoid shortening +- [type t = Path.To.t] into [type t = t]. +-*) +- +-let ident_sigitem = function +- | Types.Sig_type(ident,_,_,_) -> {hide=true;ident} +- | Types.Sig_class(ident,_,_,_) +- | Types.Sig_class_type (ident,_,_,_) +- | Types.Sig_module(ident,_, _,_,_) +- | Types.Sig_value (ident,_,_) +- | Types.Sig_modtype (ident,_,_) +- | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } +- +-let hide ids env = +- let hide_id id env = +- (* Global idents cannot be renamed *) +- if id.hide && not (Ident.global id.ident) then +- Env.add_type ~check:false (Ident.rename id.ident) dummy env +- else env +- in +- List.fold_right hide_id ids env +- +-let with_hidden_items ids f = +- let with_hidden_in_printing_env ids f = +- wrap_env (hide ids) (Naming_context.with_hidden ids) f +- in +- if not !Clflags.real_paths then +- with_hidden_in_printing_env ids f +- else +- Naming_context.with_hidden ids f +- +- +-let add_sigitem env x = +- Env.add_signature (Signature_group.flatten x) env +- +-let rec tree_of_modtype ?(ellipsis=false) = function +- | Mty_ident p -> +- Omty_ident (tree_of_path (Some Module_type) p) +- | Mty_signature sg -> +- Omty_signature (if ellipsis then [Osig_ellipsis] +- else tree_of_signature sg) +- | Mty_functor(param, ty_res) -> +- let param, env = +- tree_of_functor_parameter param +- in +- let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in +- Omty_functor (param, res) +- | Mty_alias p -> +- Omty_alias (tree_of_path (Some Module) p) +- +-and tree_of_functor_parameter = function +- | Unit -> +- None, fun k -> k +- | Named (param, ty_arg) -> +- let name, env = +- match param with +- | None -> None, fun env -> env +- | Some id -> +- Some (Ident.name id), +- Env.add_module ~arg:true id Mp_present ty_arg +- in +- Some (name, tree_of_modtype ~ellipsis:false ty_arg), env +- +-and tree_of_signature sg = +- wrap_env (fun env -> env)(fun sg -> +- let tree_groups = tree_of_signature_rec !printing_env sg in +- List.concat_map (fun (_env,l) -> List.map snd l) tree_groups +- ) sg +- +-and tree_of_signature_rec env' sg = +- let structured = List.of_seq (Signature_group.seq sg) in +- let collect_trees_of_rec_group group = +- let env = !printing_env in +- let env', group_trees = +- trees_of_recursive_sigitem_group env group +- in +- set_printing_env env'; +- (env, group_trees) in +- set_printing_env env'; +- List.map collect_trees_of_rec_group structured +- +-and trees_of_recursive_sigitem_group env +- (syntactic_group: Signature_group.rec_group) = +- let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in +- let env = Env.add_signature syntactic_group.pre_ghosts env in +- match syntactic_group.group with +- | Not_rec x -> add_sigitem env x, [display x] +- | Rec_group items -> +- let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in +- List.fold_left add_sigitem env items, +- with_hidden_items ids (fun () -> List.map display items) +- +-and tree_of_sigitem = function +- | Sig_value(id, decl, _) -> +- tree_of_value_description id decl +- | Sig_type(id, decl, rs, _) -> +- tree_of_type_declaration id decl rs +- | Sig_typext(id, ext, es, _) -> +- tree_of_extension_constructor id ext es +- | Sig_module(id, _, md, rs, _) -> +- let ellipsis = +- List.exists (function +- | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true +- | _ -> false) +- md.md_attributes in +- tree_of_module id md.md_type rs ~ellipsis +- | Sig_modtype(id, decl, _) -> +- tree_of_modtype_declaration id decl +- | Sig_class(id, decl, rs, _) -> +- tree_of_class_declaration id decl rs +- | Sig_class_type(id, decl, rs, _) -> +- tree_of_cltype_declaration id decl rs +- +-and tree_of_modtype_declaration id decl = +- let mty = +- match decl.mtd_type with +- | None -> Omty_abstract +- | Some mty -> tree_of_modtype mty +- in +- Osig_modtype (Ident.name id, mty) +- +-and tree_of_module id ?ellipsis mty rs = +- Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) +- +-let rec functor_parameters ~sep custom_printer = function +- | [] -> ignore +- | [id,param] -> +- Format.dprintf "%t%t" +- (custom_printer param) +- (functor_param ~sep ~custom_printer id []) +- | (id,param) :: q -> +- Format.dprintf "%t%a%t" +- (custom_printer param) +- sep () +- (functor_param ~sep ~custom_printer id q) +-and functor_param ~sep ~custom_printer id q = +- match id with +- | None -> functor_parameters ~sep custom_printer q +- | Some id -> +- Naming_context.with_arg id +- (fun () -> functor_parameters ~sep custom_printer q) +- +- +- +-let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) +-let modtype_declaration id ppf decl = +- !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) +- +-(* For the toplevel: merge with tree_of_signature? *) +- +-let print_items showval env x = +- Names.refresh_weak(); +- Conflicts.reset (); +- let extend_val env (sigitem,outcome) = outcome, showval env sigitem in +- let post_process (env,l) = List.map (extend_val env) l in +- List.concat_map post_process @@ tree_of_signature_rec env x ++ let print_signature ppf tree = ++ Fmt.fprintf ppf "@[%a@]" !Oprint.out_signature tree + +-(* Print a signature body (used by -i when compiling a .ml) *) ++ let signature ppf sg = ++ Fmt.fprintf ppf "%a" print_signature (tree_of_signature sg) + +-let print_signature ppf tree = +- fprintf ppf "@[%a@]" !Oprint.out_signature tree ++end ++open Doc ++let string_of_path p = Fmt.asprintf "%a" path p ++ ++let strings_of_paths namespace p = ++ let trees = List.map (namespaced_tree_of_path namespace) p in ++ List.map (Fmt.asprintf "%a" !Oprint.out_ident) trees ++ ++let wrap_printing_env = wrap_printing_env ++let ident = Fmt.compat ident ++let longident = Fmt.compat longident ++let path = Fmt.compat path ++let type_path = Fmt.compat type_path ++let type_expr = Fmt.compat type_expr ++let type_scheme = Fmt.compat type_scheme ++let shared_type_scheme = Fmt.compat shared_type_scheme ++ ++let type_declaration = Fmt.compat1 type_declaration ++let type_expansion = Fmt.compat1 type_expansion ++let value_description = Fmt.compat1 value_description ++let label = Fmt.compat label ++let constructor = Fmt.compat constructor ++let constructor_arguments = Fmt.compat constructor_arguments ++let extension_constructor = Fmt.compat1 extension_constructor ++let extension_only_constructor = Fmt.compat1 extension_only_constructor ++ ++let modtype = Fmt.compat modtype ++let modtype_declaration = Fmt.compat1 modtype_declaration ++let signature = Fmt.compat signature ++ ++let class_declaration = Fmt.compat1 class_declaration ++let class_type = Fmt.compat class_type ++let cltype_declaration = Fmt.compat1 cltype_declaration + +-let signature ppf sg = +- fprintf ppf "%a" print_signature (tree_of_signature sg) + + (* Print a signature body (used by -i when compiling a .ml) *) + let printed_signature sourcefile ppf sg = + (* we are tracking any collision event for warning 63 *) +- Conflicts.reset (); ++ Ident_conflicts.reset (); + let t = tree_of_signature sg in +- if Warnings.(is_active @@ Erroneous_printed_signature "") +- && Conflicts.exists () +- then begin +- let conflicts = Format.asprintf "%t" Conflicts.print_explanations in +- Location.prerr_warning (Location.in_file sourcefile) +- (Warnings.Erroneous_printed_signature conflicts); +- Warnings.check_fatal () +- end; +- fprintf ppf "%a" print_signature t +- +-(* Trace-specific printing *) +- +-(* A configuration type that controls which trace we print. This could be +- exposed, but we instead expose three separate +- [report_{unification,equality,moregen}_error] functions. This also lets us +- give the unification case an extra optional argument without adding it to the +- equality and moregen cases. *) +-type 'variety trace_format = +- | Unification : Errortrace.unification trace_format +- | Equality : Errortrace.comparison trace_format +- | Moregen : Errortrace.comparison trace_format +- +-let incompatibility_phrase (type variety) : variety trace_format -> string = +- function +- | Unification -> "is not compatible with type" +- | Equality -> "is not equal to type" +- | Moregen -> "is not compatible with type" +- +-(* Print a unification error *) +- +-let same_path t t' = +- eq_type t t' || +- match get_desc t, get_desc t' with +- Tconstr(p,tl,_), Tconstr(p',tl',_) -> +- let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in +- begin match s1, s2 with +- Nth n1, Nth n2 when n1 = n2 -> true +- | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> +- let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in +- List.length tl = List.length tl' && +- List.for_all2 eq_type tl tl' +- | _ -> false +- end +- | _ -> +- false +- +-type 'a diff = Same of 'a | Diff of 'a * 'a +- +-let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = +- reset_loop_marks (); +- mark_loops t; +- if same_path t t' +- then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end +- else begin +- mark_loops t'; +- let t' = if proxy t == proxy t' then unalias t' else t' in +- (* beware order matter due to side effect, +- e.g. when printing object types *) +- let first = tree_of_typexp mode t in +- let second = tree_of_typexp mode t' in +- if first = second then Same first +- else Diff(first,second) +- end +- +-let type_expansion ppf = function +- | Same t -> Style.as_inline_code !Oprint.out_type ppf t +- | Diff(t,t') -> +- fprintf ppf "@[<2>%a@ =@ %a@]" +- (Style.as_inline_code !Oprint.out_type) t +- (Style.as_inline_code !Oprint.out_type) t' +- +-let trees_of_trace mode = +- List.map (Errortrace.map_diff (trees_of_type_expansion mode)) +- +-let trees_of_type_path_expansion (tp,tp') = +- if Path.same tp tp' then Same(tree_of_path (Some Type) tp) else +- Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp') +- +-let type_path_expansion ppf = function +- | Same p -> Style.as_inline_code !Oprint.out_ident ppf p +- | Diff(p,p') -> +- fprintf ppf "@[<2>%a@ =@ %a@]" +- (Style.as_inline_code !Oprint.out_ident) p +- (Style.as_inline_code !Oprint.out_ident) p' +- +-let rec trace fst txt ppf = function +- | {Errortrace.got; expected} :: rem -> +- if not fst then fprintf ppf "@,"; +- fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" +- type_expansion got txt type_expansion expected +- (trace false txt) rem +- | _ -> () +- +-type printing_status = +- | Discard +- | Keep +- | Optional_refinement +- (** An [Optional_refinement] printing status is attributed to trace +- elements that are focusing on a new subpart of a structural type. +- Since the whole type should have been printed earlier in the trace, +- we only print those elements if they are the last printed element +- of a trace, and there is no explicit explanation for the +- type error. +- *) +- +-let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; +- expected = {ty = t2; expanded = t2'} } = +- if is_constr_row ~allow_ident:true t1' +- || is_constr_row ~allow_ident:true t2' +- then Discard +- else if same_path t1 t1' && same_path t2 t2' then Optional_refinement +- else Keep +- +-let printing_status = function +- | Errortrace.Diff d -> diff_printing_status d +- | Errortrace.Escape {kind = Constraint} -> Keep +- | _ -> Keep +- +-(** Flatten the trace and remove elements that are always discarded +- during printing *) +- +-(* Takes [printing_status] to change behavior for [Subtype] *) +-let prepare_any_trace printing_status tr = +- let clean_trace x l = match printing_status x with +- | Keep -> x :: l +- | Optional_refinement when l = [] -> [x] +- | Optional_refinement | Discard -> l +- in +- match tr with +- | [] -> [] +- | elt :: rem -> elt :: List.fold_right clean_trace rem [] +- +-let prepare_trace f tr = +- prepare_any_trace printing_status (Errortrace.map f tr) +- +-(** Keep elements that are [Diff _ ] and take the decision +- for the last element, require a prepared trace *) +-let rec filter_trace keep_last = function +- | [] -> [] +- | [Errortrace.Diff d as elt] +- when printing_status elt = Optional_refinement -> +- if keep_last then [d] else [] +- | Errortrace.Diff d :: rem -> d :: filter_trace keep_last rem +- | _ :: rem -> filter_trace keep_last rem +- +-let type_path_list = +- Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0) +- type_path_expansion +- +-(* Hide variant name and var, to force printing the expanded type *) +-let hide_variant_name t = +- match get_desc t with +- | Tvariant row -> +- let Row {fields; more; name; fixed; closed} = row_repr row in +- if name = None then t else +- newty2 ~level:(get_level t) +- (Tvariant +- (create_row ~fields ~fixed ~closed ~name:None +- ~more:(newvar2 (get_level more)))) +- | _ -> t +- +-let prepare_expansion Errortrace.{ty; expanded} = +- let expanded = hide_variant_name expanded in +- reserve_names ty; +- if not (same_path ty expanded) then reserve_names expanded; +- Errortrace.{ty; expanded} +- +-let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = +- match get_desc expanded with +- Tvariant _ | Tobject _ when compact -> +- reserve_names ty; Errortrace.{ty; expanded = ty} +- | _ -> prepare_expansion ty_exp +- +-let print_path p = +- Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) +- +-let print_tag ppf s = Style.inline_code ppf ("`" ^ s) +- +-let print_tags = +- let comma ppf () = Format.fprintf ppf ",@ " in +- Format.pp_print_list ~pp_sep:comma print_tag +- +-let is_unit env ty = +- match get_desc (Ctype.expand_head env ty) with +- | Tconstr (p, _, _) -> Path.same p Predef.path_unit +- | _ -> false +- +-let unifiable env ty1 ty2 = +- let snap = Btype.snapshot () in +- let res = +- try Ctype.unify env ty1 ty2; true +- with Unify _ -> false +- in +- Btype.backtrack snap; +- res +- +-let explanation_diff env t3 t4 : (Format.formatter -> unit) option = +- match get_desc t3, get_desc t4 with +- | Tarrow (_, ty1, ty2, _), _ +- when is_unit env ty1 && unifiable env ty2 t4 -> +- Some (fun ppf -> +- fprintf ppf +- "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" +- Style.inline_code "()" +- ) +- | _, Tarrow (_, ty1, ty2, _) +- when is_unit env ty1 && unifiable env t3 ty2 -> +- Some (fun ppf -> +- fprintf ppf +- "@,@[@{Hint@}: Did you forget to wrap the expression using \ +- %a?@]" +- Style.inline_code "fun () ->" +- ) +- | _ -> +- None +- +-let explain_fixed_row_case ppf = function +- | Errortrace.Cannot_be_closed -> +- fprintf ppf "it cannot be closed" +- | Errortrace.Cannot_add_tags tags -> +- fprintf ppf "it may not allow the tag(s) %a" +- print_tags tags +- +-let explain_fixed_row pos expl = match expl with +- | Fixed_private -> +- dprintf "The %a variant type is private" Errortrace.print_pos pos +- | Univar x -> +- reserve_names x; +- dprintf "The %a variant type is bound to the universal type variable %a" +- Errortrace.print_pos pos +- (Style.as_inline_code type_expr_with_reserved_names) x +- | Reified p -> +- dprintf "The %a variant type is bound to %a" +- Errortrace.print_pos pos +- (Style.as_inline_code +- (fun ppf p -> +- Internal_names.add p; +- print_path p ppf)) +- p +- | Rigid -> ignore +- +-let explain_variant (type variety) : variety Errortrace.variant -> _ = function +- (* Common *) +- | Errortrace.Incompatible_types_for s -> +- Some(dprintf "@,Types for tag %a are incompatible" +- print_tag s +- ) +- (* Unification *) +- | Errortrace.No_intersection -> +- Some(dprintf "@,These two variant types have no intersection") +- | Errortrace.No_tags(pos,fields) -> Some( +- dprintf +- "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" +- Errortrace.print_pos pos +- print_tags (List.map fst fields) +- ) +- | Errortrace.Fixed_row (pos, +- k, +- (Univar _ | Reified _ | Fixed_private as e)) -> +- Some ( +- dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e) +- explain_fixed_row_case k +- ) +- | Errortrace.Fixed_row (_,_, Rigid) -> +- (* this case never happens *) +- None +- (* Equality & Moregen *) +- | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( +- dprintf +- "@,@[The tag %a is guaranteed to be present in the %a variant type,\ +- @ but not in the %a@]" +- print_tag s +- Errortrace.print_pos (Errortrace.swap_position pos) +- Errortrace.print_pos pos +- ) +- | Errortrace.Openness pos -> +- Some(dprintf "@,The %a variant type is open and the %a is not" +- Errortrace.print_pos pos +- Errortrace.print_pos (Errortrace.swap_position pos)) +- +-let explain_escape pre = function +- | Errortrace.Univ u -> +- reserve_names u; +- Some( +- dprintf "%t@,The universal variable %a would escape its scope" +- pre +- (Style.as_inline_code type_expr_with_reserved_names) u +- ) +- | Errortrace.Constructor p -> Some( +- dprintf +- "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]" +- pre (Style.as_inline_code path) p +- ) +- | Errortrace.Module_type p -> Some( +- dprintf +- "%t@,@[The module type@;<1 2>%a@ would escape its scope@]" +- pre (Style.as_inline_code path) p +- ) +- | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> +- reserve_names t; +- Some( +- dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" +- pre +- (Style.as_inline_code type_expr_with_reserved_names) t +- "it would escape the scope of its equation" +- ) +- | Errortrace.Self -> +- Some (dprintf "%t@,Self type cannot escape its class" pre) +- | Errortrace.Constraint -> +- None +- +-let explain_object (type variety) : variety Errortrace.obj -> _ = function +- | Errortrace.Missing_field (pos,f) -> Some( +- dprintf "@,@[The %a object type has no method %a@]" +- Errortrace.print_pos pos Style.inline_code f +- ) +- | Errortrace.Abstract_row pos -> Some( +- dprintf +- "@,@[The %a object type has an abstract row, it cannot be closed@]" +- Errortrace.print_pos pos +- ) +- | Errortrace.Self_cannot_be_closed -> +- Some (dprintf "@,Self type cannot be unified with a closed object type") +- +-let explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = +- reserve_names diff.got; +- reserve_names diff.expected; +- dprintf "@,@[The method %a has type@ %a,@ \ +- but the expected method type was@ %a@]" +- Style.inline_code name +- (Style.as_inline_code type_expr_with_reserved_names) diff.got +- (Style.as_inline_code type_expr_with_reserved_names) diff.expected +- +-let explanation (type variety) intro prev env +- : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function +- | Errortrace.Diff {got; expected} -> +- explanation_diff env got.expanded expected.expanded +- | Errortrace.Escape {kind; context} -> +- let pre = +- match context, kind, prev with +- | Some ctx, _, _ -> +- reserve_names ctx; +- dprintf "@[%t@;<1 2>%a@]" intro +- (Style.as_inline_code type_expr_with_reserved_names) ctx +- | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> +- explain_incompatible_fields name diff +- | _ -> ignore +- in +- explain_escape pre kind +- | Errortrace.Incompatible_fields { name; diff} -> +- Some(explain_incompatible_fields name diff) +- | Errortrace.Variant v -> +- explain_variant v +- | Errortrace.Obj o -> +- explain_object o +- | Errortrace.Rec_occur(x,y) -> +- reserve_names x; +- reserve_names y; +- begin match get_desc x with +- | Tvar _ | Tunivar _ -> +- Some(fun ppf -> +- reset_loop_marks (); +- mark_loops x; +- mark_loops y; +- dprintf "@,@[The type variable %a occurs inside@ %a@]" +- (Style.as_inline_code prepared_type_expr) x +- (Style.as_inline_code prepared_type_expr) y +- ppf) +- | _ -> +- (* We had a delayed unification of the type variable with +- a non-variable after the occur check. *) +- Some ignore +- (* There is no need to search further for an explanation, but +- we don't want to print a message of the form: +- {[ The type int occurs inside int list -> 'a |} +- *) +- end +- +-let mismatch intro env trace = +- Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) +- +-let explain mis ppf = +- match mis with +- | None -> () +- | Some explain -> explain ppf +- +-let warn_on_missing_def env ppf t = +- match get_desc t with +- | Tconstr (p,_,_) -> +- begin match Env.find_type p env with +- | exception Not_found -> +- fprintf ppf +- "@,@[Type %a is abstract because@ no corresponding\ +- @ cmi file@ was found@ in path.@]" (Style.as_inline_code path) p +- | { type_manifest = Some _; _ } -> () +- | { type_manifest = None; _ } as decl -> +- match type_origin decl with +- | Rec_check_regularity -> +- fprintf ppf +- "@,@[Type %a was considered abstract@ when checking\ +- @ constraints@ in this@ recursive type definition.@]" +- (Style.as_inline_code path) p +- | Definition | Existential _ -> () +- end +- | _ -> () +- +-let prepare_expansion_head empty_tr = function +- | Errortrace.Diff d -> +- Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) +- | _ -> None +- +-let head_error_printer mode txt_got txt_but = function +- | None -> ignore +- | Some d -> +- let d = Errortrace.map_diff (trees_of_type_expansion mode) d in +- dprintf "%t@;<1 2>%a@ %t@;<1 2>%a" +- txt_got type_expansion d.Errortrace.got +- txt_but type_expansion d.Errortrace.expected +- +-let warn_on_missing_defs env ppf = function +- | None -> () +- | Some Errortrace.{got = {ty=te1; expanded=_}; +- expected = {ty=te2; expanded=_} } -> +- warn_on_missing_def env ppf te1; +- warn_on_missing_def env ppf te2 +- +-(* [subst] comes out of equality, and is [[]] otherwise *) +-let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = +- reset (); +- (* We want to substitute in the opposite order from [Eqtype] *) +- Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); +- let tr = +- prepare_trace +- (fun ty_exp -> +- Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) +- tr +- in +- let mis = mismatch txt1 env tr in +- match tr with +- | [] -> assert false +- | elt :: tr -> +- try +- print_labels := not !Clflags.classic; +- let tr = filter_trace (mis = None) tr in +- let head = prepare_expansion_head (tr=[]) elt in +- let tr = List.map (Errortrace.map_diff prepare_expansion) tr in +- let head_error = head_error_printer mode txt1 txt2 head in +- let tr = trees_of_trace mode tr in +- fprintf ppf +- "@[\ +- @[%t%t@]%a%t\ +- @]" +- head_error +- ty_expect_explanation +- (trace false (incompatibility_phrase trace_format)) tr +- (explain mis); +- if env <> Env.empty +- then warn_on_missing_defs env ppf head; +- Internal_names.print_explanations env ppf; +- Conflicts.print_explanations ppf; +- print_labels := true +- with exn -> +- print_labels := true; +- raise exn +- +-let report_error trace_format ppf mode env tr +- ?(subst = []) +- ?(type_expected_explanation = fun _ -> ()) +- txt1 txt2 = +- wrap_printing_env ~error:true env (fun () -> +- error trace_format mode subst env tr txt1 ppf txt2 +- type_expected_explanation) +- +-let report_unification_error +- ppf env ({trace} : Errortrace.unification_error) = +- report_error Unification ppf Type env +- ?subst:None trace +- +-let report_equality_error +- ppf mode env ({subst; trace} : Errortrace.equality_error) = +- report_error Equality ppf mode env +- ~subst ?type_expected_explanation:None trace +- +-let report_moregen_error +- ppf mode env ({trace} : Errortrace.moregen_error) = +- report_error Moregen ppf mode env +- ?subst:None ?type_expected_explanation:None trace +- +-let report_comparison_error ppf mode env = function +- | Errortrace.Equality_error error -> report_equality_error ppf mode env error +- | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error +- +-module Subtype = struct +- (* There's a frustrating amount of code duplication between this module and +- the outside code, particularly in [prepare_trace] and [filter_trace]. +- Unfortunately, [Subtype] is *just* similar enough to have code duplication, +- while being *just* different enough (it's only [Diff]) for the abstraction +- to be nonobvious. Someday, perhaps... *) +- +- let printing_status = function +- | Errortrace.Subtype.Diff d -> diff_printing_status d +- +- let prepare_unification_trace = prepare_trace +- +- let prepare_trace f tr = +- prepare_any_trace printing_status (Errortrace.Subtype.map f tr) +- +- let trace filter_trace get_diff fst keep_last txt ppf tr = +- print_labels := not !Clflags.classic; +- try match tr with +- | elt :: tr' -> +- let diffed_elt = get_diff elt in +- let tr = +- trees_of_trace Type +- @@ List.map (Errortrace.map_diff prepare_expansion) +- @@ filter_trace keep_last tr' in +- let tr = +- match fst, diffed_elt with +- | true, Some elt -> elt :: tr +- | _, _ -> tr +- in +- trace fst txt ppf tr; +- print_labels := true +- | _ -> () +- with exn -> +- print_labels := true; +- raise exn +- +- let rec filter_subtype_trace keep_last = function +- | [] -> [] +- | [Errortrace.Subtype.Diff d as elt] +- when printing_status elt = Optional_refinement -> +- if keep_last then [d] else [] +- | Errortrace.Subtype.Diff d :: rem -> +- d :: filter_subtype_trace keep_last rem +- +- let unification_get_diff = function +- | Errortrace.Diff diff -> +- Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) +- | _ -> None +- +- let subtype_get_diff = function +- | Errortrace.Subtype.Diff diff -> +- Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) +- +- let report_error +- ppf +- env +- (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) +- txt1 = +- wrap_printing_env ~error:true env (fun () -> +- reset (); +- let tr_sub = prepare_trace prepare_expansion tr_sub in +- let tr_unif = prepare_unification_trace prepare_expansion tr_unif in +- let keep_first = match tr_unif with +- | [Obj _ | Variant _ | Escape _ ] | [] -> true +- | _ -> false in +- fprintf ppf "@[%a" +- (trace filter_subtype_trace subtype_get_diff true keep_first txt1) +- tr_sub; +- if tr_unif = [] then fprintf ppf "@]" else +- let mis = mismatch (dprintf "Within this type") env tr_unif in +- fprintf ppf "%a%t%t@]" +- (trace filter_trace unification_get_diff false +- (mis = None) "is not compatible with type") tr_unif +- (explain mis) +- Conflicts.print_explanations +- ) +-end +- +-let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = +- wrap_printing_env ~error:true env (fun () -> +- reset (); +- let tp0 = trees_of_type_path_expansion tp0 in +- match tpl with +- [] -> assert false +- | [tp] -> +- fprintf ppf +- "@[%t@;<1 2>%a@ \ +- %t@;<1 2>%a\ +- @]" +- txt1 type_path_expansion (trees_of_type_path_expansion tp) +- txt3 type_path_expansion tp0 +- | _ -> +- fprintf ppf +- "@[%t@;<1 2>@[%a@]\ +- @ %t@;<1 2>%a\ +- @]" +- txt2 type_path_list (List.map trees_of_type_path_expansion tpl) +- txt3 type_path_expansion tp0) +- +-(* Adapt functions to exposed interface *) +-let tree_of_path = tree_of_path None +-let tree_of_modtype = tree_of_modtype ~ellipsis:false +-let type_expansion mode ppf ty_exp = +- type_expansion ppf (trees_of_type_expansion mode ty_exp) +-let tree_of_type_declaration ident td rs = +- with_hidden_items [{hide=true; ident}] +- (fun () -> tree_of_type_declaration ident td rs) ++ if Warnings.(is_active @@ Erroneous_printed_signature "") then ++ begin match Ident_conflicts.err_msg () with ++ | None -> () ++ | Some msg -> ++ let conflicts = Fmt.asprintf "%a" Fmt.pp_doc msg in ++ Location.prerr_warning (Location.in_file sourcefile) ++ (Warnings.Erroneous_printed_signature conflicts); ++ Warnings.check_fatal () ++ end; ++ Fmt.compat print_signature ppf t diff --git a/upstream/patches_503/typing/printtyp.mli.patch b/upstream/patches_503/typing/printtyp.mli.patch new file mode 100644 index 000000000..8eb028700 --- /dev/null +++ b/upstream/patches_503/typing/printtyp.mli.patch @@ -0,0 +1,330 @@ +--- ocaml_502/typing/printtyp.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/printtyp.mli 2024-09-17 01:15:58.292566923 +0200 +@@ -2,9 +2,9 @@ + (* *) + (* OCaml *) + (* *) +-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) ++(* Florian Angeletti, projet Cambium, INRIA Paris *) + (* *) +-(* Copyright 1996 Institut National de Recherche en Informatique et *) ++(* Copyright 2024 Institut National de Recherche en Informatique et *) + (* en Automatique. *) + (* *) + (* All rights reserved. This file is distributed under the terms of *) +@@ -13,237 +13,91 @@ + (* *) + (**************************************************************************) + +-(* Printing functions *) ++(** Printing functions *) ++ + +-open Format + open Types +-open Outcometree + +-val longident: formatter -> Longident.t -> unit +-val ident: formatter -> Ident.t -> unit +-val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string +-val tree_of_path: Path.t -> out_ident +-val path: formatter -> Path.t -> unit ++type namespace := Shape.Sig_component_kind.t ++ ++val namespaced_ident: namespace -> Ident.t -> string + val string_of_path: Path.t -> string ++val strings_of_paths: namespace -> Path.t list -> string list ++(** Print a list of paths, using the same naming context to ++ avoid name collisions *) + +-val type_path: formatter -> Path.t -> unit +-(** Print a type path taking account of [-short-paths]. +- Calls should be within [wrap_printing_env]. *) +- +-module Out_name: sig +- val create: string -> out_name +- val print: out_name -> string +-end ++(** [printed_signature sourcefile ppf sg] print the signature [sg] of ++ [sourcefile] with potential warnings for name collisions *) ++val printed_signature: string -> Format.formatter -> signature -> unit + +-type namespace := Shape.Sig_component_kind.t option ++module type Printers := sig + +-val strings_of_paths: namespace -> Path.t list -> string list +- (** Print a list of paths, using the same naming context to +- avoid name collisions *) ++ val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a ++ (** Call the function using the environment for type path shortening This ++ affects all the printing functions below Also, if [~error:true], then ++ disable the loading of cmis *) + +-val raw_type_expr: formatter -> type_expr -> unit +-val string_of_label: Asttypes.arg_label -> string ++ type 'a printer ++ val longident: Longident.t printer ++ val ident: Ident.t printer ++ val path: Path.t printer ++ val type_path: Path.t printer ++ (** Print a type path taking account of [-short-paths]. ++ Calls should be within [wrap_printing_env]. *) + +-val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a +- (* Call the function using the environment for type path shortening *) +- (* This affects all the printing functions below *) +- (* Also, if [~error:true], then disable the loading of cmis *) +- +-module Naming_context: sig +- val enable: bool -> unit +- (** When contextual names are enabled, the mapping between identifiers +- and names is ensured to be one-to-one. *) +-end +- +-(** The [Conflicts] module keeps track of conflicts arising when attributing +- names to identifiers and provides functions that can print explanations +- for these conflict in error messages *) +-module Conflicts: sig +- val exists: unit -> bool +- (** [exists()] returns true if the current naming context renamed +- an identifier to avoid a name collision *) +- +- type explanation = +- { kind: Shape.Sig_component_kind.t; +- name:string; +- root_name:string; +- location:Location.t +- } +- +- val list_explanations: unit -> explanation list +-(** [list_explanations()] return the list of conflict explanations +- collected up to this point, and reset the list of collected +- explanations *) +- +- val print_located_explanations: +- Format.formatter -> explanation list -> unit +- +- val print_explanations: Format.formatter -> unit +- (** Print all conflict explanations collected up to this point *) +- +- val reset: unit -> unit +-end +- +-val reset: unit -> unit +- +-(** Print out a type. This will pick names for type variables, and will not +- reuse names for common type variables shared across multiple type +- expressions. (It will also reset the printing state, which matters for +- other type formatters such as [prepared_type_expr].) If you want multiple +- types to use common names for type variables, see [prepare_for_printing] and +- [prepared_type_expr]. *) +-val type_expr: formatter -> type_expr -> unit +- +-(** [prepare_for_printing] resets the global printing environment, a la [reset], +- and prepares the types for printing by reserving names and marking loops. +- Any type variables that are shared between multiple types in the input list +- will be given the same name when printed with [prepared_type_expr]. *) +-val prepare_for_printing: type_expr list -> unit +- +-(** [add_type_to_preparation ty] extend a previous type expression preparation +- to the type expression [ty] +-*) +-val add_type_to_preparation: type_expr -> unit +- +-val prepared_type_expr: formatter -> type_expr -> unit +-(** The function [prepared_type_expr] is a less-safe but more-flexible version +- of [type_expr] that should only be called on [type_expr]s that have been +- passed to [prepare_for_printing]. Unlike [type_expr], this function does no +- extra work before printing a type; in particular, this means that any loops +- in the type expression may cause a stack overflow (see #8860) since this +- function does not mark any loops. The benefit of this is that if multiple +- type expressions are prepared simultaneously and then printed with +- [prepared_type_expr], they will use the same names for the same type +- variables. *) +- +-val constructor_arguments: formatter -> constructor_arguments -> unit +-val tree_of_type_scheme: type_expr -> out_type +-val type_scheme: formatter -> type_expr -> unit +-val prepared_type_scheme: formatter -> type_expr -> unit +-val shared_type_scheme: formatter -> type_expr -> unit +-(** [shared_type_scheme] is very similar to [type_scheme], but does not reset +- the printing context first. This is intended to be used in cases where the +- printing should have a particularly wide context, such as documentation +- generators; most use cases, such as error messages, have narrower contexts +- for which [type_scheme] is better suited. *) +- +-val tree_of_value_description: Ident.t -> value_description -> out_sig_item +-val value_description: Ident.t -> formatter -> value_description -> unit +-val label : formatter -> label_declaration -> unit +-val add_constructor_to_preparation : constructor_declaration -> unit +-val prepared_constructor : formatter -> constructor_declaration -> unit +-val constructor : formatter -> constructor_declaration -> unit +-val tree_of_type_declaration: +- Ident.t -> type_declaration -> rec_status -> out_sig_item +-val add_type_declaration_to_preparation : +- Ident.t -> type_declaration -> unit +-val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit +-val type_declaration: Ident.t -> formatter -> type_declaration -> unit +-val tree_of_extension_constructor: +- Ident.t -> extension_constructor -> ext_status -> out_sig_item +-val add_extension_constructor_to_preparation : +- extension_constructor -> unit +-val prepared_extension_constructor: +- Ident.t -> formatter -> extension_constructor -> unit +-val extension_constructor: +- Ident.t -> formatter -> extension_constructor -> unit +-(* Prints extension constructor with the type signature: +- type ('a, 'b) bar += A of float +-*) +- +-val extension_only_constructor: +- Ident.t -> formatter -> extension_constructor -> unit +-(* Prints only extension constructor without type signature: +- A of float +-*) +- +-val tree_of_module: +- Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item +-val modtype: formatter -> module_type -> unit +-val signature: formatter -> signature -> unit +-val tree_of_modtype: module_type -> out_module_type +-val tree_of_modtype_declaration: +- Ident.t -> modtype_declaration -> out_sig_item +- +-(** Print a list of functor parameters while adjusting the printing environment +- for each functor argument. +- +- Currently, we are disabling disambiguation for functor argument name to +- avoid the need to track the moving association between identifiers and +- syntactic names in situation like: +- +- got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T) +- expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T) +-*) +-val functor_parameters: +- sep:(Format.formatter -> unit -> unit) -> +- ('b -> Format.formatter -> unit) -> +- (Ident.t option * 'b) list -> Format.formatter -> unit +- +-type type_or_scheme = Type | Type_scheme +- +-val tree_of_signature: Types.signature -> out_sig_item list +-val tree_of_typexp: type_or_scheme -> type_expr -> out_type +-val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit +-val class_type: formatter -> class_type -> unit +-val tree_of_class_declaration: +- Ident.t -> class_declaration -> rec_status -> out_sig_item +-val class_declaration: Ident.t -> formatter -> class_declaration -> unit +-val tree_of_cltype_declaration: +- Ident.t -> class_type_declaration -> rec_status -> out_sig_item +-val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit +-val type_expansion : +- type_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit +-val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type +-val report_ambiguous_type_error: +- formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> +- (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit +- +-val report_unification_error : +- formatter -> +- Env.t -> Errortrace.unification_error -> +- ?type_expected_explanation:(formatter -> unit) -> +- (formatter -> unit) -> (formatter -> unit) -> +- unit +- +-val report_equality_error : +- formatter -> +- type_or_scheme -> +- Env.t -> Errortrace.equality_error -> +- (formatter -> unit) -> (formatter -> unit) -> +- unit +- +-val report_moregen_error : +- formatter -> +- type_or_scheme -> +- Env.t -> Errortrace.moregen_error -> +- (formatter -> unit) -> (formatter -> unit) -> +- unit +- +-val report_comparison_error : +- formatter -> +- type_or_scheme -> +- Env.t -> Errortrace.comparison_error -> +- (formatter -> unit) -> (formatter -> unit) -> +- unit +- +-module Subtype : sig +- val report_error : +- formatter -> +- Env.t -> +- Errortrace.Subtype.error -> +- string -> +- unit +-end +- +-(* for toploop *) +-val print_items: (Env.t -> signature_item -> 'a option) -> +- Env.t -> signature_item list -> (out_sig_item * 'a option) list +- +-(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias +- for Foo__bar. This pattern is used by the stdlib. *) +-val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t + +-(** [printed_signature sourcefile ppf sg] print the signature [sg] of +- [sourcefile] with potential warnings for name collisions *) +-val printed_signature: string -> formatter -> signature -> unit ++ (** Print out a type. This will pick names for type variables, and will not ++ reuse names for common type variables shared across multiple type ++ expressions. (It will also reset the printing state, which matters for ++ other type formatters such as [prepared_type_expr].) If you want ++ multiple types to use common names for type variables, see ++ {!Out_type.prepare_for_printing} and {!Out_type.prepared_type_expr}. *) ++ val type_expr: type_expr printer ++ ++ val type_scheme: type_expr printer ++ ++ val shared_type_scheme: type_expr printer ++ (** [shared_type_scheme] is very similar to [type_scheme], but does not ++ reset the printing context first. This is intended to be used in cases ++ where the printing should have a particularly wide context, such as ++ documentation generators; most use cases, such as error messages, have ++ narrower contexts for which [type_scheme] is better suited. *) ++ ++ val type_expansion: ++ Out_type.type_or_scheme -> Errortrace.expanded_type printer ++ ++ val label : label_declaration printer ++ ++ val constructor : constructor_declaration printer ++ val constructor_arguments: constructor_arguments printer ++ ++ val extension_constructor: ++ Ident.t -> extension_constructor printer ++ (** Prints extension constructor with the type signature: ++ type ('a, 'b) bar += A of float ++ *) ++ ++ val extension_only_constructor: ++ Ident.t -> extension_constructor printer ++ (** Prints only extension constructor without type signature: ++ A of float ++ *) ++ ++ ++ val value_description: Ident.t -> value_description printer ++ val type_declaration: Ident.t -> type_declaration printer ++ val modtype_declaration: Ident.t -> modtype_declaration printer ++ val class_declaration: Ident.t -> class_declaration printer ++ val cltype_declaration: Ident.t -> class_type_declaration printer ++ ++ ++ val modtype: module_type printer ++ val signature: signature printer ++ val class_type: class_type printer ++ ++ end ++ ++module Doc : Printers with type 'a printer := 'a Format_doc.printer ++ ++(** For compatibility with Format printers *) ++include Printers with type 'a printer := 'a Format_doc.format_printer diff --git a/upstream/patches_503/typing/printtyped.ml.patch b/upstream/patches_503/typing/printtyped.ml.patch new file mode 100644 index 000000000..cc04b0cca --- /dev/null +++ b/upstream/patches_503/typing/printtyped.ml.patch @@ -0,0 +1,25 @@ +--- ocaml_502/typing/printtyped.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/printtyped.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -351,15 +351,16 @@ + line i ppf "Texp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; +- | Texp_match (e, l, partial) -> +- line i ppf "Texp_match%a\n" +- fmt_partiality partial; ++ | Texp_match (e, l1, l2, partial) -> ++ line i ppf "Texp_match%a\n" fmt_partiality partial; + expression i ppf e; +- list i case ppf l; +- | Texp_try (e, l) -> ++ list i case ppf l1; ++ list i case ppf l2; ++ | Texp_try (e, l1, l2) -> + line i ppf "Texp_try\n"; + expression i ppf e; +- list i case ppf l; ++ list i case ppf l1; ++ list i case ppf l2; + | Texp_tuple (l) -> + line i ppf "Texp_tuple\n"; + list i expression ppf l; diff --git a/upstream/patches_503/typing/rawprinttyp.ml.patch b/upstream/patches_503/typing/rawprinttyp.ml.patch new file mode 100644 index 000000000..573f89ead --- /dev/null +++ b/upstream/patches_503/typing/rawprinttyp.ml.patch @@ -0,0 +1,150 @@ +--- ocaml_502/typing/rawprinttyp.ml 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/typing/rawprinttyp.ml 2024-09-17 01:15:58.292566923 +0200 +@@ -0,0 +1,147 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Jacques Garrigue, Graduate School of Mathematics, Nagoya University *) ++(* *) ++(* Copyright 2003 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++ ++(* Print a raw type expression, with sharing *) ++ ++open Format ++open Types ++open Asttypes ++let longident = Pprintast.longident ++ ++let raw_list pr ppf = function ++ [] -> fprintf ppf "[]" ++ | a :: l -> ++ fprintf ppf "@[<1>[%a%t]@]" pr a ++ (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) ++ ++let kind_vars = ref [] ++let kind_count = ref 0 ++ ++let string_of_field_kind v = ++ match field_kind_repr v with ++ | Fpublic -> "Fpublic" ++ | Fabsent -> "Fabsent" ++ | Fprivate -> "Fprivate" ++ ++let rec safe_repr v t = ++ match Transient_expr.coerce t with ++ {desc = Tlink t} when not (List.memq t v) -> ++ safe_repr (t::v) t ++ | t' -> t' ++ ++let rec list_of_memo = function ++ Mnil -> [] ++ | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem ++ | Mlink rem -> list_of_memo !rem ++ ++let print_name ppf = function ++ None -> fprintf ppf "None" ++ | Some name -> fprintf ppf "\"%s\"" name ++ ++let path = Format_doc.compat Path.print ++ ++let visited = ref [] ++let rec raw_type ppf ty = ++ let ty = safe_repr [] ty in ++ if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin ++ visited := ty :: !visited; ++ fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;marks=%x;desc=@,%a}@]" ++ ty.id ty.level ++ (Transient_expr.get_scope ty) (Transient_expr.get_marks ty) ++ raw_type_desc ty.desc ++ end ++and raw_type_list tl = raw_list raw_type tl ++and raw_lid_type_list tl = ++ raw_list (fun ppf (lid, typ) -> ++ fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) ++ tl ++and raw_type_desc ppf = function ++ Tvar name -> fprintf ppf "Tvar %a" print_name name ++ | Tarrow(l,t1,t2,c) -> ++ fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" ++ (string_of_label l) raw_type t1 raw_type t2 ++ (if is_commu_ok c then "Cok" else "Cunknown") ++ | Ttuple tl -> ++ fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl ++ | Tconstr (p, tl, abbrev) -> ++ fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p ++ raw_type_list tl ++ (raw_list path) (list_of_memo !abbrev) ++ | Tobject (t, nm) -> ++ fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t ++ (fun ppf -> ++ match !nm with None -> fprintf ppf " None" ++ | Some(p,tl) -> ++ fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) ++ | Tfield (f, k, t1, t2) -> ++ fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f ++ (string_of_field_kind k) ++ raw_type t1 raw_type t2 ++ | Tnil -> fprintf ppf "Tnil" ++ | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t ++ | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t ++ | Tsubst (t, Some t') -> ++ fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' ++ | Tunivar name -> fprintf ppf "Tunivar %a" print_name name ++ | Tpoly (t, tl) -> ++ fprintf ppf "@[Tpoly(@,%a,@,%a)@]" ++ raw_type t ++ raw_type_list tl ++ | Tvariant row -> ++ let Row {fields; more; name; fixed; closed} = row_repr row in ++ fprintf ppf ++ "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" ++ "row_fields=" ++ (raw_list (fun ppf (l, f) -> ++ fprintf ppf "@[%s,@ %a@]" l raw_field f)) ++ fields ++ "row_more=" raw_type more ++ "row_closed=" closed ++ "row_fixed=" raw_row_fixed fixed ++ "row_name=" ++ (fun ppf -> ++ match name with None -> fprintf ppf "None" ++ | Some(p,tl) -> ++ fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) ++ | Tpackage (p, fl) -> ++ fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl ++and raw_row_fixed ppf = function ++| None -> fprintf ppf "None" ++| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" ++| Some Types.Rigid -> fprintf ppf "Some Rigid" ++| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t ++| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p ++ ++and raw_field ppf rf = ++ match_row_field ++ ~absent:(fun _ -> fprintf ppf "RFabsent") ++ ~present:(function ++ | None -> ++ fprintf ppf "RFpresent None" ++ | Some t -> ++ fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) ++ ~either:(fun c tl m (_,e) -> ++ fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c ++ raw_type_list tl m ++ (fun ppf -> ++ match e with None -> fprintf ppf " RFnone" ++ | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) ++ rf ++ ++let type_expr ppf t = ++ visited := []; kind_vars := []; kind_count := 0; ++ raw_type ppf t; ++ visited := []; kind_vars := [] diff --git a/upstream/patches_503/typing/rawprinttyp.mli.patch b/upstream/patches_503/typing/rawprinttyp.mli.patch new file mode 100644 index 000000000..1e01b04e6 --- /dev/null +++ b/upstream/patches_503/typing/rawprinttyp.mli.patch @@ -0,0 +1,23 @@ +--- ocaml_502/typing/rawprinttyp.mli 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/typing/rawprinttyp.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -0,0 +1,20 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Jacques Garrigue, Graduate School of Mathematics, Nagoya University *) ++(* *) ++(* Copyright 2003 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(** This module provides function(s) for printing the internal representation of ++ type expressions. It is targetted at internal use when debbuging the ++ compiler itself. *) ++ ++val type_expr: Format.formatter -> Types.type_expr -> unit diff --git a/upstream/patches_503/typing/shape.ml.patch b/upstream/patches_503/typing/shape.ml.patch new file mode 100644 index 000000000..d66b8feea --- /dev/null +++ b/upstream/patches_503/typing/shape.ml.patch @@ -0,0 +1,45 @@ +--- ocaml_502/typing/shape.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/shape.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -16,7 +16,7 @@ + module Uid = struct + type t = + | Compilation_unit of string +- | Item of { comp_unit: string; id: int } ++ | Item of { comp_unit: string; id: int; from: Unit_info.intf_or_impl } + | Internal + | Predef of string + +@@ -27,11 +27,16 @@ + let compare (x : t) y = compare x y + let hash (x : t) = Hashtbl.hash x + ++ let pp_intf_or_impl fmt = function ++ | Unit_info.Intf -> Format.pp_print_string fmt "[intf]" ++ | Unit_info.Impl -> () ++ + let print fmt = function + | Internal -> Format.pp_print_string fmt "" + | Predef name -> Format.fprintf fmt "" name + | Compilation_unit s -> Format.pp_print_string fmt s +- | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id ++ | Item { comp_unit; id; from } -> ++ Format.fprintf fmt "%a%s.%d" pp_intf_or_impl from comp_unit id + + let output oc t = + let fmt = Format.formatter_of_out_channel oc in +@@ -43,8 +48,14 @@ + let reinit () = id := (-1) + + let mk ~current_unit = ++ let comp_unit, from = ++ let open Unit_info in ++ match current_unit with ++ | None -> "", Impl ++ | Some ui -> modname ui, kind ui ++ in + incr id; +- Item { comp_unit = current_unit; id = !id } ++ Item { comp_unit; id = !id; from } + + let of_compilation_unit_id id = + if not (Ident.persistent id) then diff --git a/upstream/patches_503/typing/shape.mli.patch b/upstream/patches_503/typing/shape.mli.patch new file mode 100644 index 000000000..c4f43cd2a --- /dev/null +++ b/upstream/patches_503/typing/shape.mli.patch @@ -0,0 +1,30 @@ +--- ocaml_502/typing/shape.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/shape.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -43,9 +43,9 @@ + [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit. + + See: +- - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling } ++ - {{:https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling} + the design document} +- - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf } ++ - {{:https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf} + a talk about the reduction strategy + *) + +@@ -57,13 +57,13 @@ + module Uid : sig + type t = private + | Compilation_unit of string +- | Item of { comp_unit: string; id: int } ++ | Item of { comp_unit: string; id: int; from: Unit_info.intf_or_impl } + | Internal + | Predef of string + + val reinit : unit -> unit + +- val mk : current_unit:string -> t ++ val mk : current_unit:(Unit_info.t option) -> t + val of_compilation_unit_id : Ident.t -> t + val of_predef_id : Ident.t -> t + val internal_not_actually_unique : t diff --git a/upstream/patches_503/typing/stypes.ml.patch b/upstream/patches_503/typing/stypes.ml.patch new file mode 100644 index 000000000..ecce50d7b --- /dev/null +++ b/upstream/patches_503/typing/stypes.ml.patch @@ -0,0 +1,22 @@ +--- ocaml_502/typing/stypes.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/stypes.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -103,7 +103,7 @@ + let rec printtyp_reset_maybe loc = + match !phrases with + | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> +- Printtyp.reset (); ++ Out_type.reset (); + phrases := t; + printtyp_reset_maybe loc; + | _ -> () +@@ -148,7 +148,9 @@ + printtyp_reset_maybe loc; + Format.pp_print_string Format.str_formatter " "; + Printtyp.wrap_printing_env ~error:false env +- (fun () -> Printtyp.shared_type_scheme Format.str_formatter typ); ++ (fun () -> ++ Printtyp.shared_type_scheme Format.str_formatter typ ++ ); + Format.pp_print_newline Format.str_formatter (); + let s = Format.flush_str_formatter () in + output_string pp s; diff --git a/upstream/patches_503/typing/tast_iterator.ml.patch b/upstream/patches_503/typing/tast_iterator.ml.patch new file mode 100644 index 000000000..5d2ab9b60 --- /dev/null +++ b/upstream/patches_503/typing/tast_iterator.ml.patch @@ -0,0 +1,21 @@ +--- ocaml_502/typing/tast_iterator.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/tast_iterator.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -309,12 +309,14 @@ + | Texp_apply (exp, list) -> + sub.expr sub exp; + List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list +- | Texp_match (exp, cases, _) -> ++ | Texp_match (exp, cases, effs, _) -> + sub.expr sub exp; +- List.iter (sub.case sub) cases +- | Texp_try (exp, cases) -> ++ List.iter (sub.case sub) cases; ++ List.iter (sub.case sub) effs ++ | Texp_try (exp, cases, effs) -> + sub.expr sub exp; +- List.iter (sub.case sub) cases ++ List.iter (sub.case sub) cases; ++ List.iter (sub.case sub) effs + | Texp_tuple list -> List.iter (sub.expr sub) list + | Texp_construct (lid, _, args) -> + iter_loc sub lid; diff --git a/upstream/patches_503/typing/tast_mapper.ml.patch b/upstream/patches_503/typing/tast_mapper.ml.patch new file mode 100644 index 000000000..cebdcad06 --- /dev/null +++ b/upstream/patches_503/typing/tast_mapper.ml.patch @@ -0,0 +1,38 @@ +--- ocaml_502/typing/tast_mapper.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/tast_mapper.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -362,16 +362,18 @@ + sub.expr sub exp, + List.map (tuple2 id (Option.map (sub.expr sub))) list + ) +- | Texp_match (exp, cases, p) -> ++ | Texp_match (exp, cases, eff_cases, p) -> + Texp_match ( + sub.expr sub exp, + List.map (sub.case sub) cases, ++ List.map (sub.case sub) eff_cases, + p + ) +- | Texp_try (exp, cases) -> ++ | Texp_try (exp, exn_cases, eff_cases) -> + Texp_try ( + sub.expr sub exp, +- List.map (sub.case sub) cases ++ List.map (sub.case sub) exn_cases, ++ List.map (sub.case sub) eff_cases + ) + | Texp_tuple list -> + Texp_tuple (List.map (sub.expr sub) list) +@@ -843,11 +845,12 @@ + + let case + : type k . mapper -> k case -> k case +- = fun sub {c_lhs; c_guard; c_rhs} -> ++ = fun sub {c_lhs; c_guard; c_rhs; c_cont} -> + { + c_lhs = sub.pat sub c_lhs; + c_guard = Option.map (sub.expr sub) c_guard; + c_rhs = sub.expr sub c_rhs; ++ c_cont + } + + let value_binding sub x = diff --git a/upstream/patches_503/typing/typeclass.ml.patch b/upstream/patches_503/typing/typeclass.ml.patch new file mode 100644 index 000000000..fadc2adf7 --- /dev/null +++ b/upstream/patches_503/typing/typeclass.ml.patch @@ -0,0 +1,498 @@ +--- ocaml_502/typing/typeclass.ml 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/typeclass.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -19,7 +19,6 @@ + open Types + open Typecore + open Typetexp +-open Format + + + type 'a class_info = { +@@ -48,7 +47,7 @@ + + type 'a full_class = { + id : Ident.t; +- id_loc : tag loc; ++ id_loc : string loc; + clty: class_declaration; + ty_id: Ident.t; + cltydef: class_type_declaration; +@@ -94,7 +93,7 @@ + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | Class_match_failure of Ctype.class_match_failure list + | Unbound_val of string +- | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure ++ | Unbound_type_var of Format_doc.t * Ctype.closed_class_failure + | Non_generalizable_class of + { id : Ident.t + ; clty : Types.class_declaration +@@ -465,7 +464,7 @@ + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; +- val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } ++ val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } + in + Env.enter_value ~check name desc met_env + +@@ -480,7 +479,7 @@ + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; +- val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } ++ val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } + in + Env.add_value ~check id desc met_env + +@@ -495,7 +494,7 @@ + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; +- val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } ++ val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } + in + Env.add_value id desc met_env + +@@ -654,10 +653,9 @@ + with_attrs + (fun () -> + let cty = +- Ctype.with_local_level_if_principal ++ Ctype.with_local_level_generalize_structure_if_principal + (fun () -> Typetexp.transl_simple_type val_env + ~closed:false styp) +- ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Virtual cty.ctyp_type sign; +@@ -694,8 +692,7 @@ + No_overriding ("instance variable", label.txt))) + end; + let definition = +- Ctype.with_local_level_if_principal +- ~post:Typecore.generalize_structure_exp ++ Ctype.with_local_level_generalize_structure_if_principal + (fun () -> type_exp val_env sdefinition) + in + add_instance_variable ~strict:true loc val_env +@@ -1028,7 +1025,7 @@ + raise(Error(loc, val_env, Closing_self_type sign)); + end; + (* Typing of method bodies *) +- Ctype.generalize_class_signature_spine val_env sign; ++ Ctype.generalize_class_signature_spine sign; + let self_var_kind = + match virt with + | Virtual -> Self_virtual(ref meths) +@@ -1036,9 +1033,9 @@ + in + let met_env = + List.fold_right +- (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> ++ (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes} met_env -> + add_self_met pv_loc pv_id sign self_var_kind vars +- cl_num pv_as_var pv_type pv_attributes met_env) ++ cl_num (pv_kind=As_var) pv_type pv_attributes met_env) + self_pat_vars met_env + in + let fields = +@@ -1151,13 +1148,9 @@ + class_expr cl_num val_env met_env virt self_scope sfun + | Pcl_fun (l, None, spat, scl') -> + let (pat, pv, val_env', met_env) = +- Ctype.with_local_level_if_principal ++ Ctype.with_local_level_generalize_structure_if_principal + (fun () -> + Typecore.type_class_arg_pattern cl_num val_env met_env l spat) +- ~post: begin fun (pat, _, _, _) -> +- let gen {pat_type = ty} = Ctype.generalize_structure ty in +- iter_pattern gen pat +- end + in + let pv = + List.map +@@ -1183,7 +1176,7 @@ + let partial = + let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in + Typecore.check_partial val_env pat.pat_type pat.pat_loc +- [{c_lhs = pat; c_guard = None; c_rhs = dummy}] ++ [{c_lhs = pat; c_cont = None; c_guard = None; c_rhs = dummy}] + in + let cl = + Ctype.with_raised_nongen_level +@@ -1201,9 +1194,8 @@ + | Pcl_apply (scl', sargs) -> + assert (sargs <> []); + let cl = +- Ctype.with_local_level_if_principal ++ Ctype.with_local_level_generalize_structure_if_principal + (fun () -> class_expr cl_num val_env met_env virt self_scope scl') +- ~post:(fun cl -> Ctype.generalize_class_type_structure cl.cl_type) + in + let rec nonopt_labels ls ty_fun = + match ty_fun with +@@ -1222,7 +1214,7 @@ + Location.prerr_warning + cl.cl_loc + (Warnings.Labels_omitted +- (List.map Printtyp.string_of_label ++ (List.map Asttypes.string_of_label + (List.filter ((<>) Nolabel) labels))); + true + end +@@ -1270,7 +1262,7 @@ + if not optional && Btype.is_optional l' then + Location.prerr_warning sarg.pexp_loc + (Warnings.Nonoptional_label +- (Printtyp.string_of_label l)); ++ (Asttypes.string_of_label l)); + remaining_sargs, use_arg sarg l' + | None -> + sargs, +@@ -1314,7 +1306,7 @@ + (* do not mark the value as used *) + let vd = Env.find_value path val_env in + let ty = +- Ctype.with_local_level ~post:Ctype.generalize ++ Ctype.with_local_level_generalize + (fun () -> Ctype.instance vd.val_type) + in + let expr = +@@ -1372,8 +1364,10 @@ + cl, clty + end + ~post: begin fun ({cl_type=cl}, {cltyp_type=clty}) -> +- Ctype.limited_generalize_class_type (Btype.self_type_row cl) cl; +- Ctype.limited_generalize_class_type (Btype.self_type_row clty) clty; ++ Ctype.limited_generalize_class_type ++ (Btype.self_type_row cl) ~inside:cl; ++ Ctype.limited_generalize_class_type ++ (Btype.self_type_row clty) ~inside:clty; + end + in + begin match +@@ -1474,8 +1468,8 @@ + + (* Temporary type for the class constructor *) + let constr_type = +- Ctype.with_local_level_if_principal (fun () -> approx cl.pci_expr) +- ~post:Ctype.generalize_structure ++ Ctype.with_local_level_generalize_structure_if_principal ++ (fun () -> approx cl.pci_expr) + in + let dummy_cty = Cty_signature (Ctype.new_class_signature ()) in + let dummy_class = +@@ -1560,8 +1554,10 @@ + end + ~post: begin fun (_, params, _, _, typ, sign) -> + (* Generalize the row variable *) +- List.iter (Ctype.limited_generalize sign.csig_self_row) params; +- Ctype.limited_generalize_class_type sign.csig_self_row typ; ++ List.iter ++ (fun inside -> Ctype.limited_generalize sign.csig_self_row ~inside) ++ params; ++ Ctype.limited_generalize_class_type sign.csig_self_row ~inside:typ; + end + in + (* Check the abbreviation for the object type *) +@@ -1710,31 +1706,20 @@ + arity, pub_meths, List.rev !coercion_locs, expr) :: res, + env) + +-let final_decl env define_class +- (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, +- arity, pub_meths, coe, expr) = +- let cl_abbr = cltydef.clty_hash_type in +- +- begin try Ctype.collapse_conj_params env clty.cty_params ++let collapse_conj_class_params env (cl, id, clty, _, _, _, _, _, _, _, _, _) = ++ try Ctype.collapse_conj_params env clty.cty_params + with Ctype.Unify err -> + raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err))) +- end; +- +- List.iter Ctype.generalize clty.cty_params; +- Ctype.generalize_class_type clty.cty_type; +- Option.iter Ctype.generalize clty.cty_new; +- List.iter Ctype.generalize obj_abbr.type_params; +- Option.iter Ctype.generalize obj_abbr.type_manifest; +- List.iter Ctype.generalize cl_abbr.type_params; +- Option.iter Ctype.generalize cl_abbr.type_manifest; + ++let final_decl env define_class ++ (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, ++ arity, pub_meths, coe, expr) = + Ctype.nongen_vars_in_class_declaration clty + |> Option.iter (fun vars -> + let nongen_vars = Btype.TypeSet.elements vars in + raise(Error(cl.pci_loc, env + , Non_generalizable_class { id; clty; nongen_vars })); + ); +- + begin match + Ctype.closed_class clty.cty_params + (Btype.signature_of_class_type clty.cty_type) +@@ -1743,8 +1728,11 @@ + | Some reason -> + let printer = + if define_class +- then function ppf -> Printtyp.class_declaration id ppf clty +- else function ppf -> Printtyp.cltype_declaration id ppf cltydef ++ then ++ Format_doc.doc_printf "%a" (Printtyp.Doc.class_declaration id) clty ++ else ++ Format_doc.doc_printf "%a" ++ (Printtyp.Doc.cltype_declaration id) cltydef + in + raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) + end; +@@ -1848,18 +1836,19 @@ + Ident.create_scoped ~scope cl.pci_name.txt, + Ident.create_scoped ~scope cl.pci_name.txt, + Ident.create_scoped ~scope cl.pci_name.txt, +- Uid.mk ~current_unit:(Env.get_unit_name ()) ++ Uid.mk ~current_unit:(Env.get_current_unit ()) + )) + cls + in + let res, env = +- Ctype.with_local_level_for_class begin fun () -> ++ Ctype.with_local_level_generalize_for_class begin fun () -> + let (res, env) = + List.fold_left (initial_env define_class approx) ([], env) cls + in + let (res, env) = + List.fold_right (class_infos define_class kind) res ([], env) + in ++ List.iter (collapse_conj_class_params env) res; + res, env + end + in +@@ -1980,7 +1969,7 @@ + + (* Error report *) + +-open Format ++open Format_doc + + let non_virtual_string_of_kind : kind -> string = function + | Object -> "object" +@@ -1988,32 +1977,36 @@ + | Class_type -> "non-virtual class type" + + module Style=Misc.Style ++module Printtyp = Printtyp.Doc + +-let report_error env ppf = ++let out_type ppf t = Style.as_inline_code !Oprint.out_type ppf t ++let quoted_type ppf t = Style.as_inline_code Printtyp.type_expr ppf t ++ ++let report_error_doc env ppf = + let pp_args ppf args = +- let args = List.map (Printtyp.tree_of_typexp Type) args in ++ let args = List.map (Out_type.tree_of_typexp Type) args in + Style.as_inline_code !Oprint.out_type_args ppf args + in + function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Unconsistent_constraint err -> ++ let msg = Format_doc.Doc.msg in + fprintf ppf "@[The class constraints are not consistent.@ "; +- Printtyp.report_unification_error ppf env err +- (fun ppf -> fprintf ppf "Type") +- (fun ppf -> fprintf ppf "is not compatible with type"); ++ Errortrace_report.unification ppf env err ++ (msg "Type") ++ (msg "is not compatible with type"); + fprintf ppf "@]" + | Field_type_mismatch (k, m, err) -> +- Printtyp.report_unification_error ppf env err +- (function ppf -> +- fprintf ppf "The %s %a@ has type" k Style.inline_code m) +- (function ppf -> +- fprintf ppf "but is expected to have type") ++ let msg = Format_doc.doc_printf in ++ Errortrace_report.unification ppf env err ++ (msg "The %s %a@ has type" k Style.inline_code m) ++ (msg "but is expected to have type") + | Unexpected_field (ty, lab) -> + fprintf ppf + "@[@[<2>This object is expected to have type :@ %a@]\ + @ This type does not have a method %a." +- (Style.as_inline_code Printtyp.type_expr) ty ++ quoted_type ty + Style.inline_code lab + | Structure_expected clty -> + fprintf ppf +@@ -2034,7 +2027,7 @@ + (* XXX Revoir message d'erreur | Improve error message *) + fprintf ppf "@[%s@ %a@]" + "This pattern cannot match self: it only matches values of type" +- (Style.as_inline_code Printtyp.type_expr) ty ++ quoted_type ty + | Unbound_class_2 cl -> + fprintf ppf "@[The class@ %a@ is not yet completely defined@]" + (Style.as_inline_code Printtyp.longident) cl +@@ -2043,23 +2036,19 @@ + (Style.as_inline_code Printtyp.longident) cl + | Abbrev_type_clash (abbrev, actual, expected) -> + (* XXX Afficher une trace ? | Print a trace? *) +- Printtyp.prepare_for_printing [abbrev; actual; expected]; ++ Out_type.prepare_for_printing [abbrev; actual; expected]; + fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ + but is used with type@ %a@]" +- (Style.as_inline_code !Oprint.out_type) +- (Printtyp.tree_of_typexp Type abbrev) +- (Style.as_inline_code !Oprint.out_type) +- (Printtyp.tree_of_typexp Type actual) +- (Style.as_inline_code !Oprint.out_type) +- (Printtyp.tree_of_typexp Type expected) ++ out_type (Out_type.tree_of_typexp Type abbrev) ++ out_type (Out_type.tree_of_typexp Type actual) ++ out_type (Out_type.tree_of_typexp Type expected) + | Constructor_type_mismatch (c, err) -> +- Printtyp.report_unification_error ppf env err +- (function ppf -> +- fprintf ppf "The expression %a has type" ++ let msg = Format_doc.doc_printf in ++ Errortrace_report.unification ppf env err ++ (msg "The expression %a has type" + Style.inline_code ("new " ^ c) + ) +- (function ppf -> +- fprintf ppf "but is used with type") ++ (msg "but is used with type") + | Virtual_class (kind, mets, vals) -> + let kind = non_virtual_string_of_kind kind in + let missings = +@@ -2085,13 +2074,12 @@ + but is here applied to %i type argument(s)@]" + (Style.as_inline_code Printtyp.longident) lid expected provided + | Parameter_mismatch err -> +- Printtyp.report_unification_error ppf env err +- (function ppf -> +- fprintf ppf "The type parameter") +- (function ppf -> +- fprintf ppf "does not meet its constraint: it should be") ++ let msg = Format_doc.Doc.msg in ++ Errortrace_report.unification ppf env err ++ (msg "The type parameter") ++ (msg "does not meet its constraint: it should be") + | Bad_parameters (id, params, cstrs) -> +- Printtyp.prepare_for_printing (params @ cstrs); ++ Out_type.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The abbreviation %a@ is used with parameter(s)@ %a@ \ + which are incompatible with constraint(s)@ %a@]" +@@ -2100,7 +2088,7 @@ + pp_args cstrs + | Bad_class_type_parameters (id, params, cstrs) -> + let pp_hash ppf id = fprintf ppf "#%a" Printtyp.ident id in +- Printtyp.prepare_for_printing (params @ cstrs); ++ Out_type.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The class type %a@ is used with parameter(s)@ %a,@ \ + whereas the class type definition@ constrains@ \ +@@ -2109,10 +2097,10 @@ + pp_args params + pp_args cstrs + | Class_match_failure error -> +- Includeclass.report_error Type ppf error ++ Includeclass.report_error_doc Type ppf error + | Unbound_val lab -> + fprintf ppf "Unbound instance variable %a" Style.inline_code lab +- | Unbound_type_var (printer, reason) -> ++ | Unbound_type_var (msg, reason) -> + let print_reason ppf { Ctype.free_variable; meth; meth_ty; } = + let (ty0, kind) = free_variable in + let ty1 = +@@ -2120,28 +2108,27 @@ + | Type_variable -> ty0 + | Row_variable -> Btype.newgenty(Tobject(ty0, ref None)) + in +- Printtyp.add_type_to_preparation meth_ty; +- Printtyp.add_type_to_preparation ty1; +- let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in ++ Out_type.add_type_to_preparation meth_ty; ++ Out_type.add_type_to_preparation ty1; + fprintf ppf + "The method %a@ has type@;<1 2>%a@ where@ %a@ is unbound" + Style.inline_code meth +- pp_type (Printtyp.tree_of_typexp Type meth_ty) +- pp_type (Printtyp.tree_of_typexp Type ty0) ++ out_type (Out_type.tree_of_typexp Type meth_ty) ++ out_type (Out_type.tree_of_typexp Type ty0) + in + fprintf ppf +- "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ ++ "@[@[Some type variables are unbound in this type:@;<1 2>%a@]@ \ + @[%a@]@]" +- printer print_reason reason ++ pp_doc msg print_reason reason + | Non_generalizable_class {id; clty; nongen_vars } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in +- Printtyp.prepare_for_printing nongen_vars; ++ Out_type.prepare_for_printing nongen_vars; + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + (Style.as_inline_code @@ Printtyp.class_declaration id) clty + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") +- (Style.as_inline_code Printtyp.prepared_type_scheme) ++ (Style.as_inline_code Out_type.prepared_type_scheme) + ) nongen_vars + Misc.print_see_manual manual_ref + +@@ -2152,20 +2139,20 @@ + Some occurrences are contravariant@]" + (Style.as_inline_code Printtyp.type_scheme) ty + | Non_collapsable_conjunction (id, clty, err) -> ++ let msg = Format_doc.Doc.msg in + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains non-collapsible conjunctive types in constraints.@ %t@]" + (Style.as_inline_code @@ Printtyp.class_declaration id) clty +- (fun ppf -> Printtyp.report_unification_error ppf env err +- (fun ppf -> fprintf ppf "Type") +- (fun ppf -> fprintf ppf "is not compatible with type") ++ (fun ppf -> Errortrace_report.unification ppf env err ++ (msg "Type") ++ (msg "is not compatible with type") + ) + | Self_clash err -> +- Printtyp.report_unification_error ppf env err +- (function ppf -> +- fprintf ppf "This object is expected to have type") +- (function ppf -> +- fprintf ppf "but actually has type") ++ let msg = Format_doc.Doc.msg in ++ Errortrace_report.unification ppf env err ++ (msg "This object is expected to have type") ++ (msg "but actually has type") + | Mutability_mismatch (_lab, mut) -> + let mut1, mut2 = + if mut = Immutable then "mutable", "immutable" +@@ -2192,17 +2179,19 @@ + completely defined.@]" + (Style.as_inline_code Printtyp.type_scheme) sign.csig_self + +-let report_error env ppf err = ++let report_error_doc env ppf err = + Printtyp.wrap_printing_env ~error:true +- env (fun () -> report_error env ppf err) ++ env (fun () -> report_error_doc env ppf err) + + let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> +- Some (Location.error_of_printer ~loc (report_error env) err) ++ Some (Location.error_of_printer ~loc (report_error_doc env) err) + | Error_forward err -> + Some err + | _ -> + None + ) ++ ++let report_error = Format_doc.compat1 report_error_doc diff --git a/upstream/patches_503/typing/typeclass.mli.patch b/upstream/patches_503/typing/typeclass.mli.patch new file mode 100644 index 000000000..5c182054b --- /dev/null +++ b/upstream/patches_503/typing/typeclass.mli.patch @@ -0,0 +1,30 @@ +--- ocaml_502/typing/typeclass.mli 2024-06-27 15:42:08.727460578 +0200 ++++ ocaml_503/typing/typeclass.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -15,8 +15,6 @@ + + open Asttypes + open Types +-open Format +- + type 'a class_info = { + cls_id : Ident.t; + cls_id_loc : string loc; +@@ -111,7 +109,7 @@ + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | Class_match_failure of Ctype.class_match_failure list + | Unbound_val of string +- | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure ++ | Unbound_type_var of Format_doc.t * Ctype.closed_class_failure + | Non_generalizable_class of + { id : Ident.t + ; clty : Types.class_declaration +@@ -129,7 +127,8 @@ + exception Error of Location.t * Env.t * error + exception Error_forward of Location.error + +-val report_error : Env.t -> formatter -> error -> unit ++val report_error : Env.t -> Format.formatter -> error -> unit ++val report_error_doc : Env.t -> error Format_doc.printer + + (* Forward decl filled in by Typemod.type_open_descr *) + val type_open_descr : diff --git a/upstream/patches_503/typing/typecore.ml.patch b/upstream/patches_503/typing/typecore.ml.patch new file mode 100644 index 000000000..e5db77342 --- /dev/null +++ b/upstream/patches_503/typing/typecore.ml.patch @@ -0,0 +1,2384 @@ +--- ocaml_502/typing/typecore.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typecore.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -96,6 +96,11 @@ + | In_class_def (** or in [class c = let ... in ...] *) + | In_self_pattern (** or in self pattern *) + ++type existential_binding = ++ | Bind_already_bound ++ | Bind_not_in_scope ++ | Bind_non_locally_abstract ++ + type error = + | Constructor_arity_mismatch of Longident.t * int * int + | Label_mismatch of Longident.t * Errortrace.unification_error +@@ -106,7 +111,7 @@ + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option +- * Parsetree.expression_desc option ++ * Parsetree.expression option + | Function_arity_type_clash of + { syntactic_arity : int; + type_constraint : type_expr; +@@ -175,6 +180,8 @@ + | No_value_clauses + | Exception_pattern_disallowed + | Mixed_value_and_exception_patterns_under_guard ++ | Effect_pattern_below_toplevel ++ | Invalid_continuation_pattern + | Inlined_record_escape + | Inlined_record_expected + | Unrefuted_pattern of pattern +@@ -189,10 +196,15 @@ + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr ++ | Bind_existential of existential_binding * Ident.t * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + ++ ++let not_principal fmt = ++ Format_doc.Doc.kmsg (fun x -> Warnings.Not_principal x) fmt ++ + exception Error of Location.t * Env.t * error + exception Error_forward of Location.error + +@@ -256,7 +268,7 @@ + let mk_expected ?explanation ty = { ty; explanation; } + + let case lhs rhs = +- {c_lhs = lhs; c_guard = None; c_rhs = rhs} ++ {c_lhs = lhs; c_cont = None; c_guard = None; c_rhs = rhs} + + (* Typing of constants *) + +@@ -269,7 +281,8 @@ + | Const_int64 _ -> instance Predef.type_int64 + | Const_nativeint _ -> instance Predef.type_nativeint + +-let constant : Parsetree.constant -> (Asttypes.constant, error) result = ++let constant_desc ++ : Parsetree.constant_desc -> (Asttypes.constant, error) result = + function + | Pconst_integer (i,None) -> + begin +@@ -297,6 +310,8 @@ + | Pconst_float (f,None)-> Ok (Const_float f) + | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c)) + ++let constant const = constant_desc const.pconst_desc ++ + let constant_or_raise env loc cst = + match constant cst with + | Ok c -> c +@@ -368,6 +383,23 @@ + + (* Typing of patterns *) + ++(* Simplified patterns for effect continuations *) ++let type_continuation_pat env expected_ty sp = ++ let loc = sp.ppat_loc in ++ match sp.ppat_desc with ++ | Ppat_any -> None ++ | Ppat_var name -> ++ let id = Ident.create_local name.txt in ++ let desc = ++ { val_type = expected_ty; val_kind = Val_reg; ++ Types.val_loc = loc; val_attributes = []; ++ val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } ++ in ++ Some (id, desc) ++ | Ppat_extension ext -> ++ raise (Error_forward (Builtin_attributes.error_of_extension ext)) ++ | _ -> raise (Error (loc, env, Invalid_continuation_pattern)) ++ + (* unification inside type_exp and type_expect *) + let unify_exp_types loc env ty expected_ty = + (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type +@@ -463,12 +495,17 @@ + (* [type_pat_state] and related types for pattern environment; + these should not be confused with Pattern_env.t, which is a part of the + interface to unification functions in [Ctype] *) ++type pattern_variable_kind = ++ | Std_var ++ | As_var ++ | Continuation_var ++ + type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; +- pv_as_var: bool; ++ pv_kind: pattern_variable_kind; + pv_attributes: attributes; + pv_uid : Uid.t; + } +@@ -518,7 +555,17 @@ + *) + } + +-let create_type_pat_state allow_modules = ++let continuation_variable = function ++ | None -> [] ++ | Some (id, (desc:Types.value_description)) -> ++ [{pv_id = id; ++ pv_type = desc.val_type; ++ pv_loc = desc.val_loc; ++ pv_kind = Continuation_var; ++ pv_attributes = desc.val_attributes; ++ pv_uid= desc.val_uid}] ++ ++let create_type_pat_state ?cont allow_modules = + let tps_module_variables = + match allow_modules with + | Modules_allowed { scope } -> +@@ -526,7 +573,7 @@ + | Modules_ignored -> Modvars_ignored + | Modules_rejected -> Modvars_rejected + in +- { tps_pattern_variables = []; ++ { tps_pattern_variables = continuation_variable cont; + tps_module_variables; + tps_pattern_force = []; + } +@@ -581,7 +628,7 @@ + { mv_id = id; + mv_name = name; + mv_loc = loc; +- mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ mv_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } :: module_variables + in + tps.tps_module_variables <- +@@ -590,12 +637,12 @@ + end else + Ident.create_local name.txt + in +- let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in ++ let pv_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + tps.tps_pattern_variables <- + {pv_id = id; + pv_type = ty; + pv_loc = loc; +- pv_as_var = is_as_variable; ++ pv_kind = if is_as_variable then As_var else Std_var; + pv_attributes = attrs; + pv_uid} :: tps.tps_pattern_variables; + id, pv_uid +@@ -660,7 +707,7 @@ + If we used [generic_instance] we would lose the sharing between + [instance ty] and [ty]. *) + let ty = +- with_local_level ~post:generalize_structure (fun () -> instance ty) ++ with_local_level_generalize_structure (fun () -> instance ty) + in + (* This call to unify may only fail due to missing GADT equations *) + unify_pat_types p.pat_loc env (instance as_ty) (instance ty); +@@ -740,7 +787,7 @@ + | _ -> assert false + + let solve_Ppat_alias env pat = +- with_local_level ~post:generalize (fun () -> build_as_type env pat) ++ with_local_level_generalize (fun () -> build_as_type env pat) + + let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty = + let vars = List.map (fun _ -> newgenvar ()) args in +@@ -750,23 +797,31 @@ + vars + + let solve_constructor_annotation +- tps (penv : Pattern_env.t) name_list sty ty_args ty_ex = ++ tps (penv : Pattern_env.t) name_list sty ty_args ty_ex unify_res = + let expansion_scope = penv.equations_scope in +- let ids = ++ (* Introduce fresh type names that expand to type variables. ++ They should eventually be bound to ground types. *) ++ let ids_decls = + List.map + (fun name -> +- let decl = new_local_type ~loc:name.loc Definition in ++ let tv = newvar () in ++ let decl = ++ new_local_type ~loc:name.loc Definition ++ ~manifest_and_scope:(tv, Ident.lowest_scope) in + let (id, new_env) = + Env.enter_type ~scope:expansion_scope name.txt decl !!penv in + Pattern_env.set_env penv new_env; +- {name with txt = id}) ++ ({name with txt = id}, (decl, tv))) + name_list + in ++ (* Translate the type annotation using these type names. *) + let cty, ty, force = +- with_local_level ~post:(fun (_,ty,_) -> generalize_structure ty) ++ with_local_level_generalize_structure + (fun () -> Typetexp.transl_simple_type_delayed !!penv sty) + in + tps.tps_pattern_force <- force :: tps.tps_pattern_force; ++ (* Only unify the return type after generating the ids *) ++ unify_res (); + let ty_args = + let ty1 = instance ty and ty2 = instance ty in + match ty_args with +@@ -780,24 +835,62 @@ + Ttuple tyl -> tyl + | _ -> assert false + in +- if ids <> [] then ignore begin +- let ids = List.map (fun x -> x.txt) ids in ++ if ids_decls <> [] then begin ++ let ids_decls = List.map (fun (x,dm) -> (x.txt,dm)) ids_decls in ++ let ids = List.map fst ids_decls in + let rem = ++ (* First process the existentials introduced by this constructor. ++ Just need to make their definitions abstract. *) + List.fold_left + (fun rem tv -> + match get_desc tv with +- Tconstr(Path.Pident id, [], _) when List.mem id rem -> +- list_remove id rem ++ Tconstr(Path.Pident id, [], _) when List.mem_assoc id rem -> ++ let decl, tv' = List.assoc id ids_decls in ++ let env = ++ Env.add_type ~check:false id ++ {decl with type_manifest = None} !!penv ++ in ++ Pattern_env.set_env penv env; ++ (* We have changed the definition, so clean up *) ++ Btype.cleanup_abbrev (); ++ (* Since id is now abstract, this does not create a cycle *) ++ unify_pat_types cty.ctyp_loc env tv tv'; ++ List.remove_assoc id rem + | _ -> + raise (Error (cty.ctyp_loc, !!penv, + Unbound_existential (ids, ty)))) +- ids ty_ex ++ ids_decls ty_ex + in +- if rem <> [] then +- raise (Error (cty.ctyp_loc, !!penv, +- Unbound_existential (ids, ty))) ++ (* The other type names should be bound to newly introduced existentials. *) ++ let bound_ids = ref ids in ++ List.iter ++ (fun (id, (decl, tv')) -> ++ let tv' = expand_head !!penv tv' in ++ begin match get_desc tv' with ++ | Tconstr (Path.Pident id', [], _) -> ++ if List.exists (Ident.same id') !bound_ids then ++ raise (Error (cty.ctyp_loc, !!penv, ++ Bind_existential (Bind_already_bound, id, tv'))); ++ (* Both id and id' are Scoped identifiers, so their stamps grow *) ++ if Ident.scope id' <> penv.equations_scope ++ || Ident.compare_stamp id id' > 0 then ++ raise (Error (cty.ctyp_loc, !!penv, ++ Bind_existential (Bind_not_in_scope, id, tv'))); ++ bound_ids := id' :: !bound_ids ++ | _ -> ++ raise (Error (cty.ctyp_loc, !!penv, ++ Bind_existential ++ (Bind_non_locally_abstract, id, tv'))); ++ end; ++ let env = ++ Env.add_type ~check:false id ++ {decl with type_manifest = Some (duplicate_type tv')} !!penv ++ in ++ Pattern_env.set_env penv env) ++ rem; ++ if rem <> [] then Btype.cleanup_abbrev (); + end; +- ty_args, Some (ids, cty) ++ ty_args, Some (List.map fst ids_decls, cty) + + let solve_Ppat_construct ~refine tps penv loc constr no_existentials + existential_styp expected_ty = +@@ -814,7 +907,7 @@ + in + + let ty_args, equated_types, existential_ctyp = +- with_local_level_iter ~post: generalize_structure begin fun () -> ++ with_local_level_generalize_structure begin fun () -> + let expected_ty = instance expected_ty in + let ty_args, ty_res, equated_types, existential_ctyp = + match existential_styp with +@@ -835,16 +928,16 @@ + let ty_args, ty_res, ty_ex = + instance_constructor existential_treatment constr + in +- let equated_types = unify_res ty_res expected_ty in ++ let equated_types = lazy (unify_res ty_res expected_ty) in + let ty_args, existential_ctyp = + solve_constructor_annotation tps penv name_list sty ty_args ty_ex ++ (fun () -> ignore (Lazy.force equated_types)) + in +- ty_args, ty_res, equated_types, existential_ctyp ++ ty_args, ty_res, Lazy.force equated_types, existential_ctyp + in + if constr.cstr_existentials <> [] then + lower_variables_only !!penv penv.Pattern_env.equations_scope ty_res; +- ((ty_args, equated_types, existential_ctyp), +- expected_ty :: ty_res :: ty_args) ++ (ty_args, equated_types, existential_ctyp) + end + in + if !Clflags.principal && not refine then begin +@@ -853,16 +946,14 @@ + try + TypePairs.iter + (fun (t1, t2) -> +- generalize_structure t1; +- generalize_structure t2; + if not (fully_generic t1 && fully_generic t2) then + let msg = +- Format.asprintf ++ Format_doc.doc_printf + "typing this pattern requires considering@ %a@ and@ %a@ as \ + equal.@,\ + But the knowledge of these types" +- Printtyp.type_expr t1 +- Printtyp.type_expr t2 ++ Printtyp.Doc.type_expr t1 ++ Printtyp.Doc.type_expr t2 + in + Location.prerr_warning loc (Warnings.Not_principal msg); + raise Warn_only_once) +@@ -872,7 +963,7 @@ + (ty_args, existential_ctyp) + + let solve_Ppat_record_field ~refine loc penv label label_lid record_ty = +- with_local_level_iter ~post:generalize_structure begin fun () -> ++ with_local_level_generalize_structure begin fun () -> + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in + begin try + unify_pat_types_refine ~refine loc penv ty_res (instance record_ty) +@@ -880,7 +971,7 @@ + raise(Error(label_lid.loc, !!penv, + Label_mismatch(label_lid.txt, err))) + end; +- (ty_arg, [ty_res; ty_arg]) ++ ty_arg + end + + let solve_Ppat_array ~refine loc env expected_ty = +@@ -898,7 +989,7 @@ + + let solve_Ppat_constraint tps loc env sty expected_ty = + let cty, ty, force = +- with_local_level ~post:(fun (_, ty, _) -> generalize_structure ty) ++ with_local_level_generalize_structure + (fun () -> Typetexp.transl_simple_type_delayed env sty) + in + tps.tps_pattern_force <- force :: tps.tps_pattern_force; +@@ -1055,7 +1146,7 @@ + [_] -> [] + | _ -> let open Printtyp in + wrap_printing_env ~error:true env (fun () -> +- reset(); strings_of_paths (Some Type) tpaths) ++ Out_type.reset(); strings_of_paths Type tpaths) + + let disambiguate_by_type env tpath lbls = + match lbls with +@@ -1070,10 +1161,12 @@ + (* warn if there are several distinct candidates in scope *) + let warn_if_ambiguous warn lid env lbl rest = + if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin +- Printtyp.Conflicts.reset (); ++ Out_type.Ident_conflicts.reset (); + let paths = ambiguous_types env lbl rest in +- let expansion = +- Format.asprintf "%t" Printtyp.Conflicts.print_explanations in ++ let expansion = match Out_type.Ident_conflicts.err_msg () with ++ | None -> "" ++ | Some msg -> Format_doc.(asprintf "%a" pp_doc) msg ++ in + if paths <> [] then + warn lid.loc + (Warnings.Ambiguous_name ([Longident.last lid.txt], +@@ -1084,15 +1177,15 @@ + let warn_non_principal warn lid = + let name = Datatype_kind.label_name kind in + warn lid.loc +- (Warnings.Not_principal +- ("this type-based " ^ name ^ " disambiguation")) ++ (not_principal "this type-based %s disambiguation" name) + + (* we selected a name out of the lexical scope *) + let warn_out_of_scope warn lid env tpath = + if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin + let path_s = + Printtyp.wrap_printing_env ~error:true env +- (fun () -> Printtyp.string_of_path tpath) in ++ (fun () -> Format_doc.asprintf "%a" Printtyp.Doc.type_path tpath) ++ in + warn lid.loc + (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) + end +@@ -1332,7 +1425,7 @@ + in + if !w_pr then + Location.prerr_warning loc +- (Warnings.Not_principal "this type-based record disambiguation") ++ (not_principal "this type-based record disambiguation") + else begin + match List.rev !w_amb with + (_,types,ex)::_ as amb -> +@@ -1485,6 +1578,7 @@ + List.exists has_literal_pattern ps + | Ppat_record (ps, _) -> + List.exists (fun (_,p) -> has_literal_pattern p) ps ++ | Ppat_effect (p, q) + | Ppat_or (p, q) -> + has_literal_pattern p || has_literal_pattern q + +@@ -1658,22 +1752,27 @@ + pat_type = type_constant cst; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } +- | Ppat_interval (Pconst_char c1, Pconst_char c2) -> +- let open Ast_helper.Pat in ++ | Ppat_interval (c1, c2) -> ++ let open Ast_helper in ++ let get_bound = function ++ | {pconst_desc = Pconst_char c; _} -> c ++ | {pconst_loc = loc; _} -> ++ raise (Error (loc, !!penv, Invalid_interval)) ++ in ++ let c1 = get_bound c1 in ++ let c2 = get_bound c2 in + let gloc = {loc with Location.loc_ghost=true} in + let rec loop c1 c2 = +- if c1 = c2 then constant ~loc:gloc (Pconst_char c1) ++ if c1 = c2 then Pat.constant ~loc:gloc (Const.char ~loc:gloc c1) + else +- or_ ~loc:gloc +- (constant ~loc:gloc (Pconst_char c1)) ++ Pat.or_ ~loc:gloc ++ (Pat.constant ~loc:gloc (Const.char ~loc:gloc c1)) + (loop (Char.chr(Char.code c1 + 1)) c2) + in + let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in + let p = {p with ppat_loc=loc} in + type_pat tps category p expected_ty + (* TODO: record 'extra' to remember about interval *) +- | Ppat_interval _ -> +- raise (Error (loc, !!penv, Invalid_interval)) + | Ppat_tuple spl -> + assert (List.length spl >= 2); + let expected_tys = +@@ -1843,6 +1942,8 @@ + forces. *) + let tps1 = copy_type_pat_state tps in + let tps2 = {(copy_type_pat_state tps) with tps_pattern_force = []} in ++ (* Introduce a new level to avoid keeping nodes at intermediate levels *) ++ let pat_desc = with_local_level_generalize begin fun () -> + (* Introduce a new scope using with_local_level without generalizations *) + let env1, p1, env2, p2 = + with_local_level begin fun () -> +@@ -1885,7 +1986,10 @@ + } + ~dst:tps; + let p2 = alpha_pat alpha_env p2 in +- rp { pat_desc = Tpat_or (p1, p2, None); ++ Tpat_or (p1, p2, None) ++ end ++ in ++ rp { pat_desc = pat_desc; + pat_loc = loc; pat_extra = []; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; +@@ -1944,6 +2048,8 @@ + pat_env = !!penv; + pat_attributes = sp.ppat_attributes; + } ++ | Ppat_effect _ -> ++ raise (Error (loc, !!penv, Effect_pattern_below_toplevel)) + | Ppat_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +@@ -1952,8 +2058,8 @@ + + let add_pattern_variables ?check ?check_as env pv = + List.fold_right +- (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} env -> +- let check = if pv_as_var then check_as else check in ++ (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes; pv_uid} env -> ++ let check = if pv_kind=As_var then check_as else check in + Env.add_value ?check pv_id + {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; + val_attributes = pv_attributes; +@@ -2002,8 +2108,8 @@ + let type_pat tps category ?no_existentials penv = + type_pat tps category ~no_existentials ~penv + +-let type_pattern category ~lev env spat expected_ty allow_modules = +- let tps = create_type_pat_state allow_modules in ++let type_pattern category ~lev env spat expected_ty ?cont allow_modules = ++ let tps = create_type_pat_state ?cont allow_modules in + let new_penv = Pattern_env.make env + ~equations_scope:lev ~allow_recursive_equations:false in + let pat = type_pat tps category new_penv spat expected_ty in +@@ -2049,13 +2155,13 @@ + if is_optional l then unify_pat val_env pat (type_option (newvar ())); + let (pv, val_env, met_env) = + List.fold_right +- (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} ++ (fun {pv_id; pv_type; pv_loc; pv_kind; pv_attributes} + (pv, val_env, met_env) -> + let check s = +- if pv_as_var then Warnings.Unused_var s ++ if pv_kind = As_var then Warnings.Unused_var s + else Warnings.Unused_var_strict s in + let id' = Ident.rename pv_id in +- let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in ++ let val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let val_env = + Env.add_value pv_id + { val_type = pv_type +@@ -2458,9 +2564,9 @@ + match exp.exp_desc with + Texp_let (_, _, e) + | Texp_sequence (_, e) +- | Texp_try (e, _) ++ | Texp_try (e, _, _) + | Texp_ifthenelse (_, e, _) +- | Texp_match (_, {c_rhs=e} :: _, _) ++ | Texp_match (_, {c_rhs=e} :: _, _, _) + | Texp_letmodule (_, _, _, _, e) + | Texp_letexception (_, e) + | Texp_open (_, e) +@@ -2481,7 +2587,7 @@ + is_nonexpansive body + | Texp_apply(e, (_,None)::el) -> + is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) +- | Texp_match(e, cases, _) -> ++ | Texp_match(e, cases, _, _) -> + (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't + care if there are exception patterns. But the previous version enforced + that there be none, so... *) +@@ -2746,14 +2852,19 @@ + List.rev ls, is_Tvar ty + + let list_labels env ty = +- wrap_trace_gadt_instances env (list_labels_aux env TypeSet.empty []) ty ++ let snap = Btype.snapshot () in ++ let result = ++ wrap_trace_gadt_instances env (list_labels_aux env TypeSet.empty []) ty ++ in ++ Btype.backtrack snap; ++ result + + (* Check that all univars are safe in a type. Both exp.exp_type and + ty_expected should already be generalized. *) + let check_univars env kind exp ty_expected vars = + let pty = instance ty_expected in + let exp_ty, vars = +- with_local_level_iter ~post:generalize begin fun () -> ++ with_local_level_generalize begin fun () -> + match get_desc pty with + Tpoly (body, tl) -> + (* Enforce scoping for type_let: +@@ -2762,7 +2873,7 @@ + let _, ty' = instance_poly ~fixed:true tl body in + let vars, exp_ty = instance_parameterized_type vars exp.exp_type in + unify_exp_types exp.exp_loc env exp_ty ty'; +- ((exp_ty, vars), exp_ty::vars) ++ (exp_ty, vars) + | _ -> assert false + end + in +@@ -2776,12 +2887,6 @@ + ~trace:[Ctype.expanded_diff env + ~got:ty ~expected:ty_expected]))) + +-let generalize_and_check_univars env kind exp ty_expected vars = +- generalize exp.exp_type; +- generalize ty_expected; +- List.iter generalize vars; +- check_univars env kind exp ty_expected vars +- + (* [check_statement] implements the [non-unit-statement] check. + + This check is called in contexts where the value of the expression is known +@@ -2856,10 +2961,13 @@ + | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None) + | Texp_function _ -> + check_statement () +- | Texp_match (_, cases, _) -> +- List.iter (fun {c_rhs; _} -> check c_rhs) cases +- | Texp_try (e, cases) -> +- check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases ++ | Texp_match (_, cases, eff_cases, _) -> ++ List.iter (fun {c_rhs; _} -> check c_rhs) cases; ++ List.iter (fun {c_rhs; _} -> check c_rhs) eff_cases ++ | Texp_try (e, cases, eff_cases) -> ++ check e; ++ List.iter (fun {c_rhs; _} -> check c_rhs) cases; ++ List.iter (fun {c_rhs; _} -> check c_rhs) eff_cases + | Texp_ifthenelse (_, e1, Some e2) -> + check e1; check e2 + | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e) +@@ -2899,13 +3007,13 @@ + + (* Check that a type is generalizable at some level *) + let generalizable level ty = +- let rec check ty = +- if not_marked_node ty then +- if get_level ty <= level then raise Exit else +- (flip_mark_node ty; iter_type_expr check ty) +- in +- try check ty; unmark_type ty; true +- with Exit -> unmark_type ty; false ++ with_type_mark begin fun mark -> ++ let rec check ty = ++ if try_mark_node mark ty then ++ if get_level ty <= level then raise Exit else iter_type_expr check ty ++ in ++ try check ty; true with Exit -> false ++ end + + (* Hack to allow coercion of self. Will clean-up later. *) + let self_coercion = ref ([] : (Path.t * Location.t list ref) list) +@@ -2913,8 +3021,9 @@ + (* Helpers for type_cases *) + + let contains_variant_either ty = ++ with_type_mark begin fun mark -> + let rec loop ty = +- if try_mark_node ty then ++ if try_mark_node mark ty then + begin match get_desc ty with + Tvariant row -> + if not (is_fixed row) then +@@ -2927,8 +3036,8 @@ + iter_type_expr loop ty + end + in +- try loop ty; unmark_type ty; false +- with Exit -> unmark_type ty; true ++ try loop ty; false with Exit -> true ++ end + + let shallow_iter_ppat f p = + match p.ppat_desc with +@@ -2937,7 +3046,8 @@ + | Ppat_extension _ + | Ppat_type _ | Ppat_unpack _ -> () + | Ppat_array pats -> List.iter f pats +- | Ppat_or (p1,p2) -> f p1; f p2 ++ | Ppat_or (p1,p2) ++ | Ppat_effect(p1, p2) -> f p1; f p2 + | Ppat_variant (_, arg) -> Option.iter f arg + | Ppat_tuple lst -> List.iter f lst + | Ppat_construct (_, Some (_, p)) +@@ -3006,14 +3116,14 @@ + || not (is_fixed row) && not (static_row row) (* same as Ctype.poly *) + then () else + let ty_arg = +- match arg with None -> [] | Some p -> [correct_levels p.pat_type] in ++ match arg with None -> [] | Some p -> [duplicate_type p.pat_type] in + let fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in + let row' = + create_row ~fields + ~more:(newvar ()) ~closed:false ~fixed:None ~name:None in + (* Should fail *) + unify_pat env {pat with pat_type = newty (Tvariant row')} +- (correct_levels pat.pat_type) ++ (duplicate_type pat.pat_type) + | _ -> () } + + (* Getting proper location of already typed expressions. +@@ -3052,14 +3162,14 @@ + + (* Typing of expressions *) + +-(** [sdesc_for_hint] is used by error messages to report literals in their ++(** [sexp_for_hint] is used by error messages to report literals in their + original formatting *) +-let unify_exp ?sdesc_for_hint env exp expected_ty = ++let unify_exp ~sexp env exp expected_ty = + let loc = proper_exp_loc exp in + try + unify_exp_types loc env exp.exp_type expected_ty + with Error(loc, env, Expr_type_clash(err, tfc, None)) -> +- raise (Error(loc, env, Expr_type_clash(err, tfc, sdesc_for_hint))) ++ raise (Error(loc, env, Expr_type_clash(err, tfc, Some sexp))) + + (* If [is_inferred e] is true, [e] will be typechecked without using + the "expected type" provided by the context. *) +@@ -3111,10 +3221,8 @@ + raise (Error (loc', env', err)) + + (* Generalize expressions *) +-let generalize_structure_exp exp = generalize_structure exp.exp_type +-let may_lower_contravariant_then_generalize env exp = +- if maybe_expansive exp then lower_contravariant env exp.exp_type; +- generalize exp.exp_type ++let may_lower_contravariant env exp = ++ if maybe_expansive exp then lower_contravariant env exp.exp_type + + (* value binding elaboration *) + +@@ -3206,16 +3314,15 @@ + env sexp ty_expected_explained = + let { ty = ty_expected; explanation } = ty_expected_explained in + let loc = sexp.pexp_loc in +- let desc = sexp.pexp_desc in + (* Record the expression type before unifying it with the expected type *) + let with_explanation = with_explanation explanation in + (* Unify the result with [ty_expected], enforcing the current level *) + let rue exp = + with_explanation (fun () -> +- unify_exp ~sdesc_for_hint:desc env (re exp) (instance ty_expected)); ++ unify_exp ~sexp env (re exp) (instance ty_expected)); + exp + in +- match desc with ++ match sexp.pexp_desc with + | Pexp_ident lid -> + let path, desc = type_ident env ~recarg lid in + let exp_desc = +@@ -3242,7 +3349,7 @@ + exp_type = instance desc.val_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } +- | Pexp_constant(Pconst_string (str, _, _) as cst) -> ( ++ | Pexp_constant({pconst_desc = Pconst_string (str, _, _); _} as cst) -> ( + let cst = constant_or_raise env loc cst in + (* Terrible hack for format strings *) + let ty_exp = expand_head env (protect_expansion env ty_expected) in +@@ -3254,7 +3361,7 @@ + | Tconstr(path, _, _) when Path.same path fmt6_path -> + if !Clflags.principal && get_level ty_exp <> generic_level then + Location.prerr_warning loc +- (Warnings.Not_principal "this coercion to format6"); ++ (not_principal "this coercion to format6"); + true + | _ -> false + in +@@ -3302,7 +3409,7 @@ + introduced by those unpacks. The below code checks for scope escape + via both of these pathways (body, bound expressions). + *) +- with_local_level_if may_contain_modules begin fun () -> ++ with_local_level_generalize_if may_contain_modules begin fun () -> + let allow_modules = + if may_contain_modules + then +@@ -3333,7 +3440,6 @@ + types added to [new_env]. + *) + let bound_exp = vb.vb_expr in +- generalize_structure_exp bound_exp; + let bound_exp_type = Ctype.instance bound_exp.exp_type in + let loc = proper_exp_loc bound_exp in + let outer_var = newvar2 outer_level in +@@ -3347,9 +3453,9 @@ + end; + (pat_exp_list, body, new_env) + end +- ~post:(fun (_pat_exp_list, body, new_env) -> ++ ~before_generalize:(fun (_pat_exp_list, body, new_env) -> + (* The "body" component of the scope escape check. *) +- unify_exp new_env body (newvar ())) ++ unify_exp ~sexp new_env body (newvar ())) + in + re { + exp_desc = Texp_let(rec_flag, pat_exp_list, body); +@@ -3413,28 +3519,27 @@ + } + | Pexp_apply(sfunct, sargs) -> + assert (sargs <> []); ++ let outer_level = get_current_level () in + let rec lower_args seen ty_fun = + let ty = expand_head env ty_fun in + if TypeSet.mem ty seen then () else + match get_desc ty with + Tarrow (_l, ty_arg, ty_fun, _com) -> +- (try enforce_current_level env ty_arg ++ (try Ctype.unify_var env (newvar2 outer_level) ty_arg + with Unify _ -> assert false); + lower_args (TypeSet.add ty seen) ty_fun + | _ -> () + in ++ (* one more level for warning on non-returning functions *) ++ with_local_level_generalize begin fun () -> + let type_sfunct sfunct = +- (* one more level for warning on non-returning functions *) +- with_local_level_iter +- begin fun () -> +- let funct = +- with_local_level_if_principal (fun () -> type_exp env sfunct) +- ~post: generalize_structure_exp +- in +- let ty = instance funct.exp_type in +- (funct, [ty]) +- end +- ~post:(wrap_trace_gadt_instances env (lower_args TypeSet.empty)) ++ let funct = ++ with_local_level_generalize_structure_if_principal ++ (fun () -> type_exp env sfunct) ++ in ++ let ty = instance funct.exp_type in ++ wrap_trace_gadt_instances env (lower_args TypeSet.empty) ty; ++ funct + in + let funct, sargs = + let funct = type_sfunct sfunct in +@@ -3460,33 +3565,72 @@ + exp_type = ty_res; + exp_attributes = sexp.pexp_attributes; + exp_env = env } ++ end + | Pexp_match(sarg, caselist) -> + let arg = +- with_local_level (fun () -> type_exp env sarg) +- ~post:(may_lower_contravariant_then_generalize env) ++ with_local_level_generalize (fun () -> type_exp env sarg) ++ ~before_generalize:(may_lower_contravariant env) ++ in ++ let rec split_cases valc effc conts = function ++ | [] -> List.rev valc, List.rev effc, List.rev conts ++ | {pc_lhs = {ppat_desc=Ppat_effect(p1, p2)}} as c :: rest -> ++ split_cases valc ++ (({c with pc_lhs = p1}) :: effc) (p2 :: conts) rest ++ | c :: rest -> ++ split_cases (c :: valc) effc conts rest ++ in ++ let val_caselist, eff_caselist, eff_conts = ++ split_cases [] [] [] caselist ++ in ++ if val_caselist = [] && eff_caselist <> [] then ++ raise (Error (loc, env, No_value_clauses)); ++ let val_cases, partial = ++ type_cases Computation env arg.exp_type ty_expected_explained ++ ~check_if_total:true loc val_caselist ++ in ++ let eff_cases = ++ match eff_caselist with ++ | [] -> [] ++ | eff_caselist -> ++ type_effect_cases Value env ty_expected_explained loc eff_caselist ++ eff_conts + in +- let cases, partial = +- type_cases Computation env +- arg.exp_type ty_expected_explained +- ~check_if_total:true loc caselist in + if + List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs) +- cases ++ val_cases + then check_partial_application ~statement:false arg; + re { +- exp_desc = Texp_match(arg, cases, partial); ++ exp_desc = Texp_match(arg, val_cases, eff_cases, partial); + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_try(sbody, caselist) -> + let body = type_expect env sbody ty_expected_explained in +- let cases, _ = +- type_cases Value env +- Predef.type_exn ty_expected_explained +- ~check_if_total:false loc caselist in ++ let rec split_cases exnc effc conts = function ++ | [] -> List.rev exnc, List.rev effc, List.rev conts ++ | {pc_lhs = {ppat_desc=Ppat_effect(p1, p2)}} as c :: rest -> ++ split_cases exnc ++ (({c with pc_lhs = p1}) :: effc) (p2 :: conts) rest ++ | c :: rest -> ++ split_cases (c :: exnc) effc conts rest ++ in ++ let exn_caselist, eff_caselist, eff_conts = ++ split_cases [] [] [] caselist ++ in ++ let exn_cases, _ = ++ type_cases Value env Predef.type_exn ty_expected_explained ++ ~check_if_total:false loc exn_caselist ++ in ++ let eff_cases = ++ match eff_caselist with ++ | [] -> [] ++ | eff_caselist -> ++ type_effect_cases Value env ty_expected_explained loc eff_caselist ++ eff_conts ++ in + re { +- exp_desc = Texp_try(body, cases); ++ exp_desc = Texp_try(body, exn_cases, eff_cases); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; +@@ -3509,7 +3653,7 @@ + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_construct(lid, sarg) -> +- type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes ++ type_construct env ~sexp lid sarg ty_expected_explained + | Pexp_variant(l, sarg) -> + (* Keep sharing *) + let ty_expected1 = protect_expansion env ty_expected in +@@ -3558,9 +3702,8 @@ + None -> None + | Some sexp -> + let exp = +- with_local_level_if_principal ++ with_local_level_generalize_structure_if_principal + (fun () -> type_exp ~recarg env sexp) +- ~post: generalize_structure_exp + in + Some exp + in +@@ -3593,7 +3736,7 @@ + | (None | Some (_, _, false)), Some (_, p', _) -> + let decl = Env.find_type p' env in + let ty = +- with_local_level ~post:generalize_structure ++ with_local_level_generalize_structure + (fun () -> newconstr p' (instance_list decl.type_params)) + in + ty, opt_exp_opath +@@ -3699,7 +3842,7 @@ + type_label_access env srecord Env.Projection lid + in + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in +- unify_exp env record ty_res; ++ unify_exp ~sexp env record ty_res; + rue { + exp_desc = Texp_field(record, lid, label); + exp_loc = loc; exp_extra = []; +@@ -3713,7 +3856,7 @@ + if expected_type = None then newvar () else record.exp_type in + let (label_loc, label, newval) = + type_label_exp false env loc ty_record (lid, label, snewval) in +- unify_exp env record ty_record; ++ unify_exp ~sexp env record ty_record; + if label.lbl_mut = Immutable then + raise(Error(loc, env, Label_not_mutable lid.txt)); + rue { +@@ -3752,7 +3895,7 @@ + let ifso = type_expect env sifso ty_expected_explained in + let ifnot = type_expect env sifnot ty_expected_explained in + (* Keep sharing *) +- unify_exp env ifnot ifso.exp_type; ++ unify_exp ~sexp env ifnot ifso.exp_type; + re { + exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); + exp_loc = loc; exp_extra = []; +@@ -3799,7 +3942,7 @@ + val_attributes = []; + val_kind = Val_reg; + val_loc = loc; +- val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } env + ~check:(fun s -> Warnings.Unused_for_index s) + | _ -> +@@ -3838,9 +3981,8 @@ + } + | Pexp_send (e, {txt=met}) -> + let (obj,meth,typ) = +- with_local_level_if_principal ++ with_local_level_generalize_structure_if_principal + (fun () -> type_send env loc explanation e met) +- ~post:(fun (_,_,typ) -> generalize_structure typ) + in + let typ = + match get_desc typ with +@@ -3849,7 +3991,7 @@ + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc +- (Warnings.Not_principal "this use of a polymorphic method"); ++ (not_principal "this use of a polymorphic method"); + snd (instance_poly ~fixed:false tl ty) + | Tvar _ -> + let ty' = newvar () in +@@ -3944,7 +4086,7 @@ + | Pexp_letmodule(name, smodl, sbody) -> + let lv = get_current_level () in + let (id, pres, modl, _, body) = +- with_local_level begin fun () -> ++ with_local_level_generalize begin fun () -> + let modl, pres, id, new_env = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let modl, md_shape = !type_module env smodl in +@@ -3955,7 +4097,7 @@ + | _ -> Mp_present + in + let scope = create_scope () in +- let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in ++ let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let md_shape = Shape.set_uid_if_none md_shape md_uid in + let md = + { md_type = modl.mod_type; md_attributes = []; +@@ -3983,7 +4125,7 @@ + let body = type_expect new_env sbody ty_expected_explained in + (id, pres, modl, new_env, body) + end +- ~post: begin fun (_id, _pres, _modl, new_env, body) -> ++ ~before_generalize: begin fun (_id, _pres, _modl, new_env, body) -> + (* Ensure that local definitions do not leak. *) + (* required for implicit unpack *) + enforce_current_level new_env body.exp_type +@@ -4052,8 +4194,7 @@ + } + | Pexp_poly(sbody, sty) -> + let ty, cty = +- with_local_level_if_principal +- ~post:(fun (ty,_) -> generalize_structure ty) ++ with_local_level_generalize_structure_if_principal + begin fun () -> + match sty with None -> protect_expansion env ty_expected, None + | Some sty -> +@@ -4072,32 +4213,29 @@ + { exp with exp_type = instance ty } + | Tpoly (ty', tl) -> + (* One more level to generalize locally *) +- let (exp,_) = +- with_local_level begin fun () -> ++ let (exp, vars) = ++ with_local_level_generalize begin fun () -> + let vars, ty'' = +- with_local_level_if_principal ++ with_local_level_generalize_structure_if_principal + (fun () -> instance_poly ~fixed:true tl ty') +- ~post:(fun (_,ty'') -> generalize_structure ty'') + in + let exp = type_expect env sbody (mk_expected ty'') in + (exp, vars) + end +- ~post: begin fun (exp,vars) -> +- generalize_and_check_univars env "method" exp ty_expected vars +- end + in ++ check_univars env "method" exp ty_expected vars; + { exp with exp_type = instance ty } + | Tvar _ -> + let exp = type_exp env sbody in + let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in +- unify_exp env exp ty; ++ unify_exp ~sexp env exp ty; + exp + | _ -> assert false + in + re { exp with exp_extra = + (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } +- | Pexp_newtype({txt=name}, sbody) -> +- let body, ety = type_newtype loc env name (fun env -> ++ | Pexp_newtype(name, sbody) -> ++ let body, ety = type_newtype env name (fun env -> + let expr = type_exp env sbody in + expr, expr.exp_type) + in +@@ -4105,7 +4243,8 @@ + any new extra node in the typed AST. *) + rue { body with exp_loc = loc; exp_type = ety; + exp_extra = +- (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra } ++ (Texp_newtype name.txt, loc, sexp.pexp_attributes) :: body.exp_extra ++ } + | Pexp_pack m -> + let (p, fl) = + match get_desc (Ctype.expand_head env (instance ty_expected)) with +@@ -4116,7 +4255,7 @@ + < Btype.generic_level + then + Location.prerr_warning loc +- (Warnings.Not_principal "this module packing"); ++ (not_principal "this module packing"); + (p, fl) + | Tvar _ -> + raise (Error (loc, env, Cannot_infer_signature)) +@@ -4158,8 +4297,7 @@ + in + let op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops = +- with_local_level_iter_if_principal +- ~post:generalize_structure begin fun () -> ++ with_local_level_generalize_structure_if_principal begin fun () -> + let let_loc = slet.pbop_op.loc in + let op_path, op_desc = type_binding_op_ident env slet.pbop_op in + let op_type = instance op_desc.val_type in +@@ -4178,9 +4316,8 @@ + with Unify err -> + raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) + end; +- ((op_path, op_desc, op_type, spat_params, ty_params, +- ty_func_result, ty_result, ty_andops), +- [ty_andops; ty_params; ty_func_result; ty_result]) ++ (op_path, op_desc, op_type, spat_params, ty_params, ++ ty_func_result, ty_result, ty_andops) + end + in + let exp, ands = type_andops env slet.pbop_exp sands ty_andops in +@@ -4282,11 +4419,12 @@ + in + let arg, arg_type, gen = + let lv = get_current_level () in +- with_local_level begin fun () -> ++ with_local_level_generalize begin fun () -> + let arg, arg_type = type_without_constraint env in + arg, arg_type, generalizable lv arg_type + end +- ~post:(fun (_, arg_type, _) -> enforce_current_level env arg_type) ++ ~before_generalize: ++ (fun (_, arg_type, _) -> enforce_current_level env arg_type) + in + begin match !self_coercion, get_desc ty' with + | ((path, r) :: _, Tconstr (path', _, _)) +@@ -4309,7 +4447,7 @@ + force (); force' (); + if not gen && !Clflags.principal then + Location.prerr_warning loc +- (Warnings.Not_principal "this ground coercion"); ++ (not_principal "this ground coercion"); + with Subtype err -> + (* prerr_endline "coercion failed"; *) + raise (Error (loc, env, Not_subtype err)) +@@ -4326,14 +4464,13 @@ + (arg, ty', Texp_coerce (None, cty')) + | Some sty -> + let cty, ty, force, cty', ty', force' = +- with_local_level_iter ~post:generalize_structure begin fun () -> ++ with_local_level_generalize_structure begin fun () -> + let (cty, ty, force) = + Typetexp.transl_simple_type_delayed env sty + and (cty', ty', force') = + Typetexp.transl_simple_type_delayed env sty' + in +- ((cty, ty, force, cty', ty', force'), +- [ ty; ty' ]) ++ (cty, ty, force, cty', ty', force') + end + in + begin try +@@ -4348,10 +4485,9 @@ + and type_constraint env sty = + (* Pretend separate = true, 1% slowdown for lablgtk *) + let cty = +- with_local_level begin fun () -> ++ with_local_level_generalize_structure begin fun () -> + Typetexp.transl_simple_type env ~closed:false sty + end +- ~post:(fun cty -> generalize_structure cty.ctyp_type) + in + cty.ctyp_type, Texp_constraint cty + +@@ -4386,18 +4522,18 @@ + nodes for the newtype properly linked. + *) + and type_newtype +- : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr = +- fun loc env name type_body -> ++ : type a. _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr = ++ fun env { txt = name; loc = name_loc } type_body -> + let ty = + if Typetexp.valid_tyvar_name name then + newvar ~name () + else + newvar () + in +- (* Use [with_local_level] just for scoping *) +- with_local_level begin fun () -> ++ (* Use [with_local_level_generalize] just for scoping *) ++ with_local_level_generalize begin fun () -> + (* Create a fake abstract type declaration for [name]. *) +- let decl = new_local_type ~loc Definition in ++ let decl = new_local_type ~loc:name_loc Definition in + let scope = create_scope () in + let (id, new_env) = Env.enter_type ~scope name decl env in + +@@ -4418,6 +4554,7 @@ + replace ety; + (result, ety) + end ++ ~before_generalize:(fun (_,ety) -> enforce_current_level env ety) + + and type_ident env ?(recarg=Rejected) lid = + let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in +@@ -4466,7 +4603,7 @@ + and split_function_ty env ty_expected ~arg_label ~first ~in_function = + let { ty = ty_fun; explanation }, loc = in_function in + let separate = !Clflags.principal || Env.has_local_constraints env in +- with_local_level_iter_if separate ~post:generalize_structure begin fun () -> ++ with_local_level_generalize_structure_if separate begin fun () -> + let ty_arg, ty_res = + try filter_arrow env (instance ty_expected) arg_label + with Filter_arrow_failed err -> +@@ -4492,7 +4629,7 @@ + type_option tv + else ty_arg + in +- (ty_arg, ty_res), [ ty_arg; ty_res ] ++ (ty_arg, ty_res) + end + + (* Typecheck parameters one at a time followed by the body. Later parameters +@@ -4535,7 +4672,7 @@ + | { pparam_desc = Pparam_newtype newtype; pparam_loc = _ } :: rest -> + (* Check everything else in the scope of (type a). *) + let (params, body, newtypes, contains_gadt), exp_type = +- type_newtype loc env newtype.txt (fun env -> ++ type_newtype env newtype (fun env -> + let exp_type, params, body, newtypes, contains_gadt = + (* mimic the typing of Pexp_newtype by minting a new type var, + like [type_exp]. +@@ -4589,7 +4726,7 @@ + (* We don't make use of [case_data] here so we pass unit. *) + [ { pattern = pat; has_guard = false; needs_refute = false }, () ] + ~type_body:begin +- fun () pat ~ext_env ~ty_expected ~ty_infer:_ ++ fun () pat ~when_env:_ ~ext_env ~cont:_ ~ty_expected ~ty_infer:_ + ~contains_gadt:param_contains_gadt -> + let _, params, body, newtypes, suffix_contains_gadt = + type_function ext_env rest body_constraint body +@@ -4685,7 +4822,7 @@ + [type_argument] on the cases, and discard the cases' + inferred type in favor of the constrained type. (Function + cases aren't inferred, so [type_argument] would just call +- [type_expect] straightaway, so we do the same here.) ++ [type_expect] straight away, so we do the same here.) + - [type_without_constraint]: If there is just a coercion and + no constraint, call [type_exp] on the cases and surface the + cases' inferred type to [type_constraint_expect]. *) +@@ -4724,7 +4861,7 @@ + + and type_label_access env srecord usage lid = + let record = +- with_local_level_if_principal ~post:generalize_structure_exp ++ with_local_level_generalize_structure_if_principal + (fun () -> type_exp ~recarg:Allowed env srecord) + in + let ty_exp = record.exp_type in +@@ -4767,7 +4904,9 @@ + | [ e ] -> Some e + | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in + mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in +- let mk_cst cst = mk_exp_loc (Pexp_constant cst) in ++ let mk_cst cst = ++ mk_exp_loc (Pexp_constant {pconst_desc = cst; pconst_loc = loc}) ++ in + let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None)) + and mk_string str = mk_cst (Pconst_string (str, loc, None)) + and mk_char chr = mk_cst (Pconst_char chr) in +@@ -4993,22 +5132,15 @@ + (lid, label, sarg) = + (* Here also ty_expected may be at generic_level *) + let separate = !Clflags.principal || Env.has_local_constraints env in +- (* #4682: we try two type-checking approaches for [arg] using backtracking: +- - first try: we try with [ty_arg] as expected type; +- - second try; if that fails, we backtrack and try without +- *) +- let (vars, ty_arg, snap, arg) = +- (* try the first approach *) +- with_local_level begin fun () -> ++ let is_poly = label_is_poly label in ++ let (vars, arg) = ++ (* raise level to check univars *) ++ with_local_level_generalize_if is_poly begin fun () -> + let (vars, ty_arg) = +- with_local_level_iter_if separate begin fun () -> ++ with_local_level_generalize_structure_if separate begin fun () -> + let (vars, ty_arg, ty_res) = +- with_local_level_iter_if separate ~post:generalize_structure +- begin fun () -> +- let ((_, ty_arg, ty_res) as r) = +- instance_label ~fixed:true label in +- (r, [ty_arg; ty_res]) +- end ++ with_local_level_generalize_structure_if separate ++ (fun () -> instance_label ~fixed:true label) + in + begin try + unify env (instance ty_res) (instance ty_expected) +@@ -5017,9 +5149,8 @@ + end; + (* Instantiate so that we can generalize internal nodes *) + let ty_arg = instance ty_arg in +- ((vars, ty_arg), [ty_arg]) ++ (vars, ty_arg) + end +- ~post:generalize_structure + in + + if label.lbl_private = Private then +@@ -5027,45 +5158,12 @@ + raise (Error(loc, env, Private_type ty_expected)) + else + raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); +- let snap = if vars = [] then None else Some (Btype.snapshot ()) in +- let arg = type_argument env sarg ty_arg (instance ty_arg) in +- (vars, ty_arg, snap, arg) ++ (vars, type_argument env sarg ty_arg (instance ty_arg)) + end +- (* Note: there is no generalization logic here as could be expected, +- because it is part of the backtracking logic below. *) +- in +- let arg = +- try +- if (vars = []) then arg +- else begin +- (* We detect if the first try failed here, +- during generalization. *) +- if maybe_expansive arg then +- lower_contravariant env arg.exp_type; +- generalize_and_check_univars env "field value" arg label.lbl_arg vars; +- {arg with exp_type = instance arg.exp_type} +- end +- with first_try_exn when maybe_expansive arg -> try +- (* backtrack and try the second approach *) +- Option.iter Btype.backtrack snap; +- let arg = with_local_level (fun () -> type_exp env sarg) +- ~post:(fun arg -> lower_contravariant env arg.exp_type) +- in +- let arg = +- with_local_level begin fun () -> +- let arg = {arg with exp_type = instance arg.exp_type} in +- unify_exp env arg (instance ty_arg); +- arg +- end +- ~post: begin fun arg -> +- generalize_and_check_univars env "field value" arg label.lbl_arg vars +- end +- in +- {arg with exp_type = instance arg.exp_type} +- with Error (_, _, Less_general _) as e -> raise e +- | _ -> raise first_try_exn ++ ~before_generalize:(fun (_,arg) -> may_lower_contravariant env arg) + in +- (lid, label, arg) ++ if is_poly then check_univars env "field value" arg label.lbl_arg vars; ++ (lid, label, {arg with exp_type = instance arg.exp_type}) + + and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = + (* ty_expected' may be generic *) +@@ -5093,7 +5191,7 @@ + (* apply optional arguments when expected type is "" *) + (* we must be very careful about not breaking the semantics *) + let texp = +- with_local_level_if_principal ~post:generalize_structure_exp ++ with_local_level_generalize_structure_if_principal + (fun () -> type_exp env sarg) + in + let rec make_args args ty_fun = +@@ -5109,7 +5207,7 @@ + let args, ty_fun', simple_res = make_args [] texp.exp_type + and texp = {texp with exp_type = instance texp.exp_type} in + if not (simple_res || safe_expect) then begin +- unify_exp env texp ty_expected; ++ unify_exp ~sexp:sarg env texp ty_expected; + texp + end else begin + let warn = !Clflags.principal && +@@ -5120,7 +5218,7 @@ + Tarrow(Nolabel,ty_arg,ty_res,_) -> ty_arg, ty_res + | _ -> assert false + in +- unify_exp env {texp with exp_type = ty_fun} ty_expected; ++ unify_exp ~sexp:sarg env {texp with exp_type = ty_fun} ty_expected; + if args = [] then texp else + (* eta-expand to avoid side effects *) + let var_pair name ty = +@@ -5129,7 +5227,7 @@ + { val_type = ty; val_kind = Val_reg; + val_attributes = []; + val_loc = Location.none; +- val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let exp_env = Env.add_value id desc env in +@@ -5165,7 +5263,7 @@ + in + Location.prerr_warning texp.exp_loc + (Warnings.Eliminated_optional_arguments +- (List.map (fun (l, _) -> Printtyp.string_of_label l) args)); ++ (List.map (fun (l, _) -> Asttypes.string_of_label l) args)); + if warn then Location.prerr_warning texp.exp_loc + (Warnings.Non_principal_labels "eliminated optional argument"); + (* let-expand to have side effects *) +@@ -5180,7 +5278,7 @@ + | None -> + let texp = type_expect ?recarg env sarg + (mk_expected ?explanation ty_expected') in +- unify_exp env texp ty_expected; ++ unify_exp ~sexp:sarg env texp ty_expected; + texp + + and type_application env funct sargs = +@@ -5245,7 +5343,7 @@ + let arg () = + let arg = type_expect env sarg (mk_expected ty_arg) in + if is_optional lbl then +- unify_exp env arg (type_option(newvar())); ++ unify_exp ~sexp:sarg env arg (type_option(newvar())); + arg + in + (ty_res, (lbl, Some (arg, Some sarg.pexp_loc)) :: typed_args) +@@ -5262,7 +5360,7 @@ + (Location.prerr_warning + funct.exp_loc + (Warnings.Labels_omitted +- (List.map Printtyp.string_of_label ++ (List.map Asttypes.string_of_label + (List.filter ((<>) Nolabel) labels))); + true) + end +@@ -5309,7 +5407,7 @@ + (fun () -> type_argument env sarg ty ty0) + else begin + may_warn sarg.pexp_loc +- (Warnings.Not_principal "using an optional argument here"); ++ (not_principal "using an optional argument here"); + (fun () -> option_some env (type_argument env sarg + (extract_option_type env ty) + (extract_option_type env ty0))) +@@ -5348,11 +5446,11 @@ + | Some (l', sarg, commuted, remaining_sargs) -> + if commuted then begin + may_warn sarg.pexp_loc +- (Warnings.Not_principal "commuting this argument") ++ (not_principal "commuting this argument") + end; + if not optional && is_optional l' then + Location.prerr_warning sarg.pexp_loc +- (Warnings.Nonoptional_label (Printtyp.string_of_label l)); ++ (Warnings.Nonoptional_label (Asttypes.string_of_label l)); + remaining_sargs, Some (use_arg sarg l', Some sarg.pexp_loc) + | None -> + sargs, +@@ -5376,22 +5474,19 @@ + (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true + with Filter_arrow_failed _ -> false) + in +- (* Extra scope to check for non-returning functions *) +- with_local_level begin fun () -> +- match sargs with +- | (* Special case for ignore: avoid discarding warning *) +- [Nolabel, sarg] when is_ignore funct -> +- let ty_arg, ty_res = +- filter_arrow env (instance funct.exp_type) Nolabel in +- let exp = type_expect env sarg (mk_expected ty_arg) in +- check_partial_application ~statement:false exp; +- ([Nolabel, Some exp], ty_res) +- | _ -> +- let ty = funct.exp_type in +- type_args [] ty (instance ty) sargs +- end ++ match sargs with ++ | (* Special case for ignore: avoid discarding warning *) ++ [Nolabel, sarg] when is_ignore funct -> ++ let ty_arg, ty_res = ++ filter_arrow env (instance funct.exp_type) Nolabel in ++ let exp = type_expect env sarg (mk_expected ty_arg) in ++ check_partial_application ~statement:false exp; ++ ([Nolabel, Some exp], ty_res) ++ | _ -> ++ let ty = funct.exp_type in ++ type_args [] ty (instance ty) sargs + +-and type_construct env loc lid sarg ty_expected_explained attrs = ++and type_construct env ~sexp lid sarg ty_expected_explained = + let { ty = ty_expected; explanation } = ty_expected_explained in + let expected_type = + match extract_concrete_variant env ty_expected with +@@ -5402,7 +5497,7 @@ + let srt = wrong_kind_sort_of_constructor lid.txt in + let ctx = Expression explanation in + let error = Wrong_expected_kind(srt, ctx, ty_expected) in +- raise (Error (loc, env, error)) ++ raise (Error (sexp.pexp_loc, env, error)) + in + let constrs = + Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env +@@ -5416,37 +5511,36 @@ + match sarg with + None -> [] + | Some {pexp_desc = Pexp_tuple sel} when +- constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs ++ constr.cstr_arity > 1 ++ || Builtin_attributes.explicit_arity sexp.pexp_attributes + -> sel + | Some se -> [se] in + if List.length sargs <> constr.cstr_arity then +- raise(Error(loc, env, Constructor_arity_mismatch +- (lid.txt, constr.cstr_arity, List.length sargs))); ++ raise(Error(sexp.pexp_loc, env, ++ Constructor_arity_mismatch ++ (lid.txt, constr.cstr_arity, List.length sargs))); + let separate = !Clflags.principal || Env.has_local_constraints env in + let ty_args, ty_res, texp = +- with_local_level_iter_if separate ~post:generalize_structure begin fun () -> ++ with_local_level_generalize_structure_if separate begin fun () -> + let ty_args, ty_res, texp = +- with_local_level_if separate begin fun () -> ++ with_local_level_generalize_structure_if separate begin fun () -> + let (ty_args, ty_res, _) = + instance_constructor Keep_existentials_flexible constr + in + let texp = + re { + exp_desc = Texp_construct(lid, constr, []); +- exp_loc = loc; exp_extra = []; ++ exp_loc = sexp.pexp_loc; exp_extra = []; + exp_type = ty_res; +- exp_attributes = attrs; ++ exp_attributes = sexp.pexp_attributes; + exp_env = env } in + (ty_args, ty_res, texp) + end +- ~post: begin fun (_, ty_res, texp) -> +- generalize_structure ty_res; +- with_explanation explanation (fun () -> +- unify_exp env {texp with exp_type = instance ty_res} +- (instance ty_expected)); +- end + in +- ((ty_args, ty_res, texp), ty_res::ty_args) ++ with_explanation explanation (fun () -> ++ unify_exp ~sexp env {texp with exp_type = instance ty_res} ++ (instance ty_expected)); ++ (ty_args, ty_res, texp) + end + in + let ty_args0, ty_res = +@@ -5455,7 +5549,7 @@ + | _ -> assert false + in + let texp = {texp with exp_type = ty_res} in +- if not separate then unify_exp env texp (instance ty_expected); ++ if not separate then unify_exp ~sexp env texp (instance ty_expected); + let recarg = + match constr.cstr_inlined with + | None -> Rejected +@@ -5466,7 +5560,7 @@ + Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> + Required + | _ -> +- raise (Error(loc, env, Inlined_record_expected)) ++ raise (Error(sexp.pexp_loc, env, Inlined_record_expected)) + end + in + let args = +@@ -5475,9 +5569,9 @@ + if constr.cstr_private = Private then + begin match constr.cstr_tag with + | Cstr_extension _ -> +- raise(Error(loc, env, Private_constructor (constr, ty_res))) ++ raise(Error(sexp.pexp_loc, env, Private_constructor (constr, ty_res))) + | Cstr_constant _ | Cstr_block _ | Cstr_unboxed -> +- raise (Error(loc, env, Private_type ty_res)); ++ raise (Error(sexp.pexp_loc, env, Private_type ty_res)); + end; + (* NOTE: shouldn't we call "re" on this final expression? -- AF *) + { texp with +@@ -5501,24 +5595,24 @@ + | _ -> false + in + (* Raise the current level to detect non-returning functions *) +- let exp = with_local_level (fun () -> type_exp env sexp) in +- let subexp = final_subexpression exp in +- let ty = expand_head env exp.exp_type in +- if is_Tvar ty +- && get_level ty > get_current_level () +- && not (allow_polymorphic subexp) then +- Location.prerr_warning +- subexp.exp_loc +- Warnings.Nonreturning_statement; +- if !Clflags.strict_sequence then +- let expected_ty = instance Predef.type_unit in +- with_explanation explanation (fun () -> +- unify_exp env exp expected_ty); +- exp +- else begin +- check_partial_application ~statement:true exp; +- enforce_current_level env ty; +- exp ++ with_local_level_generalize (fun () -> type_exp env sexp) ++ ~before_generalize: begin fun exp -> ++ let subexp = final_subexpression exp in ++ let ty = expand_head env exp.exp_type in ++ if is_Tvar ty ++ && get_level ty > get_current_level () ++ && not (allow_polymorphic subexp) then ++ Location.prerr_warning ++ subexp.exp_loc ++ Warnings.Nonreturning_statement; ++ if !Clflags.strict_sequence then ++ let expected_ty = instance Predef.type_unit in ++ with_explanation explanation (fun () -> ++ unify_exp ~sexp env exp expected_ty) ++ else begin ++ check_partial_application ~statement:true exp; ++ enforce_current_level env ty ++ end + end + + (* Most of the arguments are the same as [type_cases]. +@@ -5535,20 +5629,22 @@ + *) + and map_half_typed_cases + : type k ret case_data. +- ?additional_checks_for_split_cases:((_ * ret) list -> unit) ++ ?additional_checks_for_split_cases:((_ * ret) list -> unit) -> ?conts:_ + -> k pattern_category -> _ -> _ -> _ -> _ + -> (untyped_case * case_data) list + -> type_body:( + case_data + -> k general_pattern (* the typed pattern *) +- -> ext_env:_ (* environment with module variables / pattern variables *) ++ -> when_env:_ (* environment with module/pattern variables *) ++ -> ext_env:_ (* when_env + continuation var*) ++ -> cont:_ + -> ty_expected:_ (* type to check body in scope of *) + -> ty_infer:_ (* type to infer for body *) + -> contains_gadt:_ (* whether the pattern contains a GADT *) + -> ret) + -> check_if_total:bool (* if false, assume Partial right away *) + -> ret list * partial +- = fun ?additional_checks_for_split_cases ++ = fun ?additional_checks_for_split_cases ?conts + category env ty_arg ty_res loc caselist ~type_body ~check_if_total -> + (* ty_arg is _fully_ generalized *) + let patterns = List.map (fun ((x : untyped_case), _) -> x.pattern) caselist in +@@ -5559,7 +5655,7 @@ + let create_inner_level = may_contain_gadts || may_contain_modules in + let ty_arg = + if (may_contain_gadts || erase_either) && not !Clflags.principal +- then correct_levels ty_arg else ty_arg ++ then duplicate_type ty_arg else ty_arg + in + let rec is_var spat = + match spat.ppat_desc with +@@ -5589,24 +5685,29 @@ + if erase_either + then Some false else None + in ++ let map_conts f conts caselist = match conts with ++ | None -> List.map (fun c -> f c None) caselist ++ | Some conts -> List.map2 f caselist conts ++ in + let half_typed_cases, ty_res, do_copy_types, ty_arg' = + (* propagation of the argument *) +- with_local_level begin fun () -> ++ with_local_level_generalize begin fun () -> + let pattern_force = ref [] in + (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_arg; *) + let half_typed_cases = +- List.map +- (fun ({ Parmatch.pattern; _ } as untyped_case, case_data) -> ++ map_conts ++ (fun ({ Parmatch.pattern; _ } as untyped_case, case_data) cont -> + let htc = +- with_local_level_if_principal begin fun () -> ++ with_local_level_generalize_structure_if_principal begin fun () -> + let ty_arg = + (* propagation of pattern *) +- with_local_level ~post:generalize_structure ++ with_local_level_generalize_structure + (fun () -> instance ?partial:take_partial_instance ty_arg) + in + let (pat, ext_env, force, pvs, mvs) = +- type_pattern category ~lev env pattern ty_arg allow_modules ++ type_pattern ?cont category ~lev env pattern ty_arg ++ allow_modules + in + pattern_force := force @ !pattern_force; + { typed_pat = pat; +@@ -5619,9 +5720,6 @@ + contains_gadt = contains_gadt (as_comp_pattern category pat); + } + end +- ~post: begin fun htc -> +- iter_pattern_variables_type generalize_structure htc.pat_vars; +- end + in + (* Ensure that no ambivalent pattern type escapes its branch *) + check_scope_escape htc.typed_pat.pat_loc env outer_level +@@ -5629,7 +5727,7 @@ + let pat = htc.typed_pat in + {htc with typed_pat = { pat with pat_type = instance pat.pat_type }} + ) +- caselist in ++ conts caselist in + let patl = + List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in + let does_contain_gadt = +@@ -5637,7 +5735,7 @@ + in + let ty_res, do_copy_types = + if does_contain_gadt && not !Clflags.principal then +- correct_levels ty_res, Env.make_copy_of_types env ++ duplicate_type ty_res, Env.make_copy_of_types env + else ty_res, (fun env -> env) + in + (* Unify all cases (delayed to keep it order-free) *) +@@ -5663,20 +5761,15 @@ + ) half_typed_cases; + (half_typed_cases, ty_res, do_copy_types, ty_arg') + end +- ~post: begin fun (half_typed_cases, _, _, ty_arg') -> +- generalize ty_arg'; +- List.iter (fun { pat_vars; _ } -> +- iter_pattern_variables_type generalize pat_vars +- ) half_typed_cases +- end + in + (* type bodies *) + let ty_res' = instance ty_res in ++ (* Why is it needed to keep the level of result raised ? *) + let result = with_local_level_if_principal ~post:ignore begin fun () -> +- List.map ++ map_conts + (fun { typed_pat = pat; branch_env = ext_env; +- pat_vars = pvs; module_vars = mvs; +- case_data; contains_gadt; _ } ++ pat_vars = pvs; module_vars = mvs; ++ case_data; contains_gadt; _ } cont + -> + let ext_env = + if contains_gadt then +@@ -5688,21 +5781,24 @@ + branch environments by adding the variables (and module variables) + from the patterns. + *) +- let ext_env = +- add_pattern_variables ext_env pvs ++ let cont_vars, pvs = ++ List.partition (fun pv -> pv.pv_kind = Continuation_var) pvs in ++ let add_pattern_vars = add_pattern_variables + ~check:(fun s -> Warnings.Unused_var_strict s) + ~check_as:(fun s -> Warnings.Unused_var s) + in +- let ext_env = add_module_variables ext_env mvs in ++ let when_env = add_pattern_vars ext_env pvs in ++ let when_env = add_module_variables when_env mvs in ++ let ext_env = add_pattern_vars when_env cont_vars in + let ty_expected = + if contains_gadt && not !Clflags.principal then + (* Take a generic copy of [ty_res] again to allow propagation of + type information from preceding branches *) +- correct_levels ty_res ++ duplicate_type ty_res + else ty_res in +- type_body case_data pat ~ext_env ~ty_expected ~ty_infer:ty_res' +- ~contains_gadt) +- half_typed_cases ++ type_body case_data pat ~when_env ~ext_env ~cont ~ty_expected ++ ~ty_infer:ty_res' ~contains_gadt) ++ conts half_typed_cases + end in + let do_init = may_contain_gadts || needs_exhaust_check in + let ty_arg_check = +@@ -5773,11 +5869,11 @@ + + (* Typing of match cases *) + and type_cases +- : type k . k pattern_category -> +- _ -> _ -> _ -> check_if_total:bool -> _ -> Parsetree.case list -> +- k case list * partial ++ : type k . k pattern_category -> _ -> _ -> _ -> ?conts:_ -> ++ check_if_total:bool -> _ -> Parsetree.case list -> ++ k case list * partial + = fun category env +- ty_arg ty_res_explained ~check_if_total loc caselist -> ++ ty_arg ty_res_explained ?conts ~check_if_total loc caselist -> + let { ty = ty_res; explanation } = ty_res_explained in + let caselist = + List.map (fun case -> Parmatch.untyped_case case, case) caselist +@@ -5786,16 +5882,24 @@ + is to typecheck the guards and the cases, and then to check for some + warnings that can fire in the presence of guards. + *) +- map_half_typed_cases category env ty_arg ty_res loc caselist ~check_if_total ++ map_half_typed_cases ?conts category env ty_arg ty_res loc caselist ++ ~check_if_total + ~type_body:begin +- fun { pc_guard; pc_rhs } pat ~ext_env ~ty_expected ~ty_infer +- ~contains_gadt:_ -> ++ fun { pc_guard; pc_rhs } pat ~when_env ~ext_env ~cont ~ty_expected ++ ~ty_infer ~contains_gadt:_ -> ++ let cont = Option.map (fun (id,_) -> id) cont in + let guard = + match pc_guard with + | None -> None + | Some scond -> ++ (* It is crucial that the continuation is not used in the ++ `when' expression as the extent of the continuation is ++ yet to be determined. We make the continuation ++ inaccessible by typing the `when' expression using the ++ environment `ext_env' which does not bind the ++ continuation variable. *) + Some +- (type_expect ext_env scond ++ (type_expect when_env scond + (mk_expected ~explanation:When_guard Predef.type_bool)) + in + let exp = +@@ -5803,6 +5907,7 @@ + in + { + c_lhs = pat; ++ c_cont = cont; + c_guard = guard; + c_rhs = {exp with exp_type = ty_infer} + } +@@ -5840,6 +5945,33 @@ + cases, partial, ty_fun + end + ++and type_effect_cases ++ : type k . k pattern_category -> _ -> _ -> _ -> Parsetree.case list -> _ ++ -> k case list ++ = fun category env ty_res_explained loc caselist conts -> ++ let { ty = ty_res; explanation = _ } = ty_res_explained in ++ let _ = newvar () in ++ (* remember original level *) ++ with_local_level begin fun () -> ++ (* Create a locally type abstract type for effect type. *) ++ let new_env, ty_arg, ty_cont = ++ let decl = Ctype.new_local_type ~loc Definition in ++ let scope = create_scope () in ++ let name = Ctype.get_new_abstract_name env "%eff" in ++ let id = Ident.create_scoped ~scope name in ++ let new_env = Env.add_type ~check:false id decl env in ++ let ty_eff = newgenty (Tconstr (Path.Pident id,[],ref Mnil)) in ++ new_env, ++ Predef.type_eff ty_eff, ++ Predef.type_continuation ty_eff ty_res ++ in ++ let conts = List.map (type_continuation_pat env ty_cont) conts in ++ let cases, _ = type_cases category new_env ty_arg ++ ty_res_explained ~conts ~check_if_total:false loc caselist ++ in ++ cases ++ end ++ + (* Typing of let bindings *) + + and type_let ?check ?check_strict +@@ -5848,11 +5980,11 @@ + let attrs_list = List.map fst spatl in + let is_recursive = (rec_flag = Recursive) in + +- let (pat_list, exp_list, new_env, mvs, _pvs) = +- with_local_level begin fun () -> ++ let (pat_list, exp_list, new_env, mvs) = ++ with_local_level_generalize begin fun () -> + if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); + let (pat_list, new_env, force, pvs, mvs) = +- with_local_level_if_principal begin fun () -> ++ with_local_level_generalize_structure_if_principal begin fun () -> + let nvs = List.map (fun _ -> newvar ()) spatl in + let (pat_list, _new_env, _force, _pvs, _mvs as res) = + type_pattern_list +@@ -5882,11 +6014,6 @@ + pat_list; + res + end +- ~post: begin fun (pat_list, _, _, pvs, _) -> +- (* Generalize the structure *) +- iter_pattern_variables_type generalize_structure pvs; +- List.iter (fun pat -> generalize_structure pat.pat_type) pat_list +- end + in + (* Note [add_module_variables after checking expressions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@@ -5923,8 +6050,7 @@ + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + let vars, ty' = +- with_local_level_if_principal +- ~post:(fun (_,ty') -> generalize_structure ty') ++ with_local_level_generalize_structure_if_principal + (fun () -> instance_poly ~keep_names:true ~fixed:true tl ty) + in + let exp = +@@ -5950,37 +6076,21 @@ + ) + pat_list + (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list); +- (pat_list, exp_list, new_env, mvs, +- List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs) ++ (pat_list, exp_list, new_env, mvs) + end +- ~post: begin fun (pat_list, exp_list, _, _, pvs) -> +- List.iter2 +- (fun pat (exp, _) -> +- if maybe_expansive exp then lower_contravariant env pat.pat_type) +- pat_list exp_list; +- iter_pattern_variables_type generalize pvs; +- List.iter2 +- (fun pat (exp, vars) -> +- match vars with +- | None -> +- (* We generalize expressions even if they are not bound to a variable +- and do not have an expliclit polymorphic type annotation. This is +- not needed in general, however those types may be shown by the +- interactive toplevel, for example: +- {[ +- let _ = Array.get;; +- - : 'a array -> int -> 'a = +- ]} +- so we do it anyway. *) +- generalize exp.exp_type +- | Some vars -> +- if maybe_expansive exp then +- lower_contravariant env exp.exp_type; +- generalize_and_check_univars env "definition" +- exp pat.pat_type vars) ++ ~before_generalize: begin fun (pat_list, exp_list, _, _) -> ++ List.iter2 (fun pat (exp, vars) -> ++ if maybe_expansive exp then begin ++ lower_contravariant env pat.pat_type; ++ if vars <> None then lower_contravariant env exp.exp_type ++ end) + pat_list exp_list + end + in ++ List.iter2 ++ (fun pat (exp, vars) -> ++ Option.iter (check_univars env "definition" exp pat.pat_type) vars) ++ pat_list exp_list; + let l = List.combine pat_list exp_list in + let l = + List.map2 +@@ -6135,7 +6245,7 @@ + | [] -> type_expect env let_sarg (mk_expected expected_ty), [] + | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest -> + let op_path, op_desc, op_type, ty_arg, ty_rest, ty_result = +- with_local_level_iter_if_principal begin fun () -> ++ with_local_level_generalize_structure_if_principal begin fun () -> + let op_path, op_desc = type_binding_op_ident env sop in + let op_type = instance op_desc.val_type in + let ty_arg = newvar () in +@@ -6150,10 +6260,8 @@ + with Unify err -> + raise(Error(sop.loc, env, Andop_type_clash(sop.txt, err))) + end; +- ((op_path, op_desc, op_type, ty_arg, ty_rest, ty_result), +- [ty_rest; ty_arg; ty_result]) ++ (op_path, op_desc, op_type, ty_arg, ty_rest, ty_result) + end +- ~post:generalize_structure + in + let let_arg, rest = loop env let_sarg rest ty_rest in + let exp = type_expect env sexp (mk_expected ty_arg) in +@@ -6279,11 +6387,11 @@ + + let type_expression env sexp = + let exp = +- with_local_level begin fun () -> ++ with_local_level_generalize begin fun () -> + Typetexp.TyVarEnv.reset(); + type_exp env sexp + end +- ~post:(may_lower_contravariant_then_generalize env) ++ ~before_generalize:(may_lower_contravariant env) + in + match sexp.pexp_desc with + Pexp_ident lid -> +@@ -6303,7 +6411,9 @@ + let spellcheck_idents ppf unbound valid_idents = + spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) + +-open Format ++open Format_doc ++module Fmt = Format_doc ++module Printtyp = Printtyp.Doc + + let longident = Printtyp.longident + +@@ -6314,11 +6424,49 @@ + | _ -> None + )) + ++(** More precise denomination for type errors. Used by messages: ++ ++ - [This ...] ++ - [The "foo" ...] *) ++let pp_exp_denom ppf pexp = ++ let d = pp_print_string ppf in ++ let d_expression = fprintf ppf "%a expression" Style.inline_code in ++ match pexp.pexp_desc with ++ | Pexp_constant _ -> d "constant" ++ | Pexp_ident _ -> d "value" ++ | Pexp_construct _ | Pexp_variant _ -> d "constructor" ++ | Pexp_field _ -> d "field access" ++ | Pexp_send _ -> d "method call" ++ | Pexp_while _ -> d_expression "while" ++ | Pexp_for _ -> d_expression "for" ++ | Pexp_ifthenelse _ -> d_expression "if-then-else" ++ | Pexp_match _ -> d_expression "match" ++ | Pexp_try _ -> d_expression "try-with" ++ | _ -> d "expression" ++ ++(** Implements the "This expression" message, printing the expression if it ++ should be according to {!Parsetree.Doc.nominal_exp}. *) ++let report_this_pexp_has_type denom ppf exp = ++ let denom ppf = ++ match denom, exp with ++ | Some d, _ -> fprintf ppf "%s" d ++ | None, Some exp -> pp_exp_denom ppf exp ++ | None, None -> fprintf ppf "expression" ++ in ++ let nexp = Option.bind exp Pprintast.Doc.nominal_exp in ++ match nexp with ++ | Some nexp -> ++ fprintf ppf "The %t %a has type" denom (Style.as_inline_code pp_doc) nexp ++ | _ -> fprintf ppf "This %t has type" denom ++ ++let report_this_texp_has_type denom ppf texp = ++ report_this_pexp_has_type denom ppf (Some (Untypeast.untype_expression texp)) ++ + (* Hint on type error on integer literals + To avoid confusion, it is disabled on float literals + and when the expected type is `int` *) + let report_literal_type_constraint expected_type const = +- let const_str = match const with ++ let const_str = match const.pconst_desc with + | Pconst_integer (s, _) -> Some s + | _ -> None + in +@@ -6333,7 +6481,7 @@ + Some '.' + else None + in +- let pp_const ppf (c,s) = Format.fprintf ppf "%s%c" c s in ++ let pp_const ppf (c,s) = Fmt.fprintf ppf "%s%c" c s in + match const_str, suffix with + | Some c, Some s -> [ + Location.msg +@@ -6364,17 +6512,21 @@ + + let report_expr_type_clash_hints exp diff = + match exp with +- | Some (Pexp_constant const) -> report_literal_type_constraint const diff +- | Some (Pexp_apply _) -> report_partial_application diff +- | _ -> [] ++ | Some exp -> begin ++ match exp.pexp_desc with ++ | Pexp_constant const -> report_literal_type_constraint const diff ++ | Pexp_apply _ -> report_partial_application diff ++ | _ -> [] ++ end ++ | None -> [] + + let report_pattern_type_clash_hints pat diff = + match pat with + | Some (Ppat_constant const) -> report_literal_type_constraint const diff + | _ -> [] + +-let report_type_expected_explanation expl ppf = +- let because expl_str = fprintf ppf "@ because it is in %s" expl_str in ++let report_type_expected_explanation expl = ++ let because expl_str = doc_printf "@ because it is in %s" expl_str in + match expl with + | If_conditional -> + because "the condition of an if-statement" +@@ -6397,25 +6549,18 @@ + | When_guard -> + because "a when-guard" + +-let report_type_expected_explanation_opt expl ppf = ++let report_type_expected_explanation_opt expl = + match expl with +- | None -> () +- | Some expl -> report_type_expected_explanation expl ppf ++ | None -> Format_doc.Doc.empty ++ | Some expl -> report_type_expected_explanation expl + + let report_unification_error ~loc ?sub env err + ?type_expected_explanation txt1 txt2 = + Location.error_of_printer ~loc ?sub (fun ppf () -> +- Printtyp.report_unification_error ppf env err ++ Errortrace_report.unification ppf env err + ?type_expected_explanation txt1 txt2 + ) () + +-let report_this_function ppf funct = +- if Typedtree.exp_is_nominal funct then +- let pexp = Untypeast.untype_expression funct in +- Format.fprintf ppf "The function %a" +- (Style.as_inline_code Pprintast.expression) pexp +- else Format.fprintf ppf "This function" +- + let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc = + let open Location in +@@ -6442,9 +6587,12 @@ + msg ~loc:extra_arg_loc "This extra argument is not expected."; + ] in + errorf ~loc:app_loc ~sub +- "@[@[<2>%a has type@ %a@]\ ++ "@[@[<2>%a@ %a@]\ + @ It is applied to too many arguments@]" +- report_this_function funct Printtyp.type_expr func_ty ++ (report_this_texp_has_type (Some "function")) funct ++ Printtyp.type_expr func_ty ++ ++let msg = Fmt.doc_printf + + let report_error ~loc env = function + | Constructor_arity_mismatch(lid, expected, provided) -> +@@ -6454,27 +6602,20 @@ + (Style.as_inline_code longident) lid expected provided + | Label_mismatch(lid, err) -> + report_unification_error ~loc env err +- (function ppf -> +- fprintf ppf "The record field %a@ belongs to the type" ++ (msg "The record field %a@ belongs to the type" + (Style.as_inline_code longident) lid) +- (function ppf -> +- fprintf ppf "but is mixed here with fields of type") ++ (msg "but is mixed here with fields of type") + | Pattern_type_clash (err, pat) -> + let diff = type_clash_of_trace err.trace in + let sub = report_pattern_type_clash_hints pat diff in + report_unification_error ~loc ~sub env err +- (function ppf -> +- fprintf ppf "This pattern matches values of type") +- (function ppf -> +- fprintf ppf "but a pattern was expected which matches values of \ +- type"); ++ (msg "This pattern matches values of type") ++ (msg "but a pattern was expected which matches values of type"); + | Or_pattern_type_clash (id, err) -> + report_unification_error ~loc env err +- (function ppf -> +- fprintf ppf "The variable %a on the left-hand side of this \ ++ (msg "The variable %a on the left-hand side of this \ + or-pattern has type" Style.inline_code (Ident.name id)) +- (function ppf -> +- fprintf ppf "but on the right-hand side it has type") ++ (msg "but on the right-hand side it has type") + | Multiply_bound_variable name -> + Location.errorf ~loc + "Variable %a is bound several times in this matching" +@@ -6494,10 +6635,8 @@ + report_unification_error ~loc ~sub env err + ~type_expected_explanation: + (report_type_expected_explanation_opt explanation) +- (function ppf -> +- fprintf ppf "This expression has type") +- (function ppf -> +- fprintf ppf "but an expression was expected of type"); ++ (msg "%a" (report_this_pexp_has_type None) exp) ++ (msg "but an expression was expected of type"); + | Function_arity_type_clash { + syntactic_arity; type_constraint; trace = { trace }; + } -> +@@ -6596,10 +6735,10 @@ + (Style.as_inline_code Printtyp.type_path) type_path; + end else begin + fprintf ppf +- "@[@[<2>%s type@ %a%t@]@ \ ++ "@[@[<2>%s type@ %a%a@]@ \ + There is no %s %a within type %a@]" + eorp (Style.as_inline_code Printtyp.type_expr) ty +- (report_type_expected_explanation_opt explanation) ++ pp_doc (report_type_expected_explanation_opt explanation) + (Datatype_kind.label_name kind) + Style.inline_code name.txt + (Style.as_inline_code Printtyp.type_path) type_path; +@@ -6610,18 +6749,15 @@ + let type_name = Datatype_kind.type_name kind in + let name = Datatype_kind.label_name kind in + Location.error_of_printer ~loc (fun ppf () -> +- Printtyp.report_ambiguous_type_error ppf env tp tpl +- (function ppf -> +- fprintf ppf "The %s %a@ belongs to the %s type" ++ Errortrace_report.ambiguous_type ppf env tp tpl ++ (msg "The %s %a@ belongs to the %s type" + name (Style.as_inline_code longident) lid + type_name) +- (function ppf -> +- fprintf ppf "The %s %a@ belongs to one of the following %s types:" ++ (msg "The %s %a@ belongs to one of the following %s types:" + name (Style.as_inline_code longident) lid type_name) +- (function ppf -> +- fprintf ppf "but a %s was expected belonging to the %s type" ++ (msg "but a %s was expected belonging to the %s type" + name type_name) +- ) () ++ ) () + | Invalid_format msg -> + Location.errorf ~loc "%s" msg + | Not_an_object (ty, explanation) -> +@@ -6629,7 +6765,7 @@ + fprintf ppf "This expression is not an object;@ \ + it has type %a" + (Style.as_inline_code Printtyp.type_expr) ty; +- report_type_expected_explanation_opt explanation ppf ++ pp_doc ppf @@ report_type_expected_explanation_opt explanation + ) () + | Undefined_method (ty, me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> +@@ -6662,7 +6798,7 @@ + Style.inline_code v + | Not_subtype err -> + Location.error_of_printer ~loc (fun ppf () -> +- Printtyp.Subtype.report_error ppf env err "is not a subtype of" ++ Errortrace_report.subtype ppf env err "is not a subtype of" + ) () + | Outside_class -> + Location.errorf ~loc +@@ -6673,14 +6809,15 @@ + Style.inline_code v + | Coercion_failure (ty_exp, err, b) -> + Location.error_of_printer ~loc (fun ppf () -> +- Printtyp.report_unification_error ppf env err +- (function ppf -> +- let ty_exp = Printtyp.prepare_expansion ty_exp in +- fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ +- it has type" +- (Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp) +- (function ppf -> +- fprintf ppf "but is here used with type"); ++ let intro = ++ let ty_exp = Out_type.prepare_expansion ty_exp in ++ doc_printf "This expression cannot be coerced to type@;<1 2>%a;@ \ ++ it has type" ++ (Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp ++ in ++ Errortrace_report.unification ppf env err ++ intro ++ (Fmt.doc_printf "but is here used with type"); + if b then + fprintf ppf + ".@.@[This simple coercion was not fully general.@ \ +@@ -6691,15 +6828,15 @@ + | Not_a_function (ty, explanation) -> + Location.errorf ~loc + "This expression should not be a function,@ \ +- the expected type is@ %a%t" ++ the expected type is@ %a%a" + (Style.as_inline_code Printtyp.type_expr) ty +- (report_type_expected_explanation_opt explanation) ++ pp_doc (report_type_expected_explanation_opt explanation) + | Too_many_arguments (ty, explanation) -> + Location.errorf ~loc + "This function expects too many arguments,@ \ +- it should have type@ %a%t" ++ it should have type@ %a%a" + (Style.as_inline_code Printtyp.type_expr) ty +- (report_type_expected_explanation_opt explanation) ++ pp_doc (report_type_expected_explanation_opt explanation) + | Abstract_wrong_label {got; expected; expected_type; explanation} -> + let label ~long ppf = function + | Nolabel -> fprintf ppf "unlabeled" +@@ -6714,10 +6851,10 @@ + | _ -> false + in + Location.errorf ~loc +- "@[@[<2>This function should have type@ %a%t@]@,\ ++ "@[@[<2>This function should have type@ %a%a@]@,\ + @[but its first argument is %a@ instead of %s%a@]@]" + (Style.as_inline_code Printtyp.type_expr) expected_type +- (report_type_expected_explanation_opt explanation) ++ pp_doc (report_type_expected_explanation_opt explanation) + (label ~long:true) got + (if second_long then "being " else "") + (label ~long:second_long) expected +@@ -6750,8 +6887,8 @@ + This is only allowed when the real type is known." + | Less_general (kind, err) -> + report_unification_error ~loc env err +- (fun ppf -> fprintf ppf "This %s has type" kind) +- (fun ppf -> fprintf ppf "which is less general than") ++ (Fmt.doc_printf "This %s has type" kind) ++ (Fmt.doc_printf "which is less general than") + | Modules_not_allowed -> + Location.errorf ~loc "Modules are not allowed in this pattern." + | Cannot_infer_signature -> +@@ -6803,6 +6940,12 @@ + Location.errorf ~loc + "@[Mixing value and exception patterns under when-guards is not \ + supported.@]" ++ | Effect_pattern_below_toplevel -> ++ Location.errorf ~loc ++ "@[Effect patterns must be at the top level of a match case.@]" ++ | Invalid_continuation_pattern -> ++ Location.errorf ~loc ++ "@[Invalid continuation pattern: only variables and _ are allowed .@]" + | Inlined_record_escape -> + Location.errorf ~loc + "@[This form is not allowed as the type of the inlined record could \ +@@ -6815,7 +6958,7 @@ + "@[%s@ %s@ @[%a@]@]" + "This match case could not be refuted." + "Here is an example of a value that would reach it:" +- (Style.as_inline_code Printpat.pretty_val) pat ++ (Style.as_inline_code Printpat.top_pretty) pat + | Invalid_extension_constructor_payload -> + Location.errorf ~loc + "Invalid %a payload, a constructor is expected." +@@ -6845,22 +6988,16 @@ + "This kind of recursive class expression is not allowed" + | Letop_type_clash(name, err) -> + report_unification_error ~loc env err +- (function ppf -> +- fprintf ppf "The operator %a has type" Style.inline_code name) +- (function ppf -> +- fprintf ppf "but it was expected to have type") ++ (msg "The operator %a has type" Style.inline_code name) ++ (msg "but it was expected to have type") + | Andop_type_clash(name, err) -> + report_unification_error ~loc env err +- (function ppf -> +- fprintf ppf "The operator %a has type" Style.inline_code name) +- (function ppf -> +- fprintf ppf "but it was expected to have type") ++ (msg "The operator %a has type" Style.inline_code name) ++ (msg "but it was expected to have type") + | Bindings_type_clash(err) -> + report_unification_error ~loc env err +- (function ppf -> +- fprintf ppf "These bindings have type") +- (function ppf -> +- fprintf ppf "but bindings were expected of type") ++ (Fmt.doc_printf "These bindings have type") ++ (Fmt.doc_printf "but bindings were expected of type") + | Unbound_existential (ids, ty) -> + let pp_ident ppf id = pp_print_string ppf (Ident.name id) in + let pp_type ppf (ids,ty)= +@@ -6872,6 +7009,20 @@ + "@[<2>%s:@ %a@]" + "This type does not bind all existentials in the constructor" + (Style.as_inline_code pp_type) (ids, ty) ++ | Bind_existential (reason, id, ty) -> ++ let reason1, reason2 = match reason with ++ | Bind_already_bound -> "the name", "that is already bound" ++ | Bind_not_in_scope -> "the name", "that was defined before" ++ | Bind_non_locally_abstract -> "the type", ++ "that is not a locally abstract type" ++ in ++ Location.errorf ~loc ++ "@[The local name@ %a@ %s@ %s.@ %s@ %s@ %a@ %s.@]" ++ (Style.as_inline_code Printtyp.ident) id ++ "can only be given to an existential variable" ++ "introduced by this GADT constructor" ++ "The type annotation tries to bind it to" ++ reason1 (Style.as_inline_code Printtyp.type_expr) ty reason2 + | Missing_type_constraint -> + Location.errorf ~loc + "@[%s@ %s@]" +@@ -6893,9 +7044,9 @@ + in + Location.errorf ~loc + "This %s should not be a %s,@ \ +- the expected type is@ %a%t" ++ the expected type is@ %a%a" + ctx sort (Style.as_inline_code Printtyp.type_expr) ty +- (report_type_expected_explanation_opt explanation) ++ pp_doc (report_type_expected_explanation_opt explanation) + | Expr_not_a_record_type ty -> + Location.errorf ~loc + "This expression has type %a@ \ diff --git a/upstream/patches_503/typing/typecore.mli.patch b/upstream/patches_503/typing/typecore.mli.patch new file mode 100644 index 000000000..e5d612c7f --- /dev/null +++ b/upstream/patches_503/typing/typecore.mli.patch @@ -0,0 +1,67 @@ +--- ocaml_502/typing/typecore.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typecore.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -49,12 +49,17 @@ + } + + (* Variables in patterns *) ++type pattern_variable_kind = ++ | Std_var ++ | As_var ++ | Continuation_var ++ + type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; +- pv_as_var: bool; ++ pv_kind: pattern_variable_kind; + pv_attributes: Typedtree.attributes; + pv_uid : Uid.t; + } +@@ -134,7 +139,6 @@ + val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression + val extract_option_type: Env.t -> type_expr -> type_expr + val generalizable: int -> type_expr -> bool +-val generalize_structure_exp: Typedtree.expression -> unit + val reset_delayed_checks: unit -> unit + val force_delayed_checks: unit -> unit + +@@ -143,6 +147,11 @@ + + val self_coercion : (Path.t * Location.t list ref) list ref + ++type existential_binding = ++ | Bind_already_bound ++ | Bind_not_in_scope ++ | Bind_non_locally_abstract ++ + type error = + | Constructor_arity_mismatch of Longident.t * int * int + | Label_mismatch of Longident.t * Errortrace.unification_error +@@ -154,7 +163,7 @@ + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option +- * Parsetree.expression_desc option ++ * Parsetree.expression option + | Function_arity_type_clash of + { syntactic_arity : int; + type_constraint : type_expr; +@@ -210,6 +219,8 @@ + | No_value_clauses + | Exception_pattern_disallowed + | Mixed_value_and_exception_patterns_under_guard ++ | Effect_pattern_below_toplevel ++ | Invalid_continuation_pattern + | Inlined_record_escape + | Inlined_record_expected + | Unrefuted_pattern of Typedtree.pattern +@@ -224,6 +235,7 @@ + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr ++ | Bind_existential of existential_binding * Ident.t * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr diff --git a/upstream/patches_503/typing/typedecl.ml.patch b/upstream/patches_503/typing/typedecl.ml.patch new file mode 100644 index 000000000..cb46210b5 --- /dev/null +++ b/upstream/patches_503/typing/typedecl.ml.patch @@ -0,0 +1,548 @@ +--- ocaml_502/typing/typedecl.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typedecl.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -231,7 +231,7 @@ + let cty = transl_simple_type env ?univars ~closed arg in + {ld_id = Ident.create_local name.txt; + ld_name = name; +- ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ ld_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + ld_mutable = mut; + ld_type = cty; ld_loc = loc; ld_attributes = attrs} + ) +@@ -276,8 +276,8 @@ + (* narrow and widen are now invoked through wrap_type_variable_scope *) + TyVarEnv.with_local_scope begin fun () -> + let closed = svars <> [] in +- let targs, tret_type, args, ret_type, _univars = +- Ctype.with_local_level_if closed begin fun () -> ++ let targs, tret_type, args, ret_type, univars = ++ Ctype.with_local_level_generalize_if closed begin fun () -> + TyVarEnv.reset (); + let univar_list = + TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) svars) in +@@ -306,15 +306,13 @@ + end; + (targs, tret_type, args, ret_type, univar_list) + end +- ~post: begin fun (_, _, args, ret_type, univars) -> +- Btype.iter_type_expr_cstr_args Ctype.generalize args; +- Ctype.generalize ret_type; +- let _vars = TyVarEnv.instance_poly_univars env loc univars in +- let set_level t = Ctype.enforce_current_level env t in +- Btype.iter_type_expr_cstr_args set_level args; +- set_level ret_type; +- end + in ++ if closed then begin ++ ignore (TyVarEnv.instance_poly_univars env loc univars); ++ let set_level t = Ctype.enforce_current_level env t in ++ Btype.iter_type_expr_cstr_args set_level args; ++ set_level ret_type ++ end; + targs, Some tret_type, args, Some ret_type + end + +@@ -341,7 +339,6 @@ + + let transl_declaration env sdecl (id, uid) = + (* Bind type parameters *) +- Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in +@@ -425,7 +422,7 @@ + let tcstr = + { cd_id = name; + cd_name = scstr.pcd_name; +- cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ cd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + cd_vars = scstr.pcd_vars; + cd_args = targs; + cd_res = tret_type; +@@ -460,6 +457,7 @@ + Ttype_record lbls, Type_record(lbls', rep) + | Ptype_open -> Ttype_open, Type_open + in ++ begin + let (tman, man) = match sdecl.ptype_manifest with + None -> None, None + | Some sty -> +@@ -526,16 +524,6 @@ + decl, typ_shape + end + +-(* Generalize a type declaration *) +- +-let generalize_decl decl = +- List.iter Ctype.generalize decl.type_params; +- Btype.iter_type_expr_kind Ctype.generalize decl.type_kind; +- begin match decl.type_manifest with +- | None -> () +- | Some ty -> Ctype.generalize ty +- end +- + (* Check that all constraints are enforced *) + + module TypeSet = Btype.TypeSet +@@ -903,11 +891,8 @@ + let open Btype in + (* We iterate on all subexpressions of the declaration to check + "in depth" that no ill-founded type exists. *) +- let it = +- let checked = +- (* [checked] remembers the types that the iterator already +- checked, to avoid looping on cyclic types. *) +- ref TypeSet.empty in ++ with_type_mark begin fun mark -> ++ let super = type_iterators mark in + let visited = + (* [visited] remembers the inner visits performed by + [check_well_founded] on each type expression reachable from +@@ -915,14 +900,14 @@ + [check_well_founded] work when invoked on two parts of the + type declaration that have common subexpressions. *) + ref TypeMap.empty in +- {type_iterators with it_type_expr = +- (fun self ty -> +- if TypeSet.mem ty !checked then () else begin +- check_well_founded ~abs_env env loc path to_check visited ty; +- checked := TypeSet.add ty !checked; +- self.it_do_type_expr self ty +- end)} in +- it.it_type_declaration it (Ctype.generic_instance_declaration decl) ++ let it = ++ {super with it_do_type_expr = ++ (fun self ty -> ++ check_well_founded ~abs_env env loc path to_check visited ty; ++ super.it_do_type_expr self ty ++ )} in ++ it.it_type_declaration it (Ctype.generic_instance_declaration decl) ++ end + + (* Check for non-regular abbreviations; an abbreviation + [type 'a t = ...] is non-regular if the expansion of [...] +@@ -1043,10 +1028,10 @@ + | { type_kind = Type_abstract _; + type_manifest = Some ty; + type_private = Private; } when is_fixed_type sdecl -> +- let ty' = newty2 ~level:(get_level ty) (get_desc ty) in ++ let ty' = Btype.newty2 ~level:(get_level ty) (get_desc ty) in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in +- link_type ty (newty2 ~level:(get_level ty) td); ++ link_type ty (Btype.newty2 ~level:(get_level ty) td); + {decl with type_manifest = Some ty'} + else decl + | _ -> decl +@@ -1101,14 +1086,14 @@ + let ids_list = + List.map (fun sdecl -> + Ident.create_scoped ~scope sdecl.ptype_name.txt, +- Uid.mk ~current_unit:(Env.get_unit_name ()) ++ Uid.mk ~current_unit:(Env.get_current_unit ()) + ) sdecl_list + in + (* Translate declarations, using a temporary environment where abbreviations + expand to a generic type variable. After that, we check the coherence of + the translated declarations in the resulting new environment. *) + let tdecls, decls, shapes, new_env = +- Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> ++ Ctype.with_local_level_generalize begin fun () -> + (* Enter types. *) + let temp_env = + List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in +@@ -1154,7 +1139,7 @@ + check_duplicates sdecl_list; + (* Build the final env. *) + let new_env = add_types_to_env decls shapes env in +- ((tdecls, decls, shapes, new_env), List.map snd decls) ++ (tdecls, decls, shapes, new_env) + end + in + (* Check for ill-formed abbrevs *) +@@ -1330,7 +1315,7 @@ + ext_private = priv; + Types.ext_loc = sext.pext_loc; + Types.ext_attributes = sext.pext_attributes; +- ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ ext_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let ext_cstrs = +@@ -1410,7 +1395,7 @@ + (* Note: it would be incorrect to call [create_scope] *after* + [TyVarEnv.reset] or after [with_local_level] (see #10010). *) + let scope = Ctype.create_scope () in +- Ctype.with_local_level begin fun () -> ++ Ctype.with_local_level_generalize begin fun () -> + TyVarEnv.reset(); + let ttype_params = make_params env styext.ptyext_params in + let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in +@@ -1424,15 +1409,6 @@ + in + (ttype_params, type_params, constructors) + end +- ~post: begin fun (_, type_params, constructors) -> +- (* Generalize types *) +- List.iter Ctype.generalize type_params; +- List.iter +- (fun (ext, _shape) -> +- Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; +- Option.iter Ctype.generalize ext.ext_type.ext_ret_type) +- constructors; +- end + in + (* Check that all type variables are closed *) + List.iter +@@ -1482,15 +1458,11 @@ + let transl_exception env sext = + let ext, shape = + let scope = Ctype.create_scope () in +- Ctype.with_local_level ++ Ctype.with_local_level_generalize + (fun () -> + TyVarEnv.reset(); + transl_extension_constructor ~scope env + Predef.path_exn [] [] Asttypes.Public sext) +- ~post: begin fun (ext, _shape) -> +- Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; +- Option.iter Ctype.generalize ext.ext_type.ext_ret_type; +- end + in + (* Check that all type variables are closed *) + begin match Ctype.closed_extension_constructor ext.ext_type with +@@ -1629,7 +1601,7 @@ + [] when Env.is_in_signature env -> + { val_type = ty; val_kind = Val_reg; Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; +- val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + | [] -> + raise (Error(valdecl.pval_loc, Val_in_structure)) +@@ -1659,7 +1631,7 @@ + check_unboxable env loc ty; + { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; +- val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let (id, newenv) = +@@ -1697,7 +1669,7 @@ + let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env + sdecl = + Env.mark_type_used sig_decl.type_uid; +- Ctype.with_local_level begin fun () -> ++ Ctype.with_local_level_generalize begin fun () -> + TyVarEnv.reset(); + (* In the first part of this function, we typecheck the syntactic + declaration [sdecl] in the outer environment [outer_env]. *) +@@ -1775,7 +1747,7 @@ + type_attributes = sdecl.ptype_attributes; + type_immediate = Unknown; + type_unboxed_default; +- type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + Option.iter (fun p -> set_private_row env sdecl.ptype_loc p new_sig_decl) +@@ -1832,7 +1804,6 @@ + typ_attributes = sdecl.ptype_attributes; + } + end +- ~post:(fun ttyp -> generalize_decl ttyp.typ_type) + + (* A simplified version of [transl_with_constraint], for the case of packages. + Package constraints are much simpler than normal with type constraints (e.g., +@@ -1852,7 +1823,7 @@ + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; +- type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) ++ type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) + } + in + let new_type_immediate = +@@ -1866,7 +1837,7 @@ + let abstract_type_decl ~injective arity = + let rec make_params n = + if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in +- Ctype.with_local_level ~post:generalize_decl begin fun () -> ++ Ctype.with_local_level_generalize begin fun () -> + { type_params = make_params arity; + type_arity = arity; + type_kind = Type_abstract Definition; +@@ -1909,25 +1880,26 @@ + + (**** Error report ****) + +-open Format ++open Format_doc + module Style = Misc.Style ++module Printtyp = Printtyp.Doc + + let explain_unbound_gen ppf tv tl typ kwd pr = + try + let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in + let ty0 = (* Hack to force aliasing when needed *) + Btype.newgenty (Tobject(tv, ref None)) in +- Printtyp.prepare_for_printing [typ ti; ty0]; ++ Out_type.prepare_for_printing [typ ti; ty0]; + fprintf ppf + ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd (Style.as_inline_code pr) ti +- (Style.as_inline_code Printtyp.prepared_type_expr) tv ++ (Style.as_inline_code Out_type.prepared_type_expr) tv + with Not_found -> () + + let explain_unbound ppf tv tl typ kwd lab = + explain_unbound_gen ppf tv tl typ kwd + (fun ppf ti -> +- fprintf ppf "%s%a" (lab ti) Printtyp.prepared_type_expr (typ ti) ++ fprintf ppf "%s%a" (lab ti) Out_type.prepared_type_expr (typ ti) + ) + + let explain_unbound_single ppf tv ty = +@@ -1969,7 +1941,7 @@ + | [] -> [] + in simplify path + +- (* See Printtyp.add_type_to_preparation. ++ (* See Out_type.add_type_to_preparation. + + Note: it is better to call this after [simplify], otherwise some + type variable names may be used for types that are removed +@@ -1978,29 +1950,32 @@ + let add_to_preparation path = + List.iter (function + | Contains (ty1, ty2) | Expands_to (ty1, ty2) -> +- List.iter Printtyp.add_type_to_preparation [ty1; ty2] ++ List.iter Out_type.add_type_to_preparation [ty1; ty2] + ) path + ++ module Fmt = Format_doc ++ + let pp ppf reaching_path = + let pp_step ppf = function + | Expands_to (ty, body) -> +- Format.fprintf ppf "%a = %a" +- (Style.as_inline_code Printtyp.prepared_type_expr) ty +- (Style.as_inline_code Printtyp.prepared_type_expr) body ++ Fmt.fprintf ppf "%a = %a" ++ (Style.as_inline_code Out_type.prepared_type_expr) ty ++ (Style.as_inline_code Out_type.prepared_type_expr) body + | Contains (outer, inner) -> +- Format.fprintf ppf "%a contains %a" +- (Style.as_inline_code Printtyp.prepared_type_expr) outer +- (Style.as_inline_code Printtyp.prepared_type_expr) inner ++ Fmt.fprintf ppf "%a contains %a" ++ (Style.as_inline_code Out_type.prepared_type_expr) outer ++ (Style.as_inline_code Out_type.prepared_type_expr) inner + in +- let comma ppf () = Format.fprintf ppf ",@ " in +- Format.(pp_print_list ~pp_sep:comma pp_step) ppf reaching_path ++ Fmt.(pp_print_list ~pp_sep:comma) pp_step ppf reaching_path + + let pp_colon ppf path = +- Format.fprintf ppf ":@;<1 2>@[%a@]" +- pp path ++ Fmt.fprintf ppf ":@;<1 2>@[%a@]" pp path + end + +-let report_error ppf = function ++let quoted_out_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty ++let quoted_type ppf ty = Style.as_inline_code Printtyp.type_expr ppf ty ++ ++let report_error_doc ppf = function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Duplicate_constructor s -> +@@ -2014,7 +1989,7 @@ + | Recursive_abbrev (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> +- Printtyp.reset (); ++ Out_type.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The type abbreviation %a is cyclic%a@]" + Style.inline_code s +@@ -2022,7 +1997,7 @@ + | Cycle_in_def (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> +- Printtyp.reset (); ++ Out_type.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The definition of %a contains a cycle%a@]" + Style.inline_code s +@@ -2030,24 +2005,24 @@ + | Definition_mismatch (ty, _env, None) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" + "This variant or record definition" "does not match that of type" +- (Style.as_inline_code Printtyp.type_expr) ty ++ quoted_type ty + | Definition_mismatch (ty, env, Some err) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" + "This variant or record definition" "does not match that of type" +- (Style.as_inline_code Printtyp.type_expr) ty ++ quoted_type ty + (Includecore.report_type_mismatch + "the original" "this" "definition" env) + err + | Constraint_failed (env, err) -> ++ let msg = Format_doc.Doc.msg in + fprintf ppf "@[Constraints are not satisfied in this type.@ "; +- Printtyp.report_unification_error ppf env err +- (fun ppf -> fprintf ppf "Type") +- (fun ppf -> fprintf ppf "should be an instance of"); ++ Errortrace_report.unification ppf env err ++ (msg "Type") ++ (msg "should be an instance of"); + fprintf ppf "@]" + | Non_regular { definition; used_as; defined_as; reaching_path } -> + let reaching_path = Reaching_path.simplify reaching_path in +- let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in +- Printtyp.prepare_for_printing [used_as; defined_as]; ++ Out_type.prepare_for_printing [used_as; defined_as]; + Reaching_path.add_to_preparation reaching_path; + fprintf ppf + "@[This recursive type is not regular.@ \ +@@ -2056,8 +2031,8 @@ + All uses need to match the definition for the recursive type \ + to be regular.@]" + Style.inline_code (Path.name definition) +- pp_type (Printtyp.tree_of_typexp Type defined_as) +- pp_type (Printtyp.tree_of_typexp Type used_as) ++ quoted_out_type (Out_type.tree_of_typexp Type defined_as) ++ quoted_out_type (Out_type.tree_of_typexp Type used_as) + (fun pp -> + let is_expansion = function Expands_to _ -> true | _ -> false in + if List.exists is_expansion reaching_path then +@@ -2065,17 +2040,17 @@ + Reaching_path.pp_colon reaching_path + else fprintf pp ".@ ") + | Inconsistent_constraint (env, err) -> ++ let msg = Format_doc.Doc.msg in + fprintf ppf "@[The type constraints are not consistent.@ "; +- Printtyp.report_unification_error ppf env err +- (fun ppf -> fprintf ppf "Type") +- (fun ppf -> fprintf ppf "is not compatible with type"); ++ Errortrace_report.unification ppf env err ++ (msg "Type") ++ (msg "is not compatible with type"); + fprintf ppf "@]" + | Type_clash (env, err) -> +- Printtyp.report_unification_error ppf env err +- (function ppf -> +- fprintf ppf "This type constructor expands to type") +- (function ppf -> +- fprintf ppf "but is used here with type") ++ let msg = Format_doc.Doc.msg in ++ Errortrace_report.unification ppf env err ++ (msg "This type constructor expands to type") ++ (msg "but is used here with type") + | Null_arity_external -> + fprintf ppf "External identifiers must be functions" + | Missing_native_external -> +@@ -2124,12 +2099,11 @@ + "the type" "this extension" "definition" env) + err + | Rebind_wrong_type (lid, env, err) -> +- Printtyp.report_unification_error ppf env err +- (function ppf -> +- fprintf ppf "The constructor %a@ has type" ++ let msg = Format_doc.doc_printf in ++ Errortrace_report.unification ppf env err ++ (msg "The constructor %a@ has type" + (Style.as_inline_code Printtyp.longident) lid) +- (function ppf -> +- fprintf ppf "but was expected to be of type") ++ (msg "but was expected to be of type") + | Rebind_mismatch (lid, p, p') -> + fprintf ppf + "@[%s@ %a@ %s@ %a@ %s@ %s@ %a@]" +@@ -2154,44 +2128,44 @@ + in + (match n with + | Variance_variable_error { error; variable; context } -> +- Printtyp.prepare_for_printing [ variable ]; ++ Out_type.prepare_for_printing [ variable ]; + begin match context with + | Type_declaration (id, decl) -> +- Printtyp.add_type_declaration_to_preparation id decl; ++ Out_type.add_type_declaration_to_preparation id decl; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the definition" +- (Style.as_inline_code @@ Printtyp.prepared_type_declaration id) ++ (Style.as_inline_code @@ Out_type.prepared_type_declaration id) + decl + | Gadt_constructor c -> +- Printtyp.add_constructor_to_preparation c; ++ Out_type.add_constructor_to_preparation c; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the GADT constructor" +- (Style.as_inline_code Printtyp.prepared_constructor) ++ (Style.as_inline_code Out_type.prepared_constructor) + c + | Extension_constructor (id, e) -> +- Printtyp.add_extension_constructor_to_preparation e; ++ Out_type.add_extension_constructor_to_preparation e; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the extension constructor" +- (Printtyp.prepared_extension_constructor id) ++ (Out_type.prepared_extension_constructor id) + e + end; + begin match error with + | Variance_not_reflected -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" +- (Style.as_inline_code Printtyp.prepared_type_expr) variable ++ (Style.as_inline_code Out_type.prepared_type_expr) variable + "has a variance that" + "is not reflected by its occurrence in type parameters." + | No_variable -> + fprintf ppf "@[%s@ %a@ %s@ %s@]@]" + "the type variable" +- (Style.as_inline_code Printtyp.prepared_type_expr) variable ++ (Style.as_inline_code Out_type.prepared_type_expr) variable + "cannot be deduced" + "from the type parameters." + | Variance_not_deducible -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" +- (Style.as_inline_code Printtyp.prepared_type_expr) variable ++ (Style.as_inline_code Out_type.prepared_type_expr) variable + "has a variance that" + "cannot be deduced from the type parameters." + end +@@ -2259,7 +2233,7 @@ + fprintf ppf "an unnamed existential variable" + | Some str -> + fprintf ppf "the existential variable %a" +- (Style.as_inline_code Pprintast.tyvar) str in ++ (Style.as_inline_code Pprintast.Doc.tyvar) str in + fprintf ppf "@[This type cannot be unboxed because@ \ + it might contain both float and non-float values,@ \ + depending on the instantiation of %a.@ \ +@@ -2274,7 +2248,7 @@ + Style.inline_code "nonrec" + | Invalid_private_row_declaration ty -> + let pp_private ppf ty = fprintf ppf "private %a" Printtyp.type_expr ty in +- Format.fprintf ppf ++ fprintf ppf + "@[This private row type declaration is invalid.@ \ + The type expression on the right-hand side reduces to@;<1 2>%a@ \ + which does not have a free row type variable.@]@,\ +@@ -2288,7 +2262,9 @@ + Location.register_error_of_exn + (function + | Error (loc, err) -> +- Some (Location.error_of_printer ~loc report_error err) ++ Some (Location.error_of_printer ~loc report_error_doc err) + | _ -> + None + ) ++ ++let report_error = Format_doc.compat report_error_doc diff --git a/upstream/patches_503/typing/typedecl.mli.patch b/upstream/patches_503/typing/typedecl.mli.patch new file mode 100644 index 000000000..e8d0d1847 --- /dev/null +++ b/upstream/patches_503/typing/typedecl.mli.patch @@ -0,0 +1,18 @@ +--- ocaml_502/typing/typedecl.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typedecl.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -16,8 +16,6 @@ + (* Typing of type definitions and primitive definitions *) + + open Types +-open Format +- + val transl_type_decl: + Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> + Typedtree.type_declaration list * Env.t * Shape.t list +@@ -111,4 +109,5 @@ + + exception Error of Location.t * error + +-val report_error: formatter -> error -> unit ++val report_error: error Format_doc.format_printer ++val report_error_doc: error Format_doc.printer diff --git a/upstream/patches_503/typing/typedtree.ml.patch b/upstream/patches_503/typing/typedtree.ml.patch new file mode 100644 index 000000000..25ce3e5dc --- /dev/null +++ b/upstream/patches_503/typing/typedtree.ml.patch @@ -0,0 +1,41 @@ +--- ocaml_502/typing/typedtree.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typedtree.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -104,8 +104,8 @@ + | Texp_let of rec_flag * value_binding list * expression + | Texp_function of function_param list * function_body + | Texp_apply of expression * (arg_label * expression option) list +- | Texp_match of expression * computation case list * partial +- | Texp_try of expression * value case list ++ | Texp_match of expression * computation case list * value case list * partial ++ | Texp_try of expression * value case list * value case list + | Texp_tuple of expression list + | Texp_construct of + Longident.t loc * constructor_description * expression list +@@ -157,6 +157,7 @@ + and 'k case = + { + c_lhs: 'k general_pattern; ++ c_cont: Ident.t option; + c_guard: expression option; + c_rhs: expression; + } +@@ -892,19 +893,3 @@ + combine_opts (into cpat) exns1 exns2 + in + split_pattern pat +- +-(* Expressions are considered nominal if they can be used as the subject of a +- sentence or action. In practice, we consider that an expression is nominal +- if they satisfy one of: +- - Similar to an identifier: words separated by '.' or '#'. +- - Do not contain spaces when printed. +- *) +-let rec exp_is_nominal exp = +- match exp.exp_desc with +- | _ when exp.exp_attributes <> [] -> false +- | Texp_ident _ | Texp_instvar _ | Texp_constant _ +- | Texp_variant (_, None) +- | Texp_construct (_, _, []) -> +- true +- | Texp_field (parent, _, _) | Texp_send (parent, _) -> exp_is_nominal parent +- | _ -> false diff --git a/upstream/patches_503/typing/typedtree.mli.patch b/upstream/patches_503/typing/typedtree.mli.patch new file mode 100644 index 000000000..e54ce675e --- /dev/null +++ b/upstream/patches_503/typing/typedtree.mli.patch @@ -0,0 +1,45 @@ +--- ocaml_502/typing/typedtree.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typedtree.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -211,17 +211,22 @@ + (Labelled "y", Some (Texp_constant Const_int 3)) + ]) + *) +- | Texp_match of expression * computation case list * partial ++ | Texp_match of expression * computation case list * value case list * partial + (** match E0 with + | P1 -> E1 + | P2 | exception P3 -> E2 + | exception P4 -> E3 ++ | effect P4 k -> E4 + + [Texp_match (E0, [(P1, E1); (P2 | exception P3, E2); +- (exception P4, E3)], _)] ++ (exception P4, E3)], [(P4, E4)], _)] + *) +- | Texp_try of expression * value case list +- (** try E with P1 -> E1 | ... | PN -> EN *) ++ | Texp_try of expression * value case list * value case list ++ (** try E with ++ | P1 -> E1 ++ | effect P2 k -> E2 ++ [Texp_try (E, [(P1, E1)], [(P2, E2)])] ++ *) + | Texp_tuple of expression list + (** (E1, ..., EN) *) + | Texp_construct of +@@ -290,6 +295,7 @@ + and 'k case = + { + c_lhs: 'k general_pattern; ++ c_cont: Ident.t option; + c_guard: expression option; + c_rhs: expression; + } +@@ -913,7 +919,3 @@ + (** Splits an or pattern into its value (left) and exception (right) parts. *) + val split_pattern: + computation general_pattern -> pattern option * pattern option +- +-(** Whether an expression looks nice as the subject of a sentence in a error +- message. *) +-val exp_is_nominal : expression -> bool diff --git a/upstream/patches_503/typing/typemod.ml.patch b/upstream/patches_503/typing/typemod.ml.patch new file mode 100644 index 000000000..afc4329b1 --- /dev/null +++ b/upstream/patches_503/typing/typemod.ml.patch @@ -0,0 +1,477 @@ +--- ocaml_502/typing/typemod.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typemod.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -19,7 +19,7 @@ + open Asttypes + open Parsetree + open Types +-open Format ++open Format_doc + + module Style = Misc.Style + +@@ -78,6 +78,7 @@ + | Invalid_type_subst_rhs + | Unpackable_local_modtype_subst of Path.t + | With_cannot_remove_packed_modtype of Path.t * module_type ++ | Cannot_alias of Path.t + + exception Error of Location.t * Env.t * error + exception Error_forward of Location.error +@@ -264,9 +265,8 @@ + Ident.same ident1 ident2 + && list_is_strict_prefix l1 ~prefix:l2 + +-let iterator_with_env env = ++let iterator_with_env super env = + let env = ref (lazy env) in +- let super = Btype.type_iterators in + env, { super with + Btype.it_signature = (fun self sg -> + (* add all items to the env before recursing down, to handle recursive +@@ -359,7 +359,8 @@ + { super with Btype.it_do_type_expr } + + let do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg = +- let env, iterator = iterator_with_env env in ++ with_type_mark begin fun mark -> ++ let env, iterator = iterator_with_env (Btype.type_iterators mark) env in + let last, rest = match List.rev paths with + | [] -> assert false + | last :: rest -> last, rest +@@ -378,8 +379,8 @@ + let error p = With_cannot_remove_packed_modtype(p,mty) in + check_usage_of_module_types ~error ~paths ~loc env iterator + in +- iterator.Btype.it_signature iterator sg; +- Btype.(unmark_iterators.it_signature unmark_iterators) sg ++ iterator.Btype.it_signature iterator sg ++ end + + let check_usage_after_substitution env ~loc ~lid paths unpackable_modtype sg = + match paths, unpackable_modtype with +@@ -413,9 +414,9 @@ + | _ :: rem -> + check_signature env rem + in +- let env, super = iterator_with_env env in ++ let env, super = ++ iterator_with_env Btype.type_iterators_without_type_expr env in + { super with +- it_type_expr = (fun _self _ty -> ()); + it_signature = (fun self sg -> + let env_before = !env in + let env = lazy (Env.add_signature sg (Lazy.force env_before)) in +@@ -527,7 +528,7 @@ + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; +- type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + and id_row = Ident.create_local (s^"#row") in + let initial_env = +@@ -599,7 +600,7 @@ + if not destructive_substitution then + let mtd': modtype_declaration = + { +- mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ mtd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + mtd_type = Some mty.mty_type; + mtd_attributes = []; + mtd_loc = loc; +@@ -1175,19 +1176,19 @@ + should raise an error. + *) + let check_unpackable_modtypes ~loc ~env to_remove component = +- if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then begin +- let iterator = +- let error p = Unpackable_local_modtype_subst p in +- let paths = +- List.map (fun id -> Pident id) +- (Ident.Set.elements to_remove.unpackable_modtypes) ++ if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then ++ with_type_mark begin fun mark -> ++ let iterator = ++ let error p = Unpackable_local_modtype_subst p in ++ let paths = ++ List.map (fun id -> Pident id) ++ (Ident.Set.elements to_remove.unpackable_modtypes) ++ in ++ check_usage_of_module_types ~loc ~error ~paths ++ (ref (lazy env)) (Btype.type_iterators mark) + in +- check_usage_of_module_types ~loc ~error ~paths +- (ref (lazy env)) Btype.type_iterators +- in +- iterator.Btype.it_signature_item iterator component; +- Btype.(unmark_iterators.it_signature_item unmark_iterators) component +- end ++ iterator.Btype.it_signature_item iterator component ++ end + + (* We usually require name uniqueness of signature components (e.g. types, + modules, etc), however in some situation reusing the name is allowed: if +@@ -1347,7 +1348,7 @@ + { md_type = arg.mty_type; + md_attributes = []; + md_loc = param.loc; +- md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + Env.enter_module_declaration ~scope ~arg:true name Mp_present +@@ -1403,7 +1404,7 @@ + + + +-and transl_signature ?(toplevel = false) env sg = ++and transl_signature env sg = + let names = Signature_names.create () in + let rec transl_sig env sg = + match sg with +@@ -1499,14 +1500,17 @@ + in + let pres = + match tmty.mty_type with +- | Mty_alias _ -> Mp_absent ++ | Mty_alias p -> ++ if Env.is_functor_arg p env then ++ raise (Error (pmd.pmd_loc, env, Cannot_alias p)); ++ Mp_absent + | _ -> Mp_present + in + let md = { + md_type=tmty.mty_type; + md_attributes=pmd.pmd_attributes; + md_loc=pmd.pmd_loc; +- md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let id, newenv = +@@ -1543,7 +1547,7 @@ + { md_type = Mty_alias path; + md_attributes = pms.pms_attributes; + md_loc = pms.pms_loc; +- md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let pres = +@@ -1702,8 +1706,6 @@ + typedtree, sg, final_env + | Psig_attribute x -> + Builtin_attributes.warning_attribute x; +- if toplevel || not (Warnings.is_active (Misplaced_attribute "")) +- then Builtin_attributes.mark_alert_used x; + let (trem,rem, final_env) = transl_sig env srem in + mksig (Tsig_attribute x) env loc :: trem, rem, final_env + | Psig_extension (ext, _attrs) -> +@@ -1736,7 +1738,7 @@ + Types.mtd_type=Option.map (fun t -> t.mty_type) tmty; + mtd_attributes=pmtd_attributes; + mtd_loc=pmtd_loc; +- mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ mtd_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + let scope = Ctype.create_scope () in +@@ -1795,7 +1797,7 @@ + let init = + List.map2 + (fun id pmd -> +- let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in ++ let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let md = + { md_type = approx_modtype approx_env pmd.pmd_type; + md_loc = pmd.pmd_loc; +@@ -2090,11 +2092,11 @@ + end + + let modtype_of_package env loc p fl = +- (* We call Ctype.correct_levels to ensure that the types being added to the ++ (* We call Ctype.duplicate_type to ensure that the types being added to the + module type are at generic_level. *) + let mty = + package_constraints env loc (Mty_ident p) +- (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) ++ (List.map (fun (n, t) -> Longident.flatten n, Ctype.duplicate_type t) fl) + in + Subst.modtype Keep Subst.identity mty + +@@ -2105,12 +2107,20 @@ + modtype_of_package env Location.none p fl + in + match mkmty p1 fl1, mkmty p2 fl2 with +- | exception Error(_, _, Cannot_scrape_package_type _) -> false ++ | exception Error(_, _, Cannot_scrape_package_type r) -> ++ Result.Error (Errortrace.Package_cannot_scrape r) + | mty1, mty2 -> + let loc = Location.none in + match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with +- | Tcoerce_none -> true +- | _ | exception Includemod.Error _ -> false ++ | Tcoerce_none -> Ok () ++ | c -> ++ let msg = ++ Includemod_errorprinter.coercion_in_package_subtype env mty1 c ++ in ++ Result.Error (Errortrace.Package_coercion msg) ++ | exception Includemod.Error e -> ++ let msg = doc_printf "%a" Includemod_errorprinter.err_msgs e in ++ Result.Error (Errortrace.Package_inclusion msg) + + let () = Ctype.package_subtype := package_subtype + +@@ -2172,6 +2182,8 @@ + | false, Some p -> Includemod.Error.Named p, mty + | false, None -> Includemod.Error.Anonymous, mty + ++let not_principal msg = Warnings.Not_principal (Format_doc.Doc.msg msg) ++ + let rec type_module ?(alias=false) sttn funct_body anchor env smod = + Builtin_attributes.warning_scope smod.pmod_attributes + (fun () -> type_module_aux ~alias sttn funct_body anchor env smod) +@@ -2243,7 +2255,7 @@ + match param.txt with + | None -> None, env, Shape.for_unnamed_functor_param + | Some name -> +- let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in ++ let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let arg_md = + { md_type = mty.mty_type; + md_attributes = []; +@@ -2284,9 +2296,8 @@ + final_shape + | Pmod_unpack sexp -> + let exp = +- Ctype.with_local_level_if_principal ++ Ctype.with_local_level_generalize_structure_if_principal + (fun () -> Typecore.type_exp env sexp) +- ~post:Typecore.generalize_structure_exp + in + let mty = + match get_desc (Ctype.expand_head env exp.exp_type) with +@@ -2298,7 +2309,7 @@ + not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type) + then + Location.prerr_warning smod.pmod_loc +- (Warnings.Not_principal "this module unpacking"); ++ (not_principal "this module unpacking"); + modtype_of_package env smod.pmod_loc p fl + | Tvar _ -> + raise (Typecore.Error +@@ -2637,7 +2648,7 @@ + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in +- let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in ++ let md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in + let md = + { md_type = enrich_module_type anchor name.txt modl.mod_type env; + md_attributes = attrs; +@@ -2714,6 +2725,8 @@ + let mty' = + enrich_module_type anchor name.txt modl.mod_type newenv + in ++ Includemod.modtypes_consistency ~loc:modl.mod_loc newenv ++ mty' mty.mty_type; + (id, name, mty, modl, mty', attrs, loc, shape, uid)) + decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) +@@ -2854,8 +2867,6 @@ + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | Pstr_attribute x -> + Builtin_attributes.warning_attribute x; +- if toplevel || not (Warnings.is_active (Misplaced_attribute "")) then +- Builtin_attributes.mark_alert_used x; + Tstr_attribute x, [], shape_map, env + in + let rec type_struct env shape_map sstr = +@@ -3087,7 +3098,7 @@ + Typecore.force_delayed_checks (); + let shape = Shape_reduce.local_reduce Env.empty shape in + Printtyp.wrap_printing_env ~error:false initial_env +- (fun () -> fprintf std_formatter "%a@." ++ Format.(fun () -> fprintf std_formatter "%a@." + (Printtyp.printed_signature @@ Unit_info.source_file target) + simple_sg + ); +@@ -3143,8 +3154,8 @@ + declarations like "let x = true;; let x = 1;;", because in this + case, the inferred signature contains only the last declaration. *) + let shape = Shape_reduce.local_reduce Env.empty shape in ++ let alerts = Builtin_attributes.alerts_of_str ~mark:true ast in + if not !Clflags.dont_write_files then begin +- let alerts = Builtin_attributes.alerts_of_str ast in + let cmi = + Env.save_signature ~alerts simple_sg (Unit_info.cmi target) + in +@@ -3172,10 +3183,7 @@ + (Cmt_format.Interface tsg) initial_env (Some cmi) None + + let type_interface env ast = +- transl_signature ~toplevel:true env ast +- +-let transl_signature env ast = +- transl_signature ~toplevel:false env ast ++ transl_signature env ast + + (* "Packaging" of several compilation units into one unit + having them as sub-modules. *) +@@ -3204,7 +3212,7 @@ + { md_type=Mty_signature sg; + md_attributes=[]; + md_loc=Location.none; +- md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); ++ md_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); + } + in + Sig_module(newid, Mp_present, md, Trec_not, Exported)) +@@ -3274,9 +3282,7 @@ + + + (* Error report *) +- +- +-open Printtyp ++open Printtyp.Doc + + let report_error ~loc _env = function + Cannot_apply mty -> +@@ -3284,8 +3290,9 @@ + "@[This module is not a functor; it has type@ %a@]" + (Style.as_inline_code modtype) mty + | Not_included errs -> +- let main = Includemod_errorprinter.err_msgs errs in +- Location.errorf ~loc "@[Signature mismatch:@ %t@]" main ++ Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg ++ "@[Signature mismatch:@ %a@]" ++ Includemod_errorprinter.err_msgs errs + | Cannot_eliminate_dependency mty -> + Location.errorf ~loc + "@[This functor has type@ %a@ \ +@@ -3304,26 +3311,25 @@ + Style.inline_code "with" + (Style.as_inline_code longident) lid + | With_mismatch(lid, explanation) -> +- let main = Includemod_errorprinter.err_msgs explanation in +- Location.errorf ~loc ++ Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg + "@[\ + @[In this %a constraint, the new definition of %a@ \ + does not match its original definition@ \ + in the constrained signature:@]@ \ +- %t@]" ++ %a@]" + Style.inline_code "with" +- (Style.as_inline_code longident) lid main ++ (Style.as_inline_code longident) lid ++ Includemod_errorprinter.err_msgs explanation + | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> +- let main = Includemod_errorprinter.err_msgs explanation in +- Location.errorf ~loc ++ Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg + "@[\ + @[This %a constraint on %a makes the applicative functor @ \ + type %a ill-typed in the constrained signature:@]@ \ +- %t@]" ++ %a@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + Style.inline_code (Path.name path) +- main ++ Includemod_errorprinter.err_msgs explanation + | With_changes_module_alias(lid, id, path) -> + Location.errorf ~loc + "@[\ +@@ -3343,8 +3349,8 @@ + [ 12; 7; 3 ] + in + let pp_constraint ppf () = +- Format.fprintf ppf "%s := %a" +- (Path.name p) Printtyp.modtype mty ++ fprintf ppf "%s := %a" ++ (Path.name p) modtype mty + in + Location.errorf ~loc + "This %a constraint@ %a@ makes a packed module ill-formed.@ %a" +@@ -3356,7 +3362,7 @@ + "In the constrained signature, type %a is defined to be %a.@ \ + Package %a constraints may only be used on abstract types." + (Style.as_inline_code longident) lid +- (Style.as_inline_code Printtyp.type_expr) ty ++ (Style.as_inline_code type_expr) ty + Style.inline_code "with" + | Repeated_name(kind, name) -> + Location.errorf ~loc +@@ -3365,27 +3371,27 @@ + (Sig_component_kind.to_string kind) Style.inline_code name + | Non_generalizable { vars; expression } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in +- prepare_for_printing vars; +- add_type_to_preparation expression; ++ Out_type.prepare_for_printing vars; ++ Out_type.add_type_to_preparation expression; + Location.errorf ~loc + "@[The type of this expression,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" +- (Style.as_inline_code prepared_type_scheme) expression ++ (Style.as_inline_code Out_type.prepared_type_scheme) expression + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") +- (Style.as_inline_code prepared_type_scheme)) vars ++ (Style.as_inline_code Out_type.prepared_type_scheme)) vars + Misc.print_see_manual manual_ref + | Non_generalizable_module { vars; mty; item } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in +- prepare_for_printing vars; +- add_type_to_preparation item.val_type; ++ Out_type.prepare_for_printing vars; ++ Out_type.add_type_to_preparation item.val_type; + let sub = + [ Location.msg ~loc:item.val_loc + "The type of this value,@ %a,@ \ + contains the non-generalizable type variable(s) %a." +- (Style.as_inline_code prepared_type_scheme) ++ (Style.as_inline_code Out_type.prepared_type_scheme) + item.val_type + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") +- @@ Style.as_inline_code prepared_type_scheme) vars ++ @@ Style.as_inline_code Out_type.prepared_type_scheme) vars + ] + in + Location.errorf ~loc ~sub +@@ -3397,11 +3403,11 @@ + Location.errorf ~loc + "@[The interface %a@ declares values, not just types.@ \ + An implementation must be provided.@]" +- Location.print_filename intf_name ++ Location.Doc.quoted_filename intf_name + | Interface_not_compiled intf_name -> + Location.errorf ~loc + "@[Could not find the .cmi file for interface@ %a.@]" +- Location.print_filename intf_name ++ Location.Doc.quoted_filename intf_name + | Not_allowed_in_functor_body -> + Location.errorf ~loc + "@[This expression creates fresh types.@ %s@]" +@@ -3430,12 +3436,18 @@ + Location.errorf ~loc + "This is an alias for module %a, which is missing" + (Style.as_inline_code path) p ++ | Cannot_alias p -> ++ Location.errorf ~loc ++ "Functor arguments, such as %a, cannot be aliased" ++ (Style.as_inline_code path) p + | Cannot_scrape_package_type p -> + Location.errorf ~loc + "The type of this packed module refers to %a, which is missing" + (Style.as_inline_code path) p + | Badly_formed_signature (context, err) -> +- Location.errorf ~loc "@[In %s:@ %a@]" context Typedecl.report_error err ++ Location.errorf ~loc "@[In %s:@ %a@]" ++ context ++ Typedecl.report_error_doc err + | Cannot_hide_id Illegal_shadowing + { shadowed_item_kind; shadowed_item_id; shadowed_item_loc; + shadower_id; user_id; user_kind; user_loc } -> diff --git a/upstream/patches_503/typing/typemod.mli.patch b/upstream/patches_503/typing/typemod.mli.patch new file mode 100644 index 000000000..abe1b7985 --- /dev/null +++ b/upstream/patches_503/typing/typemod.mli.patch @@ -0,0 +1,19 @@ +--- ocaml_502/typing/typemod.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typemod.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -43,8 +43,6 @@ + Typedtree.implementation + val type_interface: + Env.t -> Parsetree.signature -> Typedtree.signature +-val transl_signature: +- Env.t -> Parsetree.signature -> Typedtree.signature + val check_nongen_signature: + Env.t -> Types.signature -> unit + (* +@@ -137,6 +135,7 @@ + | Invalid_type_subst_rhs + | Unpackable_local_modtype_subst of Path.t + | With_cannot_remove_packed_modtype of Path.t * module_type ++ | Cannot_alias of Path.t + + exception Error of Location.t * Env.t * error + exception Error_forward of Location.error diff --git a/upstream/patches_503/typing/typeopt.ml.patch b/upstream/patches_503/typing/typeopt.ml.patch new file mode 100644 index 000000000..bc32cf5d9 --- /dev/null +++ b/upstream/patches_503/typing/typeopt.ml.patch @@ -0,0 +1,11 @@ +--- ocaml_502/typing/typeopt.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typeopt.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -24,7 +24,7 @@ + let scrape_ty env ty = + match get_desc ty with + | Tconstr _ -> +- let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in ++ let ty = Ctype.expand_head_opt env ty in + begin match get_desc ty with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with diff --git a/upstream/patches_503/typing/types.ml.patch b/upstream/patches_503/typing/types.ml.patch new file mode 100644 index 000000000..b62c06914 --- /dev/null +++ b/upstream/patches_503/typing/types.ml.patch @@ -0,0 +1,174 @@ +--- ocaml_502/typing/types.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/types.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -22,9 +22,13 @@ + type transient_expr = + { mutable desc: type_desc; + mutable level: int; +- mutable scope: int; ++ mutable scope: scope_field; + id: int } + ++and scope_field = int ++ (* bit field: 27 bits for scope (Ident.highest_scope = 100_000_000) ++ and at least 4 marks *) ++ + and type_expr = transient_expr + + and type_desc = +@@ -51,13 +55,14 @@ + and fixed_explanation = + | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid + and row_field = [`some] row_field_gen ++and row_field_cell = [`some | `none] row_field_gen ref + and _ row_field_gen = + RFpresent : type_expr option -> [> `some] row_field_gen + | RFeither : + { no_arg: bool; + arg_type: type_expr list; + matched: bool; +- ext: [`some | `none] row_field_gen ref} -> [> `some] row_field_gen ++ ext: row_field_cell} -> [> `some] row_field_gen + | RFabsent : [> `some] row_field_gen + | RFnone : [> `none] row_field_gen + +@@ -87,6 +92,8 @@ + let equal t1 t2 = t1 == t2 + end + ++module TransientTypeHash = Hashtbl.Make(TransientTypeOps) ++ + (* *) + + module Uid = Shape.Uid +@@ -176,6 +183,7 @@ + let unknown = 7 + let full = single Inv + let covariant = single Pos ++ let contravariant = single Neg + let swap f1 f2 v v' = + set_if (mem f2 v) f1 (set_if (mem f1 v) f2 v') + let conjugate v = +@@ -575,12 +583,48 @@ + repr_link1 t t' + | _ -> t + ++(* scope_field and marks *) ++ ++let scope_mask = (1 lsl 27) - 1 ++let marks_mask = (-1) lxor scope_mask ++let () = assert (Ident.highest_scope land marks_mask = 0) ++ ++type type_mark = ++ | Mark of {mark: int; mutable marked: type_expr list} ++ | Hash of {visited: unit TransientTypeHash.t} ++let type_marks = ++ (* All the bits in marks_mask *) ++ List.init (Sys.int_size - 27) (fun x -> 1 lsl (x + 27)) ++let available_marks = Local_store.s_ref type_marks ++let with_type_mark f = ++ match !available_marks with ++ | mark :: rem as old -> ++ available_marks := rem; ++ let mk = Mark {mark; marked = []} in ++ Misc.try_finally (fun () -> f mk) ~always: begin fun () -> ++ available_marks := old; ++ match mk with ++ | Mark {marked} -> ++ (* unmark marked type nodes *) ++ List.iter ++ (fun ty -> ty.scope <- ty.scope land ((-1) lxor mark)) ++ marked ++ | Hash _ -> () ++ end ++ | [] -> ++ (* When marks are exhausted, fall back to using a hash table *) ++ f (Hash {visited = TransientTypeHash.create 1}) ++ + (* getters for type_expr *) + + let get_desc t = (repr t).desc + let get_level t = (repr t).level +-let get_scope t = (repr t).scope ++let get_scope t = (repr t).scope land scope_mask + let get_id t = (repr t).id ++let not_marked_node mark t = ++ match mark with ++ | Mark {mark} -> (repr t).scope land mark = 0 ++ | Hash {visited} -> not (TransientTypeHash.mem visited (repr t)) + + (* transient type_expr *) + +@@ -589,12 +633,28 @@ + let set_desc ty d = ty.desc <- d + let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d + let set_level ty lv = ty.level <- lv +- let set_scope ty sc = ty.scope <- sc ++ let get_scope ty = ty.scope land scope_mask ++ let get_marks ty = ty.scope lsr 27 ++ let set_scope ty sc = ++ if (sc land marks_mask <> 0) then ++ invalid_arg "Types.Transient_expr.set_scope"; ++ ty.scope <- (ty.scope land marks_mask) lor sc ++ let try_mark_node mark ty = ++ match mark with ++ | Mark ({mark} as mk) -> ++ (ty.scope land mark = 0) && (* mark type node when not marked *) ++ (ty.scope <- ty.scope lor mark; mk.marked <- ty :: mk.marked; true) ++ | Hash {visited} -> ++ not (TransientTypeHash.mem visited ty) && ++ (TransientTypeHash.add visited ty (); true) + let coerce ty = ty + let repr = repr + let type_expr ty = ty + end + ++(* setting marks *) ++let try_mark_node mark t = Transient_expr.try_mark_node mark (repr t) ++ + (* Comparison for [type_expr]; cannot be used for functors *) + + let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 +@@ -721,8 +781,7 @@ + | RFnone -> None + | RFeither _ | RFpresent _ | RFabsent as e -> Some e + in +- either no_arg arg_type matched e +- ++ either no_arg arg_type matched (ext,e) + + (**** Some type creators ****) + +@@ -730,13 +789,10 @@ + + let create_expr = Transient_expr.create + +-let newty3 ~level ~scope desc = ++let proto_newty3 ~level ~scope desc = + incr new_id; + create_expr desc ~level ~scope ~id:!new_id + +-let newty2 ~level desc = +- newty3 ~level ~scope:Ident.lowest_scope desc +- + (**********************************) + (* Utilities for backtracking *) + (**********************************) +@@ -795,13 +851,16 @@ + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + Transient_expr.set_level ty level + end ++ + (* TODO: introduce a guard and rename it to set_higher_scope? *) + let set_scope ty scope = + let ty = repr ty in +- if scope <> ty.scope then begin +- if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); ++ let prev_scope = ty.scope land marks_mask in ++ if scope <> prev_scope then begin ++ if ty.id <= !last_snapshot then log_change (Cscope (ty, prev_scope)); + Transient_expr.set_scope ty scope + end ++ + let set_univar rty ty = + log_change (Cuniv (rty, !rty)); rty := Some ty + let set_name nm v = diff --git a/upstream/patches_503/typing/types.mli.patch b/upstream/patches_503/typing/types.mli.patch new file mode 100644 index 000000000..e02db22f6 --- /dev/null +++ b/upstream/patches_503/typing/types.mli.patch @@ -0,0 +1,96 @@ +--- ocaml_502/typing/types.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/types.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -221,18 +221,36 @@ + val get_scope: type_expr -> int + val get_id: type_expr -> int + ++(** Access to marks. They are stored in the scope field. *) ++type type_mark ++val with_type_mark: (type_mark -> 'a) -> 'a ++ (* run a computation using exclusively an available type mark *) ++ ++val not_marked_node: type_mark -> type_expr -> bool ++ (* Return true if a type node is not yet marked *) ++ ++val try_mark_node: type_mark -> type_expr -> bool ++ (* Mark a type node if it is not yet marked. ++ Marks will be automatically removed when leaving the ++ scope of [with_type_mark]. ++ ++ Return false if it was already marked *) ++ + (** Transient [type_expr]. + Should only be used immediately after [Transient_expr.repr] *) + type transient_expr = private + { mutable desc: type_desc; + mutable level: int; +- mutable scope: int; ++ mutable scope: scope_field; + id: int } ++and scope_field (* abstract *) + + module Transient_expr : sig + (** Operations on [transient_expr] *) + + val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr ++ val get_scope: transient_expr -> int ++ val get_marks: transient_expr -> int + val set_desc: transient_expr -> type_desc -> unit + val set_level: transient_expr -> int -> unit + val set_scope: transient_expr -> int -> unit +@@ -244,18 +262,17 @@ + val set_stub_desc: type_expr -> type_desc -> unit + (** Instantiate a not yet instantiated stub. + Fail if already instantiated. *) ++ ++ val try_mark_node: type_mark -> transient_expr -> bool + end + + val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr + + (** Functions and definitions moved from Btype *) + +-val newty3: level:int -> scope:int -> type_desc -> type_expr ++val proto_newty3: level:int -> scope:int -> type_desc -> transient_expr + (** Create a type with a fresh id *) + +-val newty2: level:int -> type_desc -> type_expr +- (** Create a type with a fresh id and no scope *) +- + module TransientTypeOps : sig + (** Comparisons for functors *) + +@@ -265,6 +282,8 @@ + val hash : t -> int + end + ++module TransientTypeHash : Hashtbl.S with type key = transient_expr ++ + (** Comparisons for [type_expr]; cannot be used for functors *) + + val eq_type: type_expr -> type_expr -> bool +@@ -346,12 +365,15 @@ + val eq_row_field_ext: row_field -> row_field -> bool + val changed_row_field_exts: row_field list -> (unit -> unit) -> bool + ++type row_field_cell + val match_row_field: + present:(type_expr option -> 'a) -> + absent:(unit -> 'a) -> +- either:(bool -> type_expr list -> bool -> row_field option ->'a) -> ++ either:(bool -> type_expr list -> bool -> ++ row_field_cell * row_field option ->'a) -> + row_field -> 'a + ++ + (* *) + + module Uid = Shape.Uid +@@ -413,6 +435,7 @@ + val null : t (* no occurrence *) + val full : t (* strictly invariant (all flags) *) + val covariant : t (* strictly covariant (May_pos, Pos and Inj) *) ++ val contravariant : t (* strictly contravariant *) + val unknown : t (* allow everything, guarantee nothing *) + val union : t -> t -> t + val inter : t -> t -> t diff --git a/upstream/patches_503/typing/typetexp.ml.patch b/upstream/patches_503/typing/typetexp.ml.patch new file mode 100644 index 000000000..768cdeb6b --- /dev/null +++ b/upstream/patches_503/typing/typetexp.ml.patch @@ -0,0 +1,259 @@ +--- ocaml_502/typing/typetexp.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typetexp.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -218,7 +218,6 @@ + promoted vars + + let check_poly_univars env loc vars = +- vars |> List.iter (fun (_, p) -> generalize p.univar); + let univars = + vars |> List.map (fun (name, {univar=ty1; _ }) -> + let v = Btype.proxy ty1 in +@@ -350,8 +349,6 @@ + + (* Translation of type expressions *) + +-let generalize_ctyp typ = generalize typ.ctyp_type +- + let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') + + let validate_name = function +@@ -519,7 +516,7 @@ + ty + with Not_found -> + let t, ty = +- with_local_level_if_principal begin fun () -> ++ with_local_level_generalize_structure_if_principal begin fun () -> + let t = newvar () in + (* Use the whole location, which is used by [Type_mismatch]. *) + TyVarEnv.remember_used alias.txt t styp.ptyp_loc; +@@ -530,7 +527,6 @@ + end; + (t, ty) + end +- ~post: (fun (t, _) -> generalize_structure t) + in + let t = instance t in + let px = Btype.proxy t in +@@ -645,14 +641,13 @@ + | Ptyp_poly(vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let new_univars, cty = +- with_local_level begin fun () -> ++ with_local_level_generalize begin fun () -> + let new_univars = TyVarEnv.make_poly_univars vars in + let cty = TyVarEnv.with_univars new_univars begin fun () -> + transl_type env ~policy ~row_context st + end in + (new_univars, cty) + end +- ~post:(fun (_,cty) -> generalize_ctyp cty) + in + let ty = cty.ctyp_type in + let ty_list = TyVarEnv.check_poly_univars env styp.ptyp_loc new_univars in +@@ -760,8 +755,8 @@ + + + (* Make the rows "fixed" in this type, to make universal check easier *) +-let rec make_fixed_univars ty = +- if Btype.try_mark_node ty then ++let rec make_fixed_univars mark ty = ++ if try_mark_node mark ty then + begin match get_desc ty with + | Tvariant row -> + let Row {fields; more; name; closed} = row_repr row in +@@ -778,18 +773,17 @@ + (Tvariant + (create_row ~fields ~more ~name ~closed + ~fixed:(Some (Univar more)))); +- Btype.iter_row make_fixed_univars row ++ Btype.iter_row (make_fixed_univars mark) row + | _ -> +- Btype.iter_type_expr make_fixed_univars ty ++ Btype.iter_type_expr (make_fixed_univars mark) ty + end + ++let make_fixed_univars ty = ++ with_type_mark (fun mark -> make_fixed_univars mark ty) ++ + let transl_type env policy styp = + transl_type env ~policy ~row_context:[] styp + +-let make_fixed_univars ty = +- make_fixed_univars ty; +- Btype.unmark_type ty +- + let transl_simple_type env ?univars ~closed styp = + TyVarEnv.reset_locals ?univars (); + let policy = TyVarEnv.(if closed then fixed_policy else extensible_policy) in +@@ -802,7 +796,7 @@ + TyVarEnv.reset_locals (); + let typ, univs = + TyVarEnv.collect_univars begin fun () -> +- with_local_level ~post:generalize_ctyp begin fun () -> ++ with_local_level_generalize begin fun () -> + let policy = TyVarEnv.univars_policy in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); +@@ -816,7 +810,7 @@ + let transl_simple_type_delayed env styp = + TyVarEnv.reset_locals (); + let typ, force = +- with_local_level begin fun () -> ++ with_local_level_generalize begin fun () -> + let policy = TyVarEnv.extensible_policy in + let typ = transl_type env policy styp in + make_fixed_univars typ.ctyp_type; +@@ -826,8 +820,6 @@ + let force = TyVarEnv.globalize_used_variables policy env in + (typ, force) + end +- (* Generalize everything except the variables that were just globalized. *) +- ~post:(fun (typ,_) -> generalize_ctyp typ) + in + (typ, instance typ.ctyp_type, force) + +@@ -836,13 +828,12 @@ + | Ptyp_poly (vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let univars, typ = +- with_local_level begin fun () -> ++ with_local_level_generalize begin fun () -> + TyVarEnv.reset (); + let univars = TyVarEnv.make_poly_univars vars in + let typ = transl_simple_type env ~univars ~closed:true st in + (univars, typ) + end +- ~post:(fun (_,typ) -> generalize_ctyp typ) + in + let _ = TyVarEnv.instance_poly_univars env styp.ptyp_loc univars in + { ctyp_desc = Ttyp_poly (vars, typ); +@@ -851,20 +842,20 @@ + ctyp_loc = styp.ptyp_loc; + ctyp_attributes = styp.ptyp_attributes } + | _ -> +- with_local_level ++ with_local_level_generalize + (fun () -> TyVarEnv.reset (); transl_simple_type env ~closed:false styp) +- ~post:generalize_ctyp + + + (* Error report *) + +-open Format +-open Printtyp ++open Format_doc ++open Printtyp.Doc + module Style = Misc.Style +-let pp_tag ppf t = Format.fprintf ppf "`%s" t +- ++let pp_tag ppf t = fprintf ppf "`%s" t ++let pp_out_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty ++let pp_type ppf ty = Style.as_inline_code Printtyp.Doc.type_expr ppf ty + +-let report_error env ppf = function ++let report_error_doc env ppf = function + | Unbound_type_variable (name, in_scope_names) -> + fprintf ppf "The type variable %a is unbound in this type declaration.@ %a" + Style.inline_code name +@@ -882,21 +873,19 @@ + (Style.as_inline_code longident) lid expected provided + | Bound_type_variable name -> + fprintf ppf "Already bound type parameter %a" +- (Style.as_inline_code Pprintast.tyvar) name ++ (Style.as_inline_code Pprintast.Doc.tyvar) name + | Recursive_type -> + fprintf ppf "This type is recursive" + | Type_mismatch trace -> +- Printtyp.report_unification_error ppf Env.empty trace +- (function ppf -> +- fprintf ppf "This type") +- (function ppf -> +- fprintf ppf "should be an instance of type") ++ let msg = Format_doc.Doc.msg in ++ Errortrace_report.unification ppf Env.empty trace ++ (msg "This type") ++ (msg "should be an instance of type") + | Alias_type_mismatch trace -> +- Printtyp.report_unification_error ppf Env.empty trace +- (function ppf -> +- fprintf ppf "This alias is bound to type") +- (function ppf -> +- fprintf ppf "but is used as an instance of type") ++ let msg = Format_doc.Doc.msg in ++ Errortrace_report.unification ppf Env.empty trace ++ (msg "This alias is bound to type") ++ (msg "but is used as an instance of type") + | Present_has_conjunction l -> + fprintf ppf "The present constructor %a has a conjunctive type" + Style.inline_code l +@@ -913,18 +902,17 @@ + Style.inline_code ">" + (Style.as_inline_code pp_tag) l + | Constructor_mismatch (ty, ty') -> +- let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in + wrap_printing_env ~error:true env (fun () -> +- Printtyp.prepare_for_printing [ty; ty']; ++ Out_type.prepare_for_printing [ty; ty']; + fprintf ppf "@[%s %a@ %s@ %a@]" + "This variant type contains a constructor" +- pp_type (tree_of_typexp Type ty) ++ pp_out_type (Out_type.tree_of_typexp Type ty) + "which should be" +- pp_type (tree_of_typexp Type ty')) ++ pp_out_type (Out_type.tree_of_typexp Type ty')) + | Not_a_variant ty -> + fprintf ppf + "@[The type %a@ does not expand to a polymorphic variant type@]" +- (Style.as_inline_code Printtyp.type_expr) ty; ++ pp_type ty; + begin match get_desc ty with + | Tvar (Some s) -> + (* PR#7012: help the user that wrote 'Foo instead of `Foo *) +@@ -943,14 +931,13 @@ + | Cannot_quantify (name, v) -> + fprintf ppf + "@[The universal type variable %a cannot be generalized:@ " +- (Style.as_inline_code Pprintast.tyvar) name; ++ (Style.as_inline_code Pprintast.Doc.tyvar) name; + if Btype.is_Tvar v then + fprintf ppf "it escapes its scope" + else if Btype.is_Tunivar v then + fprintf ppf "it is already bound to another variable" + else +- fprintf ppf "it is bound to@ %a" +- (Style.as_inline_code Printtyp.type_expr) v; ++ fprintf ppf "it is bound to@ %a" pp_type v; + fprintf ppf ".@]"; + | Multiple_constraints_on_type s -> + fprintf ppf "Multiple constraints for type %a" +@@ -959,8 +946,8 @@ + wrap_printing_env ~error:true env (fun () -> + fprintf ppf "@[Method %a has type %a,@ which should be %a@]" + Style.inline_code l +- (Style.as_inline_code Printtyp.type_expr) ty +- (Style.as_inline_code Printtyp.type_expr) ty') ++ pp_type ty ++ pp_type ty') + | Opened_object nm -> + fprintf ppf + "Illegal open object type%a" +@@ -969,15 +956,17 @@ + | None -> fprintf ppf "") nm + | Not_an_object ty -> + fprintf ppf "@[The type %a@ is not an object type@]" +- (Style.as_inline_code Printtyp.type_expr) ty ++ pp_type ty + + let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> +- Some (Location.error_of_printer ~loc (report_error env) err) ++ Some (Location.error_of_printer ~loc (report_error_doc env) err) + | Error_forward err -> + Some err + | _ -> + None + ) ++ ++let report_error env = Format_doc.compat (report_error_doc env) diff --git a/upstream/patches_503/typing/typetexp.mli.patch b/upstream/patches_503/typing/typetexp.mli.patch new file mode 100644 index 000000000..e8e914295 --- /dev/null +++ b/upstream/patches_503/typing/typetexp.mli.patch @@ -0,0 +1,12 @@ +--- ocaml_502/typing/typetexp.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/typetexp.mli 2024-09-17 01:15:58.295900254 +0200 +@@ -95,7 +95,8 @@ + + exception Error of Location.t * Env.t * error + +-val report_error: Env.t -> Format.formatter -> error -> unit ++val report_error: Env.t -> error Format_doc.format_printer ++val report_error_doc: Env.t -> error Format_doc.printer + + (* Support for first-class modules. *) + val transl_modtype_longident: (* from Typemod *) diff --git a/upstream/patches_503/typing/untypeast.ml.patch b/upstream/patches_503/typing/untypeast.ml.patch new file mode 100644 index 000000000..8729aac64 --- /dev/null +++ b/upstream/patches_503/typing/untypeast.ml.patch @@ -0,0 +1,60 @@ +--- ocaml_502/typing/untypeast.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/untypeast.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -121,13 +121,13 @@ + (** Mapping functions. *) + + let constant = function +- | Const_char c -> Pconst_char c +- | Const_string (s,loc,d) -> Pconst_string (s,loc,d) +- | Const_int i -> Pconst_integer (Int.to_string i, None) +- | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') +- | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') +- | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n') +- | Const_float f -> Pconst_float (f,None) ++ | Const_char c -> Const.char c ++ | Const_string (s,loc,d) -> Const.string ?quotation_delimiter:d ~loc s ++ | Const_int i -> Const.integer (Int.to_string i) ++ | Const_int32 i -> Const.integer ~suffix:'l' (Int32.to_string i) ++ | Const_int64 i -> Const.integer ~suffix:'L' (Int64.to_string i) ++ | Const_nativeint i -> Const.integer ~suffix:'n' (Nativeint.to_string i) ++ | Const_float f -> Const.float f + + let attribute sub a = { + attr_name = map_loc sub a.attr_name; +@@ -450,10 +450,32 @@ + None -> list + | Some exp -> (label, sub.expr sub exp) :: list + ) list []) +- | Texp_match (exp, cases, _) -> +- Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases) +- | Texp_try (exp, cases) -> +- Pexp_try (sub.expr sub exp, List.map (sub.case sub) cases) ++ | Texp_match (exp, cases, eff_cases, _) -> ++ let merged_cases = List.map (sub.case sub) cases ++ @ List.map ++ (fun c -> ++ let uc = sub.case sub c in ++ let pat = { uc.pc_lhs ++ (* XXX KC: The 2nd argument of Ppat_effect is wrong *) ++ with ppat_desc = Ppat_effect (uc.pc_lhs, uc.pc_lhs) } ++ in ++ { uc with pc_lhs = pat }) ++ eff_cases ++ in ++ Pexp_match (sub.expr sub exp, merged_cases) ++ | Texp_try (exp, exn_cases, eff_cases) -> ++ let merged_cases = List.map (sub.case sub) exn_cases ++ @ List.map ++ (fun c -> ++ let uc = sub.case sub c in ++ let pat = { uc.pc_lhs ++ (* XXX KC: The 2nd argument of Ppat_effect is wrong *) ++ with ppat_desc = Ppat_effect (uc.pc_lhs, uc.pc_lhs) } ++ in ++ { uc with pc_lhs = pat }) ++ eff_cases ++ in ++ Pexp_try (sub.expr sub exp, merged_cases) + | Texp_tuple list -> + Pexp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, _, args) -> diff --git a/upstream/patches_503/typing/value_rec_check.ml.patch b/upstream/patches_503/typing/value_rec_check.ml.patch new file mode 100644 index 000000000..3a996e475 --- /dev/null +++ b/upstream/patches_503/typing/value_rec_check.ml.patch @@ -0,0 +1,52 @@ +--- ocaml_502/typing/value_rec_check.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/typing/value_rec_check.ml 2024-09-17 01:15:58.295900254 +0200 +@@ -154,7 +154,7 @@ + (* Note on module presence: + For absent modules (i.e. module aliases), the module being bound + does not have a physical representation, but its size can still be +- derived from the alias itself, so we can re-use the same code as ++ derived from the alias itself, so we can reuse the same code as + for modules that are present. *) + let size = classify_module_expression env mexp in + let env = Ident.add mid size env in +@@ -592,8 +592,8 @@ + value_bindings rec_flag bindings >> expression body + | Texp_letmodule (x, _, _, mexp, e) -> + module_binding (x, mexp) >> expression e +- | Texp_match (e, cases, _) -> +- (* ++ | Texp_match (e, cases, eff_cases, _) -> ++ (* TODO: update comment below for eff_cases + (Gi; mi |- pi -> ei : m)^i + G |- e : sum(mi)^i + ---------------------------------------------- +@@ -603,7 +603,11 @@ + let pat_envs, pat_modes = + List.split (List.map (fun c -> case c mode) cases) in + let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in +- Env.join_list (env_e :: pat_envs)) ++ let eff_envs, eff_modes = ++ List.split (List.map (fun c -> case c mode) eff_cases) in ++ let eff_e = expression e (List.fold_left Mode.join Ignore eff_modes) in ++ Env.join_list ++ ((Env.join_list (env_e :: pat_envs)) :: (eff_e :: eff_envs))) + | Texp_for (_, _, low, high, _, body) -> + (* + G1 |- low: m[Dereference] +@@ -825,7 +829,7 @@ + modexp mexp + | Texp_object (clsstrct, _) -> + class_structure clsstrct +- | Texp_try (e, cases) -> ++ | Texp_try (e, cases, eff_cases) -> + (* + G |- e: m (Gi; _ |- pi -> ei : m)^i + -------------------------------------------- +@@ -839,6 +843,7 @@ + join [ + expression e; + list case_env cases; ++ list case_env eff_cases; + ] + | Texp_override (pth, fields) -> + (* diff --git a/upstream/patches_503/utils/ccomp.ml.patch b/upstream/patches_503/utils/ccomp.ml.patch new file mode 100644 index 000000000..15fa5e60b --- /dev/null +++ b/upstream/patches_503/utils/ccomp.ml.patch @@ -0,0 +1,30 @@ +--- ocaml_502/utils/ccomp.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/ccomp.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -100,12 +100,11 @@ + (match !Clflags.c_compiler with + | Some cc -> cc + | None -> +- (* #7678: ocamlopt only calls the C compiler to process .c files +- from the command line, and the behaviour between +- ocamlc/ocamlopt should be identical. *) +- (String.concat " " [Config.c_compiler; +- Config.ocamlc_cflags; +- Config.ocamlc_cppflags])) ++ let (cflags, cppflags) = ++ if !Clflags.native_code ++ then (Config.native_cflags, Config.native_cppflags) ++ else (Config.bytecode_cflags, Config.bytecode_cppflags) in ++ (String.concat " " [Config.c_compiler; cflags; cppflags])) + debug_prefix_map + (match output with + | None -> "" +@@ -208,9 +207,3 @@ + in + command cmd + ) +- +-let linker_is_flexlink = +- (* Config.mkexe, Config.mkdll and Config.mkmaindll are all flexlink +- invocations for the native Windows ports and for Cygwin, if shared library +- support is enabled. *) +- Sys.win32 || Config.supports_shared_libraries && Sys.cygwin diff --git a/upstream/patches_503/utils/ccomp.mli.patch b/upstream/patches_503/utils/ccomp.mli.patch new file mode 100644 index 000000000..b63d88f50 --- /dev/null +++ b/upstream/patches_503/utils/ccomp.mli.patch @@ -0,0 +1,8 @@ +--- ocaml_502/utils/ccomp.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/ccomp.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -36,5 +36,3 @@ + | Partial + + val call_linker: link_mode -> string -> string list -> string -> int +- +-val linker_is_flexlink : bool diff --git a/upstream/patches_503/utils/clflags.ml.patch b/upstream/patches_503/utils/clflags.ml.patch new file mode 100644 index 000000000..da14e98ad --- /dev/null +++ b/upstream/patches_503/utils/clflags.ml.patch @@ -0,0 +1,241 @@ +--- ocaml_502/utils/clflags.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/clflags.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -107,6 +107,7 @@ + let dump_parsetree = ref false (* -dparsetree *) + and dump_typedtree = ref false (* -dtypedtree *) + and dump_shape = ref false (* -dshape *) ++and dump_matchcomp = ref false (* -dmatchcomp *) + and dump_rawlambda = ref false (* -drawlambda *) + and dump_lambda = ref false (* -dlambda *) + and dump_rawclambda = ref false (* -drawclambda *) +@@ -124,19 +125,19 @@ + + and dump_cmm = ref false (* -dcmm *) + let dump_selection = ref false (* -dsel *) ++let dump_combine = ref false (* -dcombine *) + let dump_cse = ref false (* -dcse *) + let dump_live = ref false (* -dlive *) + let dump_spill = ref false (* -dspill *) + let dump_split = ref false (* -dsplit *) + let dump_interf = ref false (* -dinterf *) + let dump_prefer = ref false (* -dprefer *) ++let dump_interval = ref false (* -dinterval *) + let dump_regalloc = ref false (* -dalloc *) + let dump_reload = ref false (* -dreload *) + let dump_scheduling = ref false (* -dscheduling *) + let dump_linear = ref false (* -dlinear *) +-let dump_interval = ref false (* -dinterval *) + let keep_startup_file = ref false (* -dstartup *) +-let dump_combine = ref false (* -dcombine *) + let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *) + + let native_code = ref false (* set to true under ocamlopt *) +@@ -165,8 +166,8 @@ + let dlcode = ref true (* not -nodynlink *) + + let pic_code = ref (match Config.architecture with (* -fPIC *) +- | "amd64" -> true +- | _ -> false) ++ | "amd64" | "s390x" -> true ++ | _ -> false) + + let runtime_variant = ref "" + +@@ -551,6 +552,197 @@ + in + save_ir_after := new_passes + ++module Dump_option = struct ++ type t = ++ | Source ++ | Parsetree ++ | Typedtree ++ | Shape ++ | Match_comp ++ | Raw_lambda ++ | Lambda ++ | Instr ++ | Raw_clambda ++ | Clambda ++ | Raw_flambda ++ | Flambda ++ | Cmm ++ | Selection ++ | Combine ++ | CSE ++ | Live ++ | Spill ++ | Split ++ | Interf ++ | Prefer ++ | Regalloc ++ | Scheduling ++ | Linear ++ | Interval ++ ++ let compare (op1 : t) op2 = ++ Stdlib.compare op1 op2 ++ ++ let to_string = function ++ | Source -> "source" ++ | Parsetree -> "parsetree" ++ | Typedtree -> "typedtree" ++ | Shape -> "shape" ++ | Match_comp -> "matchcomp" ++ | Raw_lambda -> "rawlambda" ++ | Lambda -> "lambda" ++ | Instr -> "instr" ++ | Raw_clambda -> "rawclambda" ++ | Clambda -> "clambda" ++ | Raw_flambda -> "rawflambda" ++ | Flambda -> "flambda" ++ | Cmm -> "cmm" ++ | Selection -> "selection" ++ | Combine -> "combine" ++ | CSE -> "cse" ++ | Live -> "live" ++ | Spill -> "spill" ++ | Split -> "split" ++ | Interf -> "interf" ++ | Prefer -> "prefer" ++ | Regalloc -> "regalloc" ++ | Scheduling -> "scheduling" ++ | Linear -> "linear" ++ | Interval -> "interval" ++ ++ let of_string = function ++ | "source" -> Some Source ++ | "parsetree" -> Some Parsetree ++ | "typedtree" -> Some Typedtree ++ | "shape" -> Some Shape ++ | "matchcomp" -> Some Match_comp ++ | "rawlambda" -> Some Raw_lambda ++ | "lambda" -> Some Lambda ++ | "instr" -> Some Instr ++ | "rawclambda" -> Some Raw_clambda ++ | "clambda" -> Some Clambda ++ | "rawflambda" -> Some Raw_flambda ++ | "flambda" -> Some Flambda ++ | "cmm" -> Some Cmm ++ | "selection" -> Some Selection ++ | "combine" -> Some Combine ++ | "cse" -> Some CSE ++ | "live" -> Some Live ++ | "spill" -> Some Spill ++ | "split" -> Some Split ++ | "interf" -> Some Interf ++ | "prefer" -> Some Prefer ++ | "regalloc" -> Some Regalloc ++ | "scheduling" -> Some Scheduling ++ | "linear" -> Some Linear ++ | "interval" -> Some Interval ++ | _ -> None ++ ++ let flag = function ++ | Source -> dump_source ++ | Parsetree -> dump_parsetree ++ | Typedtree -> dump_typedtree ++ | Shape -> dump_shape ++ | Match_comp -> dump_matchcomp ++ | Raw_lambda -> dump_rawlambda ++ | Lambda -> dump_lambda ++ | Instr -> dump_instr ++ | Raw_clambda -> dump_rawclambda ++ | Clambda -> dump_clambda ++ | Raw_flambda -> dump_rawflambda ++ | Flambda -> dump_flambda ++ | Cmm -> dump_cmm ++ | Selection -> dump_selection ++ | Combine -> dump_combine ++ | CSE -> dump_cse ++ | Live -> dump_live ++ | Spill -> dump_spill ++ | Split -> dump_split ++ | Interf -> dump_interf ++ | Prefer -> dump_prefer ++ | Regalloc -> dump_regalloc ++ | Scheduling -> dump_scheduling ++ | Linear -> dump_linear ++ | Interval -> dump_interval ++ ++ type middle_end = ++ | Flambda ++ | Any ++ | Closure ++ ++ type class_ = ++ | Frontend ++ | Bytecode ++ | Middle of middle_end ++ | Backend ++ ++ let _ = ++ (* no Closure-specific dump option for now, silence a warning *) ++ Closure ++ ++ let classify : t -> class_ = function ++ | Source ++ | Parsetree ++ | Typedtree ++ | Shape ++ | Match_comp ++ | Raw_lambda ++ | Lambda ++ -> Frontend ++ | Instr ++ -> Bytecode ++ | Raw_clambda ++ | Clambda ++ -> Middle Any ++ | Raw_flambda ++ | Flambda ++ -> Middle Flambda ++ | Cmm ++ | Selection ++ | Combine ++ | CSE ++ | Live ++ | Spill ++ | Split ++ | Interf ++ | Prefer ++ | Regalloc ++ | Scheduling ++ | Linear ++ | Interval ++ -> Backend ++ ++ let available (option : t) : (unit, string) result = ++ let pass = Result.ok () in ++ let ( let* ) = Result.bind in ++ let fail descr = ++ Error ( ++ Printf.sprintf ++ "this compiler does not support %s-specific options" ++ descr ++ ) in ++ let guard descr cond = ++ if cond then pass ++ else fail descr in ++ let check_bytecode = guard "bytecode" (not !native_code) in ++ let check_native = guard "native" !native_code in ++ let check_middle_end = function ++ | Flambda -> guard "flambda" Config.flambda ++ | Closure -> guard "closure" (not Config.flambda) ++ | Any -> pass ++ in ++ match classify option with ++ | Frontend -> ++ pass ++ | Bytecode -> ++ check_bytecode ++ | Middle middle_end -> ++ let* () = check_native in ++ check_middle_end middle_end ++ | Backend -> ++ check_native ++end ++ + module String = Misc.Stdlib.String + + let arg_spec = ref [] diff --git a/upstream/patches_503/utils/clflags.mli.patch b/upstream/patches_503/utils/clflags.mli.patch new file mode 100644 index 000000000..45c4c69d2 --- /dev/null +++ b/upstream/patches_503/utils/clflags.mli.patch @@ -0,0 +1,62 @@ +--- ocaml_502/utils/clflags.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/clflags.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -135,6 +135,7 @@ + val dump_parsetree : bool ref + val dump_typedtree : bool ref + val dump_shape : bool ref ++val dump_matchcomp : bool ref + val dump_rawlambda : bool ref + val dump_lambda : bool ref + val dump_rawclambda : bool ref +@@ -253,11 +254,51 @@ + val to_output_filename: t -> prefix:string -> string + val of_input_filename: string -> t option + end ++ + val stop_after : Compiler_pass.t option ref + val should_stop_after : Compiler_pass.t -> bool + val set_save_ir_after : Compiler_pass.t -> bool -> unit + val should_save_ir_after : Compiler_pass.t -> bool + ++module Dump_option : sig ++ type t = ++ | Source ++ | Parsetree ++ | Typedtree ++ | Shape ++ | Match_comp ++ | Raw_lambda ++ | Lambda ++ | Instr ++ | Raw_clambda ++ | Clambda ++ | Raw_flambda ++ | Flambda ++ (* Note: no support for [-dflambda-let ] for now. *) ++ | Cmm ++ | Selection ++ | Combine ++ | CSE ++ | Live ++ | Spill ++ | Split ++ | Interf ++ | Prefer ++ | Regalloc ++ | Scheduling ++ | Linear ++ | Interval ++ ++ val compare : t -> t -> int ++ ++ val of_string : string -> t option ++ val to_string : t -> string ++ ++ val flag : t -> bool ref ++ ++ val available : t -> (unit, string) Result.t ++end ++ + val arg_spec : (string * Arg.spec * string) list ref + + (* [add_arguments __LOC__ args] will add the arguments from [args] at diff --git a/upstream/patches_503/utils/compression.ml.patch b/upstream/patches_503/utils/compression.ml.patch new file mode 100644 index 000000000..7c84e319b --- /dev/null +++ b/upstream/patches_503/utils/compression.ml.patch @@ -0,0 +1,34 @@ +--- ocaml_502/utils/compression.ml 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/compression.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,31 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Xavier Leroy, Collège de France and Inria project Cambium *) ++(* *) ++(* Copyright 2023 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++external zstd_initialize: unit -> bool = "caml_zstd_initialize" ++ ++let compression_supported = zstd_initialize () ++ ++type [@warning "-unused-constructor"] extern_flags = ++ No_sharing (** Don't preserve sharing *) ++ | Closures (** Send function closures *) ++ | Compat_32 (** Ensure 32-bit compatibility *) ++ | Compression (** Optional compression *) ++ ++external to_channel: out_channel -> 'a -> extern_flags list -> unit ++ = "caml_output_value" ++ ++let output_value ch v = to_channel ch v [Compression] ++ ++let input_value = Stdlib.input_value diff --git a/upstream/patches_503/utils/compression.mli.patch b/upstream/patches_503/utils/compression.mli.patch new file mode 100644 index 000000000..df53f5836 --- /dev/null +++ b/upstream/patches_503/utils/compression.mli.patch @@ -0,0 +1,37 @@ +--- ocaml_502/utils/compression.mli 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/compression.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,34 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Xavier Leroy, Collège de France and Inria project Cambium *) ++(* *) ++(* Copyright 2023 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++val output_value : out_channel -> 'a -> unit ++(** [Compression.output_value chan v] writes the representation ++ of [v] on channel [chan]. ++ If compression is supported, the marshaled data ++ representing value [v] is compressed before being written to ++ channel [chan]. ++ If compression is not supported, this function behaves like ++ {!Stdlib.output_value}. *) ++ ++val input_value : in_channel -> 'a ++(** [Compression.input_value chan] reads from channel [chan] the ++ byte representation of a structured value, as produced by ++ [Compression.output_value], and reconstructs and ++ returns the corresponding value. ++ If compression is not supported, this function behaves like ++ {!Stdlib.input_value}. *) ++ ++val compression_supported : bool ++(** Reports whether compression is supported. *) diff --git a/upstream/patches_503/utils/config.common.ml.in.patch b/upstream/patches_503/utils/config.common.ml.in.patch new file mode 100644 index 000000000..59be4ddcb --- /dev/null +++ b/upstream/patches_503/utils/config.common.ml.in.patch @@ -0,0 +1,166 @@ +--- ocaml_502/utils/config.common.ml.in 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/config.common.ml.in 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,163 @@ ++(* @configure_input@ *) ++#3 "utils/config.common.ml.in" ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) ++(* *) ++(* Copyright 1996 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* Portions of the Config module common to both the boot and main compiler. *) ++ ++(* The main OCaml version string has moved to ../build-aux/ocaml_version.m4 *) ++let version = Sys.ocaml_version ++ ++let standard_library = ++ try ++ Sys.getenv "OCAMLLIB" ++ with Not_found -> ++ try ++ Sys.getenv "CAMLLIB" ++ with Not_found -> ++ standard_library_default ++ ++let exec_magic_number = {magic|@EXEC_MAGIC_NUMBER@|magic} ++ (* exec_magic_number is duplicated in runtime/caml/exec.h *) ++and cmi_magic_number = {magic|@CMI_MAGIC_NUMBER@|magic} ++and cmo_magic_number = {magic|@CMO_MAGIC_NUMBER@|magic} ++and cma_magic_number = {magic|@CMA_MAGIC_NUMBER@|magic} ++and cmx_magic_number = {magic|@CMX_MAGIC_NUMBER@|magic} ++and cmxa_magic_number = {magic|@CMXA_MAGIC_NUMBER@|magic} ++and ast_impl_magic_number = {magic|@AST_IMPL_MAGIC_NUMBER@|magic} ++and ast_intf_magic_number = {magic|@AST_INTF_MAGIC_NUMBER@|magic} ++and cmxs_magic_number = {magic|@CMXS_MAGIC_NUMBER@|magic} ++and cmt_magic_number = {magic|@CMT_MAGIC_NUMBER@|magic} ++and linear_magic_number = {magic|@LINEAR_MAGIC_NUMBER@|magic} ++ ++let safe_string = true ++let default_safe_string = true ++let naked_pointers = false ++ ++let interface_suffix = ref ".mli" ++ ++let max_tag = 243 ++(* This is normally the same as in obj.ml, but we have to define it ++ separately because it can differ when we're in the middle of a ++ bootstrapping phase. *) ++let lazy_tag = 246 ++ ++let max_young_wosize = 256 ++let stack_threshold = 32 (* see runtime/caml/config.h *) ++let stack_safety_margin = 6 ++let default_executable_name = ++ match Sys.os_type with ++ "Unix" -> "a.out" ++ | "Win32" | "Cygwin" -> "camlprog.exe" ++ | _ -> "camlprog" ++type configuration_value = ++ | String of string ++ | Int of int ++ | Bool of bool ++ ++let configuration_variables () = ++ let p x v = (x, String v) in ++ let p_int x v = (x, Int v) in ++ let p_bool x v = (x, Bool v) in ++[ ++ p "version" version; ++ p "standard_library_default" standard_library_default; ++ p "standard_library" standard_library; ++ p "ccomp_type" ccomp_type; ++ p "c_compiler" c_compiler; ++ p "bytecode_cflags" bytecode_cflags; ++ p "ocamlc_cflags" bytecode_cflags; ++ p "bytecode_cppflags" bytecode_cppflags; ++ p "ocamlc_cppflags" bytecode_cppflags; ++ p "native_cflags" native_cflags; ++ p "ocamlopt_cflags" native_cflags; ++ p "native_cppflags" native_cppflags; ++ p "ocamlopt_cppflags" native_cppflags; ++ p "bytecomp_c_compiler" bytecomp_c_compiler; ++ p "native_c_compiler" native_c_compiler; ++ p "bytecomp_c_libraries" bytecomp_c_libraries; ++ p "native_c_libraries" native_c_libraries; ++ p "native_ldflags" native_ldflags; ++ p "native_pack_linker" native_pack_linker; ++ p_bool "native_compiler" native_compiler; ++ p "architecture" architecture; ++ p "model" model; ++ p_int "int_size" Sys.int_size; ++ p_int "word_size" Sys.word_size; ++ p "system" system; ++ p "asm" asm; ++ p_bool "asm_cfi_supported" asm_cfi_supported; ++ p_bool "with_frame_pointers" with_frame_pointers; ++ p "ext_exe" ext_exe; ++ p "ext_obj" ext_obj; ++ p "ext_asm" ext_asm; ++ p "ext_lib" ext_lib; ++ p "ext_dll" ext_dll; ++ p "os_type" Sys.os_type; ++ p "default_executable_name" default_executable_name; ++ p_bool "systhread_supported" systhread_supported; ++ p "host" host; ++ p "target" target; ++ p_bool "flambda" flambda; ++ p_bool "safe_string" safe_string; ++ p_bool "default_safe_string" default_safe_string; ++ p_bool "flat_float_array" flat_float_array; ++ p_bool "function_sections" function_sections; ++ p_bool "afl_instrument" afl_instrument; ++ p_bool "tsan" tsan; ++ p_bool "windows_unicode" windows_unicode; ++ p_bool "supports_shared_libraries" supports_shared_libraries; ++ p_bool "native_dynlink" native_dynlink; ++ p_bool "naked_pointers" naked_pointers; ++ ++ p "exec_magic_number" exec_magic_number; ++ p "cmi_magic_number" cmi_magic_number; ++ p "cmo_magic_number" cmo_magic_number; ++ p "cma_magic_number" cma_magic_number; ++ p "cmx_magic_number" cmx_magic_number; ++ p "cmxa_magic_number" cmxa_magic_number; ++ p "ast_impl_magic_number" ast_impl_magic_number; ++ p "ast_intf_magic_number" ast_intf_magic_number; ++ p "cmxs_magic_number" cmxs_magic_number; ++ p "cmt_magic_number" cmt_magic_number; ++ p "linear_magic_number" linear_magic_number; ++] ++ ++let print_config_value oc = function ++ | String s -> ++ Printf.fprintf oc "%s" s ++ | Int n -> ++ Printf.fprintf oc "%d" n ++ | Bool p -> ++ Printf.fprintf oc "%B" p ++ ++let print_config oc = ++ let print (x, v) = ++ Printf.fprintf oc "%s: %a\n" x print_config_value v in ++ List.iter print (configuration_variables ()); ++ flush oc ++ ++let config_var x = ++ match List.assoc_opt x (configuration_variables()) with ++ | None -> None ++ | Some v -> ++ let s = match v with ++ | String s -> s ++ | Int n -> Int.to_string n ++ | Bool b -> string_of_bool b ++ in ++ Some s ++ ++let merlin = false diff --git a/upstream/patches_503/utils/config.fixed.ml.patch b/upstream/patches_503/utils/config.fixed.ml.patch new file mode 100644 index 000000000..332a8993e --- /dev/null +++ b/upstream/patches_503/utils/config.fixed.ml.patch @@ -0,0 +1,17 @@ +--- ocaml_502/utils/config.fixed.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/config.fixed.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -27,10 +27,10 @@ + let c_output_obj = "" + let c_has_debug_prefix_map = false + let as_has_debug_prefix_map = false +-let ocamlc_cflags = "" +-let ocamlc_cppflags = "" +-let ocamlopt_cflags = "" +-let ocamlopt_cppflags = "" ++let bytecode_cflags = "" ++let bytecode_cppflags = "" ++let native_cflags = "" ++let native_cppflags = "" + let bytecomp_c_libraries = "" + let bytecomp_c_compiler = "" + let native_c_compiler = c_compiler diff --git a/upstream/patches_503/utils/config.generated.ml.in.patch b/upstream/patches_503/utils/config.generated.ml.in.patch new file mode 100644 index 000000000..8b4ebddad --- /dev/null +++ b/upstream/patches_503/utils/config.generated.ml.in.patch @@ -0,0 +1,97 @@ +--- ocaml_502/utils/config.generated.ml.in 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/config.generated.ml.in 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,94 @@ ++(* @configure_input@ *) ++#2 "utils/config.generated.ml.in" ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) ++(* *) ++(* Copyright 1996 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(* This file is included in config_main.ml during the build rather ++ than compiled on its own *) ++ ++let bindir = {@QS@|@ocaml_bindir@|@QS@} ++ ++let standard_library_default = {@QS@|@ocaml_libdir@|@QS@} ++ ++let ccomp_type = {@QS@|@ccomptype@|@QS@} ++let c_compiler = {@QS@|@CC@|@QS@} ++let c_output_obj = {@QS@|@outputobj@|@QS@} ++let c_has_debug_prefix_map = @cc_has_debug_prefix_map@ ++let as_has_debug_prefix_map = @as_has_debug_prefix_map@ ++let bytecode_cflags = {@QS@|@bytecode_cflags@|@QS@} ++let bytecode_cppflags = {@QS@|@bytecode_cppflags@|@QS@} ++let native_cflags = {@QS@|@native_cflags@|@QS@} ++let native_cppflags = {@QS@|@native_cppflags@|@QS@} ++ ++let bytecomp_c_libraries = {@QS@|@zstd_libs@ @cclibs@|@QS@} ++(* bytecomp_c_compiler and native_c_compiler have been supported for a ++ long time and are retained for backwards compatibility. ++ For programs that don't need compatibility with older OCaml releases ++ the recommended approach is to use the constituent variables ++ c_compiler, {bytecode,native}_c[pp]flags etc. directly. ++*) ++let bytecomp_c_compiler = ++ c_compiler ^ " " ^ bytecode_cflags ^ " " ^ bytecode_cppflags ++let native_c_compiler = ++ c_compiler ^ " " ^ native_cflags ^ " " ^ native_cppflags ++let native_c_libraries = {@QS@|@cclibs@|@QS@} ++let native_ldflags = {@QS@|@native_ldflags@|@QS@} ++let native_pack_linker = {@QS@|@PACKLD@|@QS@} ++let default_rpath = {@QS@|@rpath@|@QS@} ++let mksharedlibrpath = {@QS@|@mksharedlibrpath@|@QS@} ++let ar = {@QS@|@AR@|@QS@} ++let supports_shared_libraries = @supports_shared_libraries@ ++let native_dynlink = @natdynlink@ ++let mkdll = {@QS@|@mkdll_exp@|@QS@} ++let mkexe = {@QS@|@mkexe_exp@|@QS@} ++let mkmaindll = {@QS@|@mkmaindll_exp@|@QS@} ++ ++let flambda = @flambda@ ++let with_flambda_invariants = @flambda_invariants@ ++let with_cmm_invariants = @cmm_invariants@ ++let windows_unicode = @windows_unicode@ != 0 ++ ++let flat_float_array = @flat_float_array@ ++ ++let function_sections = @function_sections@ ++let afl_instrument = @afl@ ++ ++let native_compiler = @native_compiler@ ++ ++let architecture = {@QS@|@arch@|@QS@} ++let model = {@QS@|@model@|@QS@} ++let system = {@QS@|@system@|@QS@} ++ ++let asm = {@QS@|@AS@|@QS@} ++let asm_cfi_supported = @asm_cfi_supported@ ++let with_frame_pointers = @frame_pointers@ ++let reserved_header_bits = @reserved_header_bits@ ++ ++let ext_exe = {@QS@|@exeext@|@QS@} ++let ext_obj = "." ^ {@QS@|@OBJEXT@|@QS@} ++let ext_asm = "." ^ {@QS@|@S@|@QS@} ++let ext_lib = "." ^ {@QS@|@libext@|@QS@} ++let ext_dll = "." ^ {@QS@|@SO@|@QS@} ++ ++let host = {@QS@|@host@|@QS@} ++let target = {@QS@|@target@|@QS@} ++ ++let systhread_supported = @systhread_support@ ++ ++let flexdll_dirs = [@flexdll_dir@] ++ ++let ar_supports_response_files = @ar_supports_response_files@ ++ ++let tsan = @tsan@ diff --git a/upstream/patches_503/utils/config.mli.patch b/upstream/patches_503/utils/config.mli.patch new file mode 100644 index 000000000..d443f6fb5 --- /dev/null +++ b/upstream/patches_503/utils/config.mli.patch @@ -0,0 +1,30 @@ +--- ocaml_502/utils/config.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/config.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -47,21 +47,17 @@ + val as_has_debug_prefix_map : bool + (** Whether the assembler supports --debug-prefix-map *) + +-val ocamlc_cflags : string ++val bytecode_cflags : string + (** The flags ocamlc should pass to the C compiler *) + +-val ocamlc_cppflags : string ++val bytecode_cppflags : string + (** The flags ocamlc should pass to the C preprocessor *) + +-val ocamlopt_cflags : string +- [@@ocaml.deprecated "Use ocamlc_cflags instead."] +-(** @deprecated {!ocamlc_cflags} should be used instead. +- The flags ocamlopt should pass to the C compiler *) ++val native_cflags : string ++(** The flags ocamlopt should pass to the C compiler *) + +-val ocamlopt_cppflags : string +- [@@ocaml.deprecated "Use ocamlc_cppflags instead."] +-(** @deprecated {!ocamlc_cppflags} should be used instead. +- The flags ocamlopt should pass to the C preprocessor *) ++val native_cppflags : string ++(** The flags ocamlopt should pass to the C preprocessor *) + + val bytecomp_c_libraries: string + (** The C libraries to link with custom runtimes *) diff --git a/upstream/patches_503/utils/diffing.ml.patch b/upstream/patches_503/utils/diffing.ml.patch new file mode 100644 index 000000000..1c003110c --- /dev/null +++ b/upstream/patches_503/utils/diffing.ml.patch @@ -0,0 +1,41 @@ +--- ocaml_502/utils/diffing.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/diffing.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -42,10 +42,11 @@ + | Modification -> Misc.Style.[ FG Magenta; Bold] + + let prefix ppf (pos, p) = ++ let open Format_doc in + let sty = style p in +- Format.pp_open_stag ppf (Misc.Style.Style sty); +- Format.fprintf ppf "%i. " pos; +- Format.pp_close_stag ppf () ++ pp_open_stag ppf (Misc.Style.Style sty); ++ fprintf ppf "%i. " pos; ++ pp_close_stag ppf () + + + let (let*) = Option.bind +@@ -346,7 +347,22 @@ + compute_proposition (i-1) (j-1) diff + in + let*! newweight, (diff, localstate) = +- select_best_proposition [diag;del;insert] ++ (* The order of propositions is important here: ++ the call [select_best_proposition [P_0, ...; P_n]] keeps the first ++ proposition with minimal weight as the representative path for this ++ weight class at the current matrix position. ++ ++ By induction, the representative path for the minimal weight class will ++ be the smallest path according to the reverse lexical order induced by ++ the element order [[P_0;...; P_n]]. ++ ++ This is why we choose to start with the [Del] case since path ending with ++ [Del+] suffix are likely to correspond to parital application in the ++ functor application case. ++ Similarly, large block of deletions or insertions at the end of the ++ definitions might point toward incomplete definitions. ++ Thus this seems a good overall setting. *) ++ select_best_proposition [del;insert;diag] + in + let state = update diff localstate in + Matrix.set tbl i j ~weight:newweight ~state ~diff:(Some diff) diff --git a/upstream/patches_503/utils/diffing.mli.patch b/upstream/patches_503/utils/diffing.mli.patch new file mode 100644 index 000000000..73249fdbd --- /dev/null +++ b/upstream/patches_503/utils/diffing.mli.patch @@ -0,0 +1,11 @@ +--- ocaml_502/utils/diffing.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/diffing.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -79,7 +79,7 @@ + | Insertion + | Modification + | Preservation +-val prefix: Format.formatter -> (int * change_kind) -> unit ++val prefix: (int * change_kind) Format_doc.printer + val style: change_kind -> Misc.Style.style list + + diff --git a/upstream/patches_503/utils/diffing_with_keys.ml.patch b/upstream/patches_503/utils/diffing_with_keys.ml.patch new file mode 100644 index 000000000..abe455b1b --- /dev/null +++ b/upstream/patches_503/utils/diffing_with_keys.ml.patch @@ -0,0 +1,22 @@ +--- ocaml_502/utils/diffing_with_keys.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/diffing_with_keys.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -37,8 +37,8 @@ + in + let style k ppf inner = + let sty = Diffing.style k in +- Format.pp_open_stag ppf (Misc.Style.Style sty); +- Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner ++ Format_doc.pp_open_stag ppf (Misc.Style.Style sty); ++ Format_doc.kfprintf (fun ppf -> Format_doc.pp_close_stag ppf () ) ppf inner + in + match x with + | Change (Name {pos; _ } | Type {pos; _}) +@@ -53,7 +53,7 @@ + + (** To detect [move] and [swaps], we are using the fact that + there are 2-cycles in the graph of name renaming. +- - [Change (x,y,_) is then an edge from ++ - [Change (x,y,_)] is then an edge from + [key_left x] to [key_right y]. + - [Insert x] is an edge between the special node epsilon and + [key_left x] diff --git a/upstream/patches_503/utils/diffing_with_keys.mli.patch b/upstream/patches_503/utils/diffing_with_keys.mli.patch new file mode 100644 index 000000000..6ee41f093 --- /dev/null +++ b/upstream/patches_503/utils/diffing_with_keys.mli.patch @@ -0,0 +1,11 @@ +--- ocaml_502/utils/diffing_with_keys.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/diffing_with_keys.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -46,7 +46,7 @@ + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +-val prefix: Format.formatter -> ('l,'r,'diff) change -> unit ++val prefix: ('l,'r,'diff) change Format_doc.printer + + module Define(D:Diffing.Defs with type eq := unit): sig + diff --git a/upstream/patches_503/utils/domainstate.ml.c.patch b/upstream/patches_503/utils/domainstate.ml.c.patch new file mode 100644 index 000000000..d2c8d7031 --- /dev/null +++ b/upstream/patches_503/utils/domainstate.ml.c.patch @@ -0,0 +1,41 @@ +--- ocaml_502/utils/domainstate.ml.c 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/domainstate.ml.c 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,38 @@ ++/**************************************************************************/ ++/* */ ++/* OCaml */ ++/* */ ++/* KC Sivaramakrishnan, Indian Institute of Technology, Madras */ ++/* Stephen Dolan, University of Cambridge */ ++/* */ ++/* Copyright 2019 Indian Institute of Technology, Madras */ ++/* Copyright 2019 University of Cambridge */ ++/* */ ++/* All rights reserved. This file is distributed under the terms of */ ++/* the GNU Lesser General Public License version 2.1, with the */ ++/* special exception on linking described in the file LICENSE. */ ++/* */ ++/**************************************************************************/ ++ ++#define CAML_CONFIG_H_NO_TYPEDEFS ++#include "config.h" ++let stack_ctx_words = Stack_ctx_words ++ ++type t = ++#define DOMAIN_STATE(type, name) | Domain_##name ++#include "domain_state.tbl" ++#undef DOMAIN_STATE ++ ++let idx_of_field = ++ let curr = 0 in ++#define DOMAIN_STATE(type, name) \ ++ let idx__##name = curr in \ ++ let curr = curr + 1 in ++#include "domain_state.tbl" ++#undef DOMAIN_STATE ++ let _ = curr in ++ function ++#define DOMAIN_STATE(type, name) \ ++ | Domain_##name -> idx__##name ++#include "domain_state.tbl" ++#undef DOMAIN_STATE diff --git a/upstream/patches_503/utils/domainstate.mli.c.patch b/upstream/patches_503/utils/domainstate.mli.c.patch new file mode 100644 index 000000000..ba3f0782c --- /dev/null +++ b/upstream/patches_503/utils/domainstate.mli.c.patch @@ -0,0 +1,27 @@ +--- ocaml_502/utils/domainstate.mli.c 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/domainstate.mli.c 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,24 @@ ++/**************************************************************************/ ++/* */ ++/* OCaml */ ++/* */ ++/* KC Sivaramakrishnan, Indian Institute of Technology, Madras */ ++/* Stephen Dolan, University of Cambridge */ ++/* */ ++/* Copyright 2019 Indian Institute of Technology, Madras */ ++/* Copyright 2019 University of Cambridge */ ++/* */ ++/* All rights reserved. This file is distributed under the terms of */ ++/* the GNU Lesser General Public License version 2.1, with the */ ++/* special exception on linking described in the file LICENSE. */ ++/* */ ++/**************************************************************************/ ++ ++val stack_ctx_words : int ++ ++type t = ++#define DOMAIN_STATE(type, name) | Domain_##name ++#include "domain_state.tbl" ++#undef DOMAIN_STATE ++ ++val idx_of_field : t -> int diff --git a/upstream/patches_503/utils/format_doc.ml.patch b/upstream/patches_503/utils/format_doc.ml.patch new file mode 100644 index 000000000..a7e2c8952 --- /dev/null +++ b/upstream/patches_503/utils/format_doc.ml.patch @@ -0,0 +1,484 @@ +--- ocaml_502/utils/format_doc.ml 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/format_doc.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,481 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Florian Angeletti, projet Cambium, Inria Paris *) ++(* *) ++(* Copyright 2021 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++module Doc = struct ++ ++ type box_type = ++ | H ++ | V ++ | HV ++ | HoV ++ | B ++ ++ type stag = Format.stag ++ ++ type element = ++ | Text of string ++ | With_size of int ++ | Open_box of { kind: box_type ; indent:int } ++ | Close_box ++ | Open_tag of Format.stag ++ | Close_tag ++ | Open_tbox ++ | Tab_break of { width : int; offset : int } ++ | Set_tab ++ | Close_tbox ++ | Simple_break of { spaces : int; indent: int } ++ | Break of { fits : string * int * string as 'a; breaks : 'a } ++ | Flush of { newline:bool } ++ | Newline ++ | If_newline ++ ++ | Deprecated of (Format.formatter -> unit) ++ ++ type t = { rev:element list } [@@unboxed] ++ ++ let empty = { rev = [] } ++ ++ let to_list doc = List.rev doc.rev ++ let add doc x = { rev = x :: doc.rev } ++ let fold f acc doc = List.fold_left f acc (to_list doc) ++ let append left right = { rev = right.rev @ left.rev } ++ ++ let format_open_box_gen ppf kind indent = ++ match kind with ++ | H-> Format.pp_open_hbox ppf () ++ | V -> Format.pp_open_vbox ppf indent ++ | HV -> Format.pp_open_hvbox ppf indent ++ | HoV -> Format.pp_open_hovbox ppf indent ++ | B -> Format.pp_open_box ppf indent ++ ++ let interpret_elt ppf = function ++ | Text x -> Format.pp_print_string ppf x ++ | Open_box { kind; indent } -> format_open_box_gen ppf kind indent ++ | Close_box -> Format.pp_close_box ppf () ++ | Open_tag tag -> Format.pp_open_stag ppf tag ++ | Close_tag -> Format.pp_close_stag ppf () ++ | Open_tbox -> Format.pp_open_tbox ppf () ++ | Tab_break {width;offset} -> Format.pp_print_tbreak ppf width offset ++ | Set_tab -> Format.pp_set_tab ppf () ++ | Close_tbox -> Format.pp_close_tbox ppf () ++ | Simple_break {spaces;indent} -> Format.pp_print_break ppf spaces indent ++ | Break {fits;breaks} -> Format.pp_print_custom_break ppf ~fits ~breaks ++ | Flush {newline=true} -> Format.pp_print_newline ppf () ++ | Flush {newline=false} -> Format.pp_print_flush ppf () ++ | Newline -> Format.pp_force_newline ppf () ++ | If_newline -> Format.pp_print_if_newline ppf () ++ | With_size _ -> () ++ | Deprecated pr -> pr ppf ++ ++ let rec interpret ppf = function ++ | [] -> () ++ | With_size size :: Text text :: l -> ++ Format.pp_print_as ppf size text; ++ interpret ppf l ++ | x :: l -> ++ interpret_elt ppf x; ++ interpret ppf l ++ ++ let format ppf doc = interpret ppf (to_list doc) ++ ++ ++ ++ let open_box kind indent doc = add doc (Open_box {kind;indent}) ++ let close_box doc = add doc Close_box ++ ++ let string s doc = add doc (Text s) ++ let bytes b doc = add doc (Text (Bytes.to_string b)) ++ let with_size size doc = add doc (With_size size) ++ ++ let int n doc = add doc (Text (string_of_int n)) ++ let float f doc = add doc (Text (string_of_float f)) ++ let char c doc = add doc (Text (String.make 1 c)) ++ let bool c doc = add doc (Text (Bool.to_string c)) ++ ++ let break ~spaces ~indent doc = add doc (Simple_break {spaces; indent}) ++ let space doc = break ~spaces:1 ~indent:0 doc ++ let cut = break ~spaces:0 ~indent:0 ++ ++ let custom_break ~fits ~breaks doc = add doc (Break {fits;breaks}) ++ ++ let force_newline doc = add doc Newline ++ let if_newline doc = add doc If_newline ++ ++ let flush doc = add doc (Flush {newline=false}) ++ let force_stop doc = add doc (Flush {newline=true}) ++ ++ let open_tbox doc = add doc Open_tbox ++ let set_tab doc = add doc Set_tab ++ let tab_break ~width ~offset doc = add doc (Tab_break {width;offset}) ++ let tab doc = tab_break ~width:0 ~offset:0 doc ++ let close_tbox doc = add doc Close_tbox ++ ++ let open_tag stag doc = add doc (Open_tag stag) ++ let close_tag doc = add doc Close_tag ++ ++ let iter ?(sep=Fun.id) ~iter:iterator elt l doc = ++ let first = ref true in ++ let rdoc = ref doc in ++ let print x = ++ if !first then (first := false; rdoc := elt x !rdoc) ++ else rdoc := !rdoc |> sep |> elt x ++ in ++ iterator print l; ++ !rdoc ++ ++ let rec list ?(sep=Fun.id) elt l doc = match l with ++ | [] -> doc ++ | [a] -> elt a doc ++ | a :: ((_ :: _) as q) -> ++ doc |> elt a |> sep |> list ~sep elt q ++ ++ let array ?sep elt a doc = iter ?sep ~iter:Array.iter elt a doc ++ let seq ?sep elt s doc = iter ?sep ~iter:Seq.iter elt s doc ++ ++ let option ?(none=Fun.id) elt o doc = match o with ++ | None -> none doc ++ | Some x -> elt x doc ++ ++ let either ~left ~right x doc = match x with ++ | Either.Left x -> left x doc ++ | Either.Right x -> right x doc ++ ++ let result ~ok ~error x doc = match x with ++ | Ok x -> ok x doc ++ | Error x -> error x doc ++ ++ (* To format free-flowing text *) ++ let rec subtext len left right s doc = ++ let flush doc = ++ doc |> string (String.sub s left (right - left)) ++ in ++ let after_flush doc = subtext len (right+1) (right+1) s doc in ++ if right = len then ++ if left <> len then flush doc else doc ++ else ++ match s.[right] with ++ | '\n' -> ++ doc |> flush |> force_newline |> after_flush ++ | ' ' -> ++ doc |> flush |> space |> after_flush ++ (* there is no specific support for '\t' ++ as it is unclear what a right semantics would be *) ++ | _ -> subtext len left (right + 1) s doc ++ ++ let text s doc = ++ subtext (String.length s) 0 0 s doc ++ ++ type ('a,'b) fmt = ('a, t, t, 'b) format4 ++ type printer0 = t -> t ++ type 'a printer = 'a -> printer0 ++ ++ let output_formatting_lit fmting_lit doc = ++ let open CamlinternalFormatBasics in ++ match fmting_lit with ++ | Close_box -> close_box doc ++ | Close_tag -> close_tag doc ++ | Break (_, width, offset) -> break ~spaces:width ~indent:offset doc ++ | FFlush -> flush doc ++ | Force_newline -> force_newline doc ++ | Flush_newline -> force_stop doc ++ | Magic_size (_, n) -> with_size n doc ++ | Escaped_at -> char '@' doc ++ | Escaped_percent -> char '%' doc ++ | Scan_indic c -> doc |> char '@' |> char c ++ ++ let to_string doc = ++ let b = Buffer.create 20 in ++ let convert = function ++ | Text s -> Buffer.add_string b s ++ | _ -> () ++ in ++ fold (fun () x -> convert x) () doc; ++ Buffer.contents b ++ ++ let box_type = ++ let open CamlinternalFormatBasics in ++ function ++ | Pp_fits -> H ++ | Pp_hbox -> H ++ | Pp_vbox -> V ++ | Pp_hovbox -> HoV ++ | Pp_hvbox -> HV ++ | Pp_box -> B ++ ++ let rec compose_acc acc doc = ++ let open CamlinternalFormat in ++ match acc with ++ | CamlinternalFormat.Acc_formatting_lit (p, f) -> ++ doc |> compose_acc p |> output_formatting_lit f ++ | Acc_formatting_gen (p, Acc_open_tag acc') -> ++ let tag = to_string (compose_acc acc' empty) in ++ let doc = compose_acc p doc in ++ doc |> open_tag (Format.String_tag tag) ++ | Acc_formatting_gen (p, Acc_open_box acc') -> ++ let doc = compose_acc p doc in ++ let box = to_string (compose_acc acc' empty) in ++ let (indent, bty) = CamlinternalFormat.open_box_of_string box in ++ doc |> open_box (box_type bty) indent ++ | Acc_string_literal (p, s) ++ | Acc_data_string (p, s) -> ++ doc |> compose_acc p |> string s ++ | Acc_char_literal (p, c) ++ | Acc_data_char (p, c) -> doc |> compose_acc p |> char c ++ | Acc_delay (p, f) -> doc |> compose_acc p |> f ++ | Acc_flush p -> doc |> compose_acc p |> flush ++ | Acc_invalid_arg (_p, msg) -> invalid_arg msg; ++ | End_of_acc -> doc ++ ++ let kprintf k (CamlinternalFormatBasics.Format (fmt, _)) = ++ CamlinternalFormat.make_printf ++ (fun acc doc -> doc |> compose_acc acc |> k ) ++ End_of_acc fmt ++ ++ let printf doc = kprintf Fun.id doc ++ let kmsg k (CamlinternalFormatBasics.Format (fmt, _)) = ++ CamlinternalFormat.make_printf ++ (fun acc -> k (compose_acc acc empty)) ++ End_of_acc fmt ++ ++ let msg fmt = kmsg Fun.id fmt ++ ++end ++ ++(** Compatibility interface *) ++ ++type doc = Doc.t ++type t = doc ++type formatter = doc ref ++type 'a printer = formatter -> 'a -> unit ++ ++let formatter d = d ++ ++(** {1 Primitive functions }*) ++ ++let pp_print_string ppf s = ppf := Doc.string s !ppf ++ ++let pp_print_as ppf size s = ++ ppf := !ppf |> Doc.with_size size |> Doc.string s ++ ++let pp_print_substring ~pos ~len ppf s = ++ ppf := Doc.string (String.sub s pos len) !ppf ++ ++let pp_print_substring_as ~pos ~len ppf size s = ++ ppf := ++ !ppf ++ |> Doc.with_size size ++ |> Doc.string (String.sub s pos len) ++ ++let pp_print_bytes ppf s = ppf := Doc.string (Bytes.to_string s) !ppf ++let pp_print_text ppf s = ppf := Doc.text s !ppf ++let pp_print_char ppf c = ppf := Doc.char c !ppf ++let pp_print_int ppf c = ppf := Doc.int c !ppf ++let pp_print_float ppf f = ppf := Doc.float f !ppf ++let pp_print_bool ppf b = ppf := Doc.bool b !ppf ++let pp_print_nothing _ _ = () ++ ++let pp_close_box ppf () = ppf := Doc.close_box !ppf ++let pp_close_stag ppf () = ppf := Doc.close_tag !ppf ++ ++let pp_print_break ppf spaces indent = ppf := Doc.break ~spaces ~indent !ppf ++ ++let pp_print_custom_break ppf ~fits ~breaks = ++ ppf := Doc.custom_break ~fits ~breaks !ppf ++ ++let pp_print_space ppf () = pp_print_break ppf 1 0 ++let pp_print_cut ppf () = pp_print_break ppf 0 0 ++ ++let pp_print_flush ppf () = ppf := Doc.flush !ppf ++let pp_force_newline ppf () = ppf := Doc.force_newline !ppf ++let pp_print_newline ppf () = ppf := Doc.force_stop !ppf ++let pp_print_if_newline ppf () =ppf := Doc.if_newline !ppf ++ ++let pp_open_stag ppf stag = ppf := !ppf |> Doc.open_tag stag ++ ++let pp_open_box_gen ppf indent bxty = ++ let box_type = Doc.box_type bxty in ++ ppf := !ppf |> Doc.open_box box_type indent ++ ++let pp_open_box ppf indent = pp_open_box_gen ppf indent Pp_box ++ ++ ++let pp_open_tbox ppf () = ppf := !ppf |> Doc.open_tbox ++ ++let pp_close_tbox ppf () = ppf := !ppf |> Doc.close_tbox ++ ++let pp_set_tab ppf () = ppf := !ppf |> Doc.set_tab ++ ++let pp_print_tab ppf () = ppf := !ppf |> Doc.tab ++ ++let pp_print_tbreak ppf width offset = ++ ppf := !ppf |> Doc.tab_break ~width ~offset ++ ++let pp_doc ppf doc = ppf := Doc.append !ppf doc ++ ++module Driver = struct ++ (* Interpret a formatting entity on a formatter. *) ++ let output_formatting_lit ppf ++ (fmting_lit:CamlinternalFormatBasics.formatting_lit) ++ = match fmting_lit with ++ | Close_box -> pp_close_box ppf () ++ | Close_tag -> pp_close_stag ppf () ++ | Break (_, width, offset) -> pp_print_break ppf width offset ++ | FFlush -> pp_print_flush ppf () ++ | Force_newline -> pp_force_newline ppf () ++ | Flush_newline -> pp_print_newline ppf () ++ | Magic_size (_, _) -> () ++ | Escaped_at -> pp_print_char ppf '@' ++ | Escaped_percent -> pp_print_char ppf '%' ++ | Scan_indic c -> pp_print_char ppf '@'; pp_print_char ppf c ++ ++ ++ ++ let compute_tag output tag_acc = ++ let buf = Buffer.create 16 in ++ let buf_fmt = Format.formatter_of_buffer buf in ++ let ppf = ref Doc.empty in ++ output ppf tag_acc; ++ pp_print_flush ppf (); ++ Doc.format buf_fmt !ppf; ++ let len = Buffer.length buf in ++ if len < 2 then Buffer.contents buf ++ else Buffer.sub buf 1 (len - 2) ++ ++ (* Recursively output an "accumulator" containing a reversed list of ++ printing entities (string, char, flus, ...) in an output_stream. *) ++ (* Differ from Printf.output_acc by the interpretation of formatting. *) ++ (* Used as a continuation of CamlinternalFormat.make_printf. *) ++ let rec output_acc ppf (acc: _ CamlinternalFormat.acc) = ++ match acc with ++ | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s) ++ | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> ++ output_acc ppf p; ++ pp_print_as ppf size s; ++ | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c) ++ | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> ++ output_acc ppf p; ++ pp_print_as ppf size (String.make 1 c); ++ | Acc_formatting_lit (p, f) -> ++ output_acc ppf p; ++ output_formatting_lit ppf f; ++ | Acc_formatting_gen (p, Acc_open_tag acc') -> ++ output_acc ppf p; ++ pp_open_stag ppf (Format.String_tag (compute_tag output_acc acc')) ++ | Acc_formatting_gen (p, Acc_open_box acc') -> ++ output_acc ppf p; ++ let (indent, bty) = ++ let box_info = compute_tag output_acc acc' in ++ CamlinternalFormat.open_box_of_string box_info ++ in ++ pp_open_box_gen ppf indent bty ++ | Acc_string_literal (p, s) ++ | Acc_data_string (p, s) -> output_acc ppf p; pp_print_string ppf s; ++ | Acc_char_literal (p, c) ++ | Acc_data_char (p, c) -> output_acc ppf p; pp_print_char ppf c; ++ | Acc_delay (p, f) -> output_acc ppf p; f ppf; ++ | Acc_flush p -> output_acc ppf p; pp_print_flush ppf (); ++ | Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg; ++ | End_of_acc -> () ++end ++ ++let kfprintf k ppf (CamlinternalFormatBasics.Format (fmt, _)) = ++ CamlinternalFormat.make_printf ++ (fun acc -> Driver.output_acc ppf acc; k ppf) ++ End_of_acc fmt ++let fprintf doc fmt = kfprintf ignore doc fmt ++ ++ ++let kdprintf k (CamlinternalFormatBasics.Format (fmt, _)) = ++ CamlinternalFormat.make_printf ++ (fun acc -> k (fun ppf -> Driver.output_acc ppf acc)) ++ End_of_acc fmt ++ ++let dprintf fmt = kdprintf (fun i -> i) fmt ++ ++let doc_printf fmt = ++ let ppf = ref Doc.empty in ++ kfprintf (fun _ -> let doc = !ppf in ppf := Doc.empty; doc) ppf fmt ++ ++let kdoc_printf k fmt = ++ let ppf = ref Doc.empty in ++ kfprintf (fun ppf -> ++ let doc = !ppf in ++ ppf := Doc.empty; ++ k doc ++ ) ++ ppf fmt ++ ++let doc_printer f x doc = ++ let r = ref doc in ++ f r x; ++ !r ++ ++type 'a format_printer = Format.formatter -> 'a -> unit ++ ++let format_printer f ppf x = ++ let doc = doc_printer f x Doc.empty in ++ Doc.format ppf doc ++let compat = format_printer ++let compat1 f p1 = compat (f p1) ++let compat2 f p1 p2 = compat (f p1 p2) ++ ++let kasprintf k fmt = ++ kdoc_printf (fun doc -> k (Format.asprintf "%a" Doc.format doc)) fmt ++let asprintf fmt = kasprintf Fun.id fmt ++ ++let pp_print_iter ?(pp_sep=pp_print_cut) iter elt ppf c = ++ let sep = doc_printer pp_sep () in ++ ppf:= Doc.iter ~sep ~iter (doc_printer elt) c !ppf ++ ++let pp_print_list ?(pp_sep=pp_print_cut) elt ppf l = ++ ppf := Doc.list ~sep:(doc_printer pp_sep ()) (doc_printer elt) l !ppf ++ ++let pp_print_array ?pp_sep elt ppf a = ++ pp_print_iter ?pp_sep Array.iter elt ppf a ++let pp_print_seq ?pp_sep elt ppf s = pp_print_iter ?pp_sep Seq.iter elt ppf s ++ ++let pp_print_option ?(none=fun _ () -> ()) elt ppf o = ++ ppf := Doc.option ~none:(doc_printer none ()) (doc_printer elt) o !ppf ++ ++let pp_print_result ~ok ~error ppf r = ++ ppf := Doc.result ~ok:(doc_printer ok) ~error:(doc_printer error) r !ppf ++ ++let pp_print_either ~left ~right ppf e = ++ ppf := Doc.either ~left:(doc_printer left) ~right:(doc_printer right) e !ppf ++ ++let comma ppf () = fprintf ppf ",@ " ++ ++let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) = ++ let left_column_size = ++ List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines in ++ let lines_nb = List.length lines in ++ let ellipsed_first, ellipsed_last = ++ match max_lines with ++ | Some max_lines when lines_nb > max_lines -> ++ let printed_lines = max_lines - 1 in (* the ellipsis uses one line *) ++ let lines_before = printed_lines / 2 + printed_lines mod 2 in ++ let lines_after = printed_lines / 2 in ++ (lines_before, lines_nb - lines_after - 1) ++ | _ -> (-1, -1) ++ in ++ fprintf ppf "@["; ++ List.iteri (fun k (line_l, line_r) -> ++ if k = ellipsed_first then fprintf ppf "...@,"; ++ if ellipsed_first <= k && k <= ellipsed_last then () ++ else fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r ++ ) lines; ++ fprintf ppf "@]" ++ ++let deprecated_printer pr ppf = ppf := Doc.add !ppf (Doc.Deprecated pr) diff --git a/upstream/patches_503/utils/format_doc.mli.patch b/upstream/patches_503/utils/format_doc.mli.patch new file mode 100644 index 000000000..927de714c --- /dev/null +++ b/upstream/patches_503/utils/format_doc.mli.patch @@ -0,0 +1,300 @@ +--- ocaml_502/utils/format_doc.mli 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/format_doc.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,297 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Florian Angeletti, projet Cambium, Inria Paris *) ++(* *) ++(* Copyright 2024 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++(** Composable document for the {!Format} formatting engine. *) ++ ++(** This module introduces a pure and immutable document type which represents a ++ sequence of formatting instructions to be printed by a formatting engine at ++ later point. At the same time, it also provides format string interpreter ++ which produces this document type from format string and their associated ++ printers. ++ ++ The module is designed to be source compatible with code defining format ++ printers: replacing `Format` by `Format_doc` in your code will convert ++ `Format` printers to `Format_doc` printers. ++*) ++ ++(** Definitions and immutable API for composing documents *) ++module Doc: sig ++ ++ (** {2 Type definitions and core functions }*) ++ ++ (** Format box types *) ++ type box_type = ++ | H ++ | V ++ | HV ++ | HoV ++ | B ++ ++ type stag = Format.stag ++ ++ (** Base formatting instruction recognized by {!Format} *) ++ type element = ++ | Text of string ++ | With_size of int ++ | Open_box of { kind: box_type ; indent:int } ++ | Close_box ++ | Open_tag of Format.stag ++ | Close_tag ++ | Open_tbox ++ | Tab_break of { width : int; offset : int } ++ | Set_tab ++ | Close_tbox ++ | Simple_break of { spaces : int; indent : int } ++ | Break of { fits : string * int * string as 'a; breaks : 'a } ++ | Flush of { newline:bool } ++ | Newline ++ | If_newline ++ ++ | Deprecated of (Format.formatter -> unit) ++ (** Escape hatch: a {!Format} printer used to provide backward-compatibility ++ for user-defined printer (from the [#install_printer] toplevel directive ++ for instance). *) ++ ++ (** Immutable document type*) ++ type t ++ ++ type ('a,'b) fmt = ('a, t, t,'b) format4 ++ ++ type printer0 = t -> t ++ type 'a printer = 'a -> printer0 ++ ++ ++ (** Empty document *) ++ val empty: t ++ ++ (** [format ppf doc] sends the format instruction of [doc] to the Format's ++ formatter [doc]. *) ++ val format: Format.formatter -> t -> unit ++ ++ (** Fold over a document as a sequence of instructions *) ++ val fold: ('acc -> element -> 'acc) -> 'acc -> t -> 'acc ++ ++ (** {!msg} and {!kmsg} produce a document from a format string and its ++ argument *) ++ val msg: ('a,t) fmt -> 'a ++ val kmsg: (t -> 'b) -> ('a,'b) fmt -> 'a ++ ++ (** {!printf} and {!kprintf} produce a printer from a format string and its ++ argument*) ++ val printf: ('a, printer0) fmt -> 'a ++ val kprintf: (t -> 'b) -> ('a, t -> 'b) fmt -> 'a ++ ++ (** The functions below mirror {!Format} printers, without the [pp_print_] ++ prefix naming convention *) ++ val open_box: box_type -> int -> printer0 ++ val close_box: printer0 ++ ++ val text: string printer ++ val string: string printer ++ val bytes: bytes printer ++ val with_size: int printer ++ ++ val int: int printer ++ val float: float printer ++ val char: char printer ++ val bool: bool printer ++ ++ val space: printer0 ++ val cut: printer0 ++ val break: spaces:int -> indent:int -> printer0 ++ ++ val custom_break: ++ fits:(string * int * string as 'a) -> breaks:'a -> printer0 ++ val force_newline: printer0 ++ val if_newline: printer0 ++ ++ val flush: printer0 ++ val force_stop: printer0 ++ ++ val open_tbox: printer0 ++ val set_tab: printer0 ++ val tab: printer0 ++ val tab_break: width:int -> offset:int -> printer0 ++ val close_tbox: printer0 ++ ++ val open_tag: stag printer ++ val close_tag: printer0 ++ ++ val list: ?sep:printer0 -> 'a printer -> 'a list printer ++ val iter: ++ ?sep:printer0 -> iter:(('a -> unit) -> 'b -> unit) -> 'a printer ++ ->'b printer ++ val array: ?sep:printer0 -> 'a printer -> 'a array printer ++ val seq: ?sep:printer0 -> 'a printer -> 'a Seq.t printer ++ ++ val option: ?none:printer0 -> 'a printer -> 'a option printer ++ val result: ok:'a printer -> error:'e printer -> ('a,'e) result printer ++ val either: left:'a printer -> right:'b printer -> ('a,'b) Either.t printer ++ ++end ++ ++(** {1 Compatibility API} *) ++ ++(** The functions and types below provides source compatibility with format ++printers and conversion function from {!Format_doc} printers to {!Format} ++printers. The reverse direction is implemented using an escape hatch in the ++formatting instruction and should only be used to preserve backward ++compatibility. *) ++ ++type doc = Doc.t ++type t = doc ++type formatter ++type 'a printer = formatter -> 'a -> unit ++ ++val formatter: doc ref -> formatter ++(** [formatter rdoc] creates a {!formatter} that updates the [rdoc] reference *) ++ ++(** Translate a {!Format_doc} printer to a {!Format} one. *) ++type 'a format_printer = Format.formatter -> 'a -> unit ++val compat: 'a printer -> 'a format_printer ++val compat1: ('p1 -> 'a printer) -> ('p1 -> 'a format_printer) ++val compat2: ('p1 -> 'p2 -> 'a printer) -> ('p1 -> 'p2 -> 'a format_printer) ++ ++(** If necessary, embbed a {!Format} printer inside a formatting instruction ++ stream. This breaks every guarantees provided by {!Format_doc}. *) ++val deprecated_printer: (Format.formatter -> unit) -> formatter -> unit ++ ++ ++(** {2 Format string interpreters }*) ++ ++val fprintf : formatter -> ('a, formatter,unit) format -> 'a ++val kfprintf: ++ (formatter -> 'a) -> formatter -> ++ ('b, formatter, unit, 'a) format4 -> 'b ++ ++val asprintf : ('a, formatter, unit, string) format4 -> 'a ++val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b ++ ++ ++val dprintf : ('a, formatter, unit, formatter -> unit) format4 -> 'a ++val kdprintf: ++ ((formatter -> unit) -> 'a) -> ++ ('b, formatter, unit, 'a) format4 -> 'b ++ ++(** {!doc_printf} and {!kdoc_printf} creates a document directly *) ++val doc_printf: ('a, formatter, unit, doc) format4 -> 'a ++val kdoc_printf: (doc -> 'r) -> ('a, formatter, unit, 'r) format4 -> 'a ++ ++(** {2 Compatibility with {!Doc} }*) ++ ++val doc_printer: 'a printer -> 'a Doc.printer ++val pp_doc: doc printer ++ ++(** {2 Source compatibility with Format}*) ++ ++(** {3 String printers } *) ++ ++val pp_print_string: string printer ++val pp_print_substring: pos:int -> len:int -> string printer ++val pp_print_text: string printer ++val pp_print_bytes: bytes printer ++ ++val pp_print_as: formatter -> int -> string -> unit ++val pp_print_substring_as: ++ pos:int -> len:int -> formatter -> int -> string -> unit ++ ++(** {3 Primitive type printers }*) ++ ++val pp_print_char: char printer ++val pp_print_int: int printer ++val pp_print_float: float printer ++val pp_print_bool: bool printer ++val pp_print_nothing: unit printer ++ ++(** {3 Printer combinators }*) ++ ++val pp_print_iter: ++ ?pp_sep:unit printer -> (('a -> unit) -> 'b -> unit) -> ++ 'a printer -> 'b printer ++ ++val pp_print_list: ?pp_sep:unit printer -> 'a printer -> 'a list printer ++val pp_print_array: ?pp_sep:unit printer -> 'a printer -> 'a array printer ++val pp_print_seq: ?pp_sep:unit printer -> 'a printer -> 'a Seq.t printer ++ ++val pp_print_option: ?none:unit printer -> 'a printer -> 'a option printer ++val pp_print_result: ok:'a printer -> error:'e printer -> ('a,'e) result printer ++val pp_print_either: ++ left:'a printer -> right:'b printer -> ('a,'b) Either.t printer ++ ++ ++(** {3 Boxes and tags }*) ++ ++val pp_open_stag: Format.stag printer ++val pp_close_stag: unit printer ++ ++val pp_open_box: int printer ++val pp_close_box: unit printer ++ ++(** {3 Break hints} *) ++ ++val pp_print_space: unit printer ++val pp_print_cut: unit printer ++val pp_print_break: formatter -> int -> int -> unit ++val pp_print_custom_break: ++ formatter -> fits:(string * int * string as 'c) -> breaks:'c -> unit ++ ++(** {3 Tabulations }*) ++ ++val pp_open_tbox: unit printer ++val pp_close_tbox: unit printer ++val pp_set_tab: unit printer ++val pp_print_tab: unit printer ++val pp_print_tbreak: formatter -> int -> int -> unit ++ ++(** {3 Newlines and flushing }*) ++ ++val pp_print_if_newline: unit printer ++val pp_force_newline: unit printer ++val pp_print_flush: unit printer ++val pp_print_newline: unit printer ++ ++(** {1 Compiler specific functions }*) ++ ++(** {2 Separators }*) ++ ++val comma: unit printer ++ ++(** {2 Compiler output} *) ++ ++val pp_two_columns : ++ ?sep:string -> ?max_lines:int -> ++ formatter -> (string * string) list -> unit ++(** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two ++ columns separated by [sep] ("|" by default). [max_lines] can be used to ++ indicate a maximum number of lines to print -- an ellipsis gets inserted at ++ the middle if the input has too many lines. ++ ++ Example: ++ ++ {v pp_two_columns ~max_lines:3 Format.std_formatter [ ++ "abc", "hello"; ++ "def", "zzz"; ++ "a" , "bllbl"; ++ "bb" , "dddddd"; ++ ] v} ++ ++ prints ++ ++ {v ++ abc | hello ++ ... ++ bb | dddddd ++ v} ++*) diff --git a/upstream/patches_503/utils/linkdeps.ml.patch b/upstream/patches_503/utils/linkdeps.ml.patch new file mode 100644 index 000000000..85aa96989 --- /dev/null +++ b/upstream/patches_503/utils/linkdeps.ml.patch @@ -0,0 +1,145 @@ +--- ocaml_502/utils/linkdeps.ml 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/linkdeps.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,142 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Hugo Heuzard *) ++(* *) ++(* Copyright 2020 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++module Style = Misc.Style ++ ++type compunit = string ++ ++type filename = string ++ ++type compunit_and_source = { ++ compunit : compunit; ++ filename : filename; ++} ++ ++module Compunit_and_source = struct ++ type t = compunit_and_source ++ module Set = Set.Make(struct type nonrec t = t let compare = compare end) ++end ++ ++type refs = Compunit_and_source.Set.t ++ ++type t = { ++ complete : bool; ++ missing_compunits : (compunit, refs) Hashtbl.t; ++ provided_compunits : (compunit, filename list) Hashtbl.t; ++ badly_ordered_deps : (Compunit_and_source.t, refs) Hashtbl.t; ++} ++ ++type error = ++ | Missing_implementations of (compunit * compunit_and_source list) list ++ | Wrong_link_order of (compunit_and_source * compunit_and_source list) list ++ | Multiple_definitions of (compunit * filename list) list ++ ++let create ~complete = { ++ complete; ++ missing_compunits = Hashtbl.create 17; ++ provided_compunits = Hashtbl.create 17; ++ badly_ordered_deps = Hashtbl.create 17; ++} ++ ++let required t compunit = Hashtbl.mem t.missing_compunits compunit ++ ++let update t k f = ++ let v = Hashtbl.find_opt t k in ++ Hashtbl.replace t k (f v) ++ ++let add_required t by (name : string) = ++ let add s = ++ Compunit_and_source.Set.add by ++ (Option.value s ~default:Compunit_and_source.Set.empty) in ++ (try ++ let filename = List.hd (Hashtbl.find t.provided_compunits name) in ++ update t.badly_ordered_deps {compunit = name; filename } add ++ with Not_found -> ()); ++ update t.missing_compunits name add ++ ++let add t ~filename ~compunit ~provides ~requires = ++ List.iter (add_required t {compunit; filename}) requires; ++ List.iter (fun p -> ++ Hashtbl.remove t.missing_compunits p; ++ let l = Option.value ~default:[] ++ (Hashtbl.find_opt t.provided_compunits p) in ++ Hashtbl.replace t.provided_compunits p (filename :: l)) provides ++ ++let check t = ++ let of_seq s = ++ Seq.map (fun (k,v) -> k, Compunit_and_source.Set.elements v) s ++ |> List.of_seq ++ in ++ let missing = of_seq (Hashtbl.to_seq t.missing_compunits) in ++ let badly_ordered_deps = of_seq (Hashtbl.to_seq t.badly_ordered_deps) in ++ let duplicated = ++ Hashtbl.to_seq t.provided_compunits ++ |> Seq.filter (fun (_, files) -> List.compare_length_with files 1 > 0) ++ |> List.of_seq ++ in ++ match duplicated, badly_ordered_deps, missing with ++ | [], [], [] -> None ++ | [], [], l -> ++ if t.complete ++ then Some (Missing_implementations l) ++ else None ++ | [], l, _ -> ++ Some (Wrong_link_order l) ++ | l, _, _ -> ++ Some (Multiple_definitions l) ++ ++(* Error report *) ++ ++open Format_doc ++ ++let print_reference print_fname ppf {compunit; filename} = ++ fprintf ppf "%a (%a)" Style.inline_code compunit print_fname filename ++ ++let pp_list_comma f = ++ pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") f ++ ++let report_error_doc ~print_filename ppf = function ++ | Missing_implementations l -> ++ let print_modules ppf = ++ List.iter ++ (fun (md, rq) -> ++ fprintf ppf "@ @[%a referenced from %a@]" ++ Style.inline_code md ++ (pp_list_comma (print_reference print_filename)) rq) ++ in ++ fprintf ppf ++ "@[No implementation provided for the following modules:%a@]" ++ print_modules l ++ | Wrong_link_order l -> ++ let depends_on ppf (dep, depending) = ++ fprintf ppf "@ @[%a depends on %a@]" ++ (pp_list_comma (print_reference print_filename)) depending ++ (print_reference print_filename) dep ++ in ++ fprintf ppf "@[Wrong link order:%a@]" ++ (pp_list_comma depends_on) l ++ | Multiple_definitions l -> ++ let print ppf (compunit, files) = ++ fprintf ppf ++ "@ @[Multiple definitions of module %a in files %a@]" ++ Style.inline_code compunit ++ (pp_list_comma (Style.as_inline_code print_filename)) files ++ ++ in ++ fprintf ppf "@[ Duplicated implementations:%a@]" ++ (pp_list_comma print) l ++ ++let report_error ~print_filename = ++ Format_doc.compat (report_error_doc ~print_filename) diff --git a/upstream/patches_503/utils/linkdeps.mli.patch b/upstream/patches_503/utils/linkdeps.mli.patch new file mode 100644 index 000000000..6b8174ba9 --- /dev/null +++ b/upstream/patches_503/utils/linkdeps.mli.patch @@ -0,0 +1,67 @@ +--- ocaml_502/utils/linkdeps.mli 1970-01-01 01:00:00.000000000 +0100 ++++ ocaml_503/utils/linkdeps.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -0,0 +1,64 @@ ++(**************************************************************************) ++(* *) ++(* OCaml *) ++(* *) ++(* Hugo Heuzard *) ++(* *) ++(* Copyright 2020 Institut National de Recherche en Informatique et *) ++(* en Automatique. *) ++(* *) ++(* All rights reserved. This file is distributed under the terms of *) ++(* the GNU Lesser General Public License version 2.1, with the *) ++(* special exception on linking described in the file LICENSE. *) ++(* *) ++(**************************************************************************) ++ ++type t ++(** The state of the linking check. ++ It keeps track of compilation units provided and required so far. *) ++ ++type compunit = string ++ ++type filename = string ++ ++val create : complete:bool -> t ++(** [create ~complete] returns an empty state. If [complete] is ++ [true], missing compilation units will be treated as errors. *) ++ ++val add : t ++ -> filename:filename -> compunit:compunit ++ -> provides:compunit list -> requires:compunit list -> unit ++(** [add t ~filename ~compunit ~provides ~requires] registers the ++ compilation unit [compunit] found in [filename] to [t]. ++ - [provides] are units and sub-units provided by [compunit] ++ - [requires] are units required by [compunit] ++ ++ [add] should be called in reverse topological order. *) ++ ++val required : t -> compunit -> bool ++(** [required t compunit] returns [true] if [compunit] is a dependency of ++ previously added compilation units. *) ++ ++type compunit_and_source = { ++ compunit : compunit; ++ filename : filename; ++} ++ ++type error = ++ | Missing_implementations of (compunit * compunit_and_source list) list ++ | Wrong_link_order of (compunit_and_source * compunit_and_source list) list ++ | Multiple_definitions of (compunit * filename list) list ++ ++val check : t -> error option ++(** [check t] should be called once all the compilation units to be linked ++ have been added. It returns some error if: ++ - There are some missing implementations ++ and [complete] is [true] ++ - Some implementation appear ++ before their dependencies *) ++ ++ ++val report_error : ++ print_filename:string Format_doc.printer -> error Format_doc.format_printer ++val report_error_doc : ++ print_filename:string Format_doc.printer -> error Format_doc.printer diff --git a/upstream/patches_503/utils/load_path.ml.patch b/upstream/patches_503/utils/load_path.ml.patch new file mode 100644 index 000000000..64554dce9 --- /dev/null +++ b/upstream/patches_503/utils/load_path.ml.patch @@ -0,0 +1,68 @@ +--- ocaml_502/utils/load_path.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/load_path.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -105,15 +105,16 @@ + order. *) + let prepend_add dir = + List.iter (fun base -> +- let fn = Filename.concat dir.Dir.path base in +- let filename = Misc.normalized_unit_filename base in +- if dir.Dir.hidden then begin +- STbl.replace !hidden_files base fn; +- STbl.replace !hidden_files_uncap filename fn +- end else begin +- STbl.replace !visible_files base fn; +- STbl.replace !visible_files_uncap filename fn +- end ++ Result.iter (fun filename -> ++ let fn = Filename.concat dir.Dir.path base in ++ if dir.Dir.hidden then begin ++ STbl.replace !hidden_files base fn; ++ STbl.replace !hidden_files_uncap filename fn ++ end else begin ++ STbl.replace !visible_files base fn; ++ STbl.replace !visible_files_uncap filename fn ++ end) ++ (Misc.normalized_unit_filename base) + ) dir.Dir.files + + let init ~auto_include ~visible ~hidden = +@@ -150,10 +151,13 @@ + in + List.iter + (fun base -> +- let fn = Filename.concat dir.Dir.path base in +- update base fn visible_files hidden_files; +- let ubase = Misc.normalized_unit_filename base in +- update ubase fn visible_files_uncap hidden_files_uncap) ++ Result.iter (fun ubase -> ++ let fn = Filename.concat dir.Dir.path base in ++ update base fn visible_files hidden_files; ++ update ubase fn visible_files_uncap hidden_files_uncap ++ ) ++ (Misc.normalized_unit_filename base) ++ ) + dir.files; + if dir.hidden then + hidden_dirs := dir :: !hidden_dirs +@@ -216,9 +220,12 @@ + + let find_normalized_with_visibility fn = + assert (not Config.merlin || Local_store.is_bound ()); ++ match Misc.normalized_unit_filename fn with ++ | Error _ -> raise Not_found ++ | Ok fn_uncap -> + try + if is_basename fn && not !Sys.interactive then +- find_file_in_cache (Misc.normalized_unit_filename fn) ++ find_file_in_cache fn_uncap + visible_files_uncap hidden_files_uncap + else + try +@@ -227,7 +234,6 @@ + | Not_found -> + (Misc.find_in_path_normalized (get_hidden_path_list ()) fn, Hidden) + with Not_found -> +- let fn_uncap = Misc.normalized_unit_filename fn in + (!auto_include_callback Dir.find_normalized fn_uncap, Visible) + + let find_normalized fn = fst (find_normalized_with_visibility fn) diff --git a/upstream/patches_503/utils/local_store.mli.patch b/upstream/patches_503/utils/local_store.mli.patch new file mode 100644 index 000000000..569dca401 --- /dev/null +++ b/upstream/patches_503/utils/local_store.mli.patch @@ -0,0 +1,12 @@ +--- ocaml_502/utils/local_store.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/local_store.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -14,7 +14,8 @@ + (**************************************************************************) + + (** This module provides some facilities for creating references (and hash +- tables) which can easily be snapshoted and restored to an arbitrary version. ++ tables) which can easily be snapshotted and restored to an arbitrary ++ version. + + It is used throughout the frontend (read: typechecker), to register all + (well, hopefully) the global state. Thus making it easy for tools like diff --git a/upstream/patches_503/utils/misc.ml.patch b/upstream/patches_503/utils/misc.ml.patch new file mode 100644 index 000000000..4edd735a1 --- /dev/null +++ b/upstream/patches_503/utils/misc.ml.patch @@ -0,0 +1,345 @@ +--- ocaml_502/utils/misc.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/misc.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -260,6 +260,236 @@ + external compare : 'a -> 'a -> int = "%compare" + end + ++(** {1 Minimal support for Unicode characters in identifiers} *) ++ ++module Utf8_lexeme = struct ++ ++ type t = string ++ ++ (* Non-ASCII letters that are allowed in identifiers (currently: Latin-9) *) ++ ++ type case = Upper of Uchar.t | Lower of Uchar.t ++ let known_chars : (Uchar.t, case) Hashtbl.t = Hashtbl.create 32 ++ ++ let _ = ++ List.iter ++ (fun (upper, lower) -> ++ let upper = Uchar.of_int upper and lower = Uchar.of_int lower in ++ Hashtbl.add known_chars upper (Upper lower); ++ Hashtbl.add known_chars lower (Lower upper)) ++ [ ++ (0xc0, 0xe0); (* À, à *) (0xc1, 0xe1); (* Á, á *) ++ (0xc2, 0xe2); (* Â, â *) (0xc3, 0xe3); (* Ã, ã *) ++ (0xc4, 0xe4); (* Ä, ä *) (0xc5, 0xe5); (* Å, å *) ++ (0xc6, 0xe6); (* Æ, æ *) (0xc7, 0xe7); (* Ç, ç *) ++ (0xc8, 0xe8); (* È, è *) (0xc9, 0xe9); (* É, é *) ++ (0xca, 0xea); (* Ê, ê *) (0xcb, 0xeb); (* Ë, ë *) ++ (0xcc, 0xec); (* Ì, ì *) (0xcd, 0xed); (* Í, í *) ++ (0xce, 0xee); (* Î, î *) (0xcf, 0xef); (* Ï, ï *) ++ (0xd0, 0xf0); (* Ð, ð *) (0xd1, 0xf1); (* Ñ, ñ *) ++ (0xd2, 0xf2); (* Ò, ò *) (0xd3, 0xf3); (* Ó, ó *) ++ (0xd4, 0xf4); (* Ô, ô *) (0xd5, 0xf5); (* Õ, õ *) ++ (0xd6, 0xf6); (* Ö, ö *) (0xd8, 0xf8); (* Ø, ø *) ++ (0xd9, 0xf9); (* Ù, ù *) (0xda, 0xfa); (* Ú, ú *) ++ (0xdb, 0xfb); (* Û, û *) (0xdc, 0xfc); (* Ü, ü *) ++ (0xdd, 0xfd); (* Ý, ý *) (0xde, 0xfe); (* Þ, þ *) ++ (0x160, 0x161); (* Š, š *) (0x17d, 0x17e); (* Ž, ž *) ++ (0x152, 0x153); (* Œ, œ *) (0x178, 0xff); (* Ÿ, ÿ *) ++ (0x1e9e, 0xdf); (* ẞ, ß *) ++ ] ++ ++ (* NFD to NFC conversion table for the letters above *) ++ ++ let known_pairs : (Uchar.t * Uchar.t, Uchar.t) Hashtbl.t = Hashtbl.create 32 ++ ++ let _ = ++ List.iter ++ (fun (c1, n2, n) -> ++ Hashtbl.add known_pairs ++ (Uchar.of_char c1, Uchar.of_int n2) (Uchar.of_int n)) ++ [ ++ ('A', 0x300, 0xc0); (* À *) ('A', 0x301, 0xc1); (* Á *) ++ ('A', 0x302, 0xc2); (*  *) ('A', 0x303, 0xc3); (* à *) ++ ('A', 0x308, 0xc4); (* Ä *) ('A', 0x30a, 0xc5); (* Å *) ++ ('C', 0x327, 0xc7); (* Ç *) ('E', 0x300, 0xc8); (* È *) ++ ('E', 0x301, 0xc9); (* É *) ('E', 0x302, 0xca); (* Ê *) ++ ('E', 0x308, 0xcb); (* Ë *) ('I', 0x300, 0xcc); (* Ì *) ++ ('I', 0x301, 0xcd); (* Í *) ('I', 0x302, 0xce); (* Î *) ++ ('I', 0x308, 0xcf); (* Ï *) ('N', 0x303, 0xd1); (* Ñ *) ++ ('O', 0x300, 0xd2); (* Ò *) ('O', 0x301, 0xd3); (* Ó *) ++ ('O', 0x302, 0xd4); (* Ô *) ('O', 0x303, 0xd5); (* Õ *) ++ ('O', 0x308, 0xd6); (* Ö *) ++ ('U', 0x300, 0xd9); (* Ù *) ('U', 0x301, 0xda); (* Ú *) ++ ('U', 0x302, 0xdb); (* Û *) ('U', 0x308, 0xdc); (* Ü *) ++ ('Y', 0x301, 0xdd); (* Ý *) ('Y', 0x308, 0x178); (* Ÿ *) ++ ('S', 0x30c, 0x160); (* Š *) ('Z', 0x30c, 0x17d); (* Ž *) ++ ('a', 0x300, 0xe0); (* à *) ('a', 0x301, 0xe1); (* á *) ++ ('a', 0x302, 0xe2); (* â *) ('a', 0x303, 0xe3); (* ã *) ++ ('a', 0x308, 0xe4); (* ä *) ('a', 0x30a, 0xe5); (* å *) ++ ('c', 0x327, 0xe7); (* ç *) ('e', 0x300, 0xe8); (* è *) ++ ('e', 0x301, 0xe9); (* é *) ('e', 0x302, 0xea); (* ê *) ++ ('e', 0x308, 0xeb); (* ë *) ('i', 0x300, 0xec); (* ì *) ++ ('i', 0x301, 0xed); (* í *) ('i', 0x302, 0xee); (* î *) ++ ('i', 0x308, 0xef); (* ï *) ('n', 0x303, 0xf1); (* ñ *) ++ ('o', 0x300, 0xf2); (* ò *) ('o', 0x301, 0xf3); (* ó *) ++ ('o', 0x302, 0xf4); (* ô *) ('o', 0x303, 0xf5); (* õ *) ++ ('o', 0x308, 0xf6); (* ö *) ++ ('u', 0x300, 0xf9); (* ù *) ('u', 0x301, 0xfa); (* ú *) ++ ('u', 0x302, 0xfb); (* û *) ('u', 0x308, 0xfc); (* ü *) ++ ('y', 0x301, 0xfd); (* ý *) ('y', 0x308, 0xff); (* ÿ *) ++ ('s', 0x30c, 0x161); (* š *) ('z', 0x30c, 0x17e); (* ž *) ++ ] ++ ++ let normalize_generic ~keep_ascii transform s = ++ let rec norm check buf prev i = ++ if i >= String.length s then begin ++ Buffer.add_utf_8_uchar buf (transform prev) ++ end else begin ++ let d = String.get_utf_8_uchar s i in ++ let u = Uchar.utf_decode_uchar d in ++ check d u; ++ let i' = i + Uchar.utf_decode_length d in ++ match Hashtbl.find_opt known_pairs (prev, u) with ++ | Some u' -> ++ norm check buf u' i' ++ | None -> ++ Buffer.add_utf_8_uchar buf (transform prev); ++ norm check buf u i' ++ end in ++ let ascii_limit = 128 in ++ if s = "" ++ || keep_ascii && String.for_all (fun x -> Char.code x < ascii_limit) s ++ then Ok s ++ else ++ let buf = Buffer.create (String.length s) in ++ let valid = ref true in ++ let check d u = ++ valid := !valid && Uchar.utf_decode_is_valid d && u <> Uchar.rep ++ in ++ let d = String.get_utf_8_uchar s 0 in ++ let u = Uchar.utf_decode_uchar d in ++ check d u; ++ norm check buf u (Uchar.utf_decode_length d); ++ let contents = Buffer.contents buf in ++ if !valid then ++ Ok contents ++ else ++ Error contents ++ ++ let normalize s = ++ normalize_generic ~keep_ascii:true (fun u -> u) s ++ ++ (* Capitalization *) ++ ++ let uchar_is_uppercase u = ++ let c = Uchar.to_int u in ++ if c < 0x80 then c >= 65 && c <= 90 else ++ match Hashtbl.find_opt known_chars u with ++ | Some(Upper _) -> true ++ | _ -> false ++ ++ let uchar_lowercase u = ++ let c = Uchar.to_int u in ++ if c < 0x80 then ++ if c >= 65 && c <= 90 then Uchar.of_int (c + 32) else u ++ else ++ match Hashtbl.find_opt known_chars u with ++ | Some(Upper u') -> u' ++ | _ -> u ++ ++ let uchar_uppercase u = ++ let c = Uchar.to_int u in ++ if c < 0x80 then ++ if c >= 97 && c <= 122 then Uchar.of_int (c - 32) else u ++ else ++ match Hashtbl.find_opt known_chars u with ++ | Some(Lower u') -> u' ++ | _ -> u ++ ++ let capitalize s = ++ let first = ref true in ++ normalize_generic ~keep_ascii:false ++ (fun u -> if !first then (first := false; uchar_uppercase u) else u) ++ s ++ ++ let uncapitalize s = ++ let first = ref true in ++ normalize_generic ~keep_ascii:false ++ (fun u -> if !first then (first := false; uchar_lowercase u) else u) ++ s ++ ++ let is_capitalized s = ++ s <> "" && ++ uchar_is_uppercase (Uchar.utf_decode_uchar (String.get_utf_8_uchar s 0)) ++ ++ (* Characters allowed in identifiers after normalization is applied. ++ Currently: ++ - ASCII letters, underscore ++ - Latin-9 letters, represented in NFC ++ - ASCII digits, single quote (but not as first character) ++ - dot if [with_dot] = true ++ *) ++ let uchar_valid_in_identifier ~with_dot u = ++ let c = Uchar.to_int u in ++ if c < 0x80 then ++ c >= 97 (* a *) && c <= 122 (* z *) ++ || c >= 65 (* A *) && c <= 90 (* Z *) ++ || c >= 48 (* 0 *) && c <= 57 (* 9 *) ++ || c = 95 (* underscore *) ++ || c = 39 (* single quote *) ++ || (with_dot && c = 46) (* dot *) ++ else ++ Hashtbl.mem known_chars u ++ ++ let uchar_not_identifier_start u = ++ let c = Uchar.to_int u in ++ c >= 48 (* 0 *) && c <= 57 (* 9 *) ++ || c = 39 (* single quote *) ++ ++ (* Check whether a normalized string is a valid OCaml identifier. *) ++ ++ type validation_result = ++ | Valid ++ | Invalid_character of Uchar.t (** Character not allowed *) ++ | Invalid_beginning of Uchar.t (** Character not allowed as first char *) ++ ++ let validate_identifier ?(with_dot=false) s = ++ let rec check i = ++ if i >= String.length s then Valid else begin ++ let d = String.get_utf_8_uchar s i in ++ let u = Uchar.utf_decode_uchar d in ++ let i' = i + Uchar.utf_decode_length d in ++ if not (uchar_valid_in_identifier ~with_dot u) then ++ Invalid_character u ++ else if i = 0 && uchar_not_identifier_start u then ++ Invalid_beginning u ++ else ++ check i' ++ end ++ in check 0 ++ ++ let is_valid_identifier s = ++ validate_identifier s = Valid ++ ++ let starts_like_a_valid_identifier s = ++ s <> "" && ++ (let u = Uchar.utf_decode_uchar (String.get_utf_8_uchar s 0) in ++ uchar_valid_in_identifier ~with_dot:false u ++ && not (uchar_not_identifier_start u)) ++ ++ let is_lowercase s = ++ let rec is_lowercase_at len s n = ++ if n >= len then true ++ else ++ let d = String.get_utf_8_uchar s n in ++ let u = Uchar.utf_decode_uchar d in ++ (uchar_valid_in_identifier ~with_dot:false u) ++ && not (uchar_is_uppercase u) ++ && is_lowercase_at len s (n+Uchar.utf_decode_length d) ++ in ++ is_lowercase_at (String.length s) s 0 ++end ++ + (* File functions *) + + let find_in_path path name = +@@ -290,10 +520,12 @@ + if Sys.file_exists fullname then fullname else try_dir rem + in try_dir path + +-let normalized_unit_filename = String.uncapitalize_ascii ++let normalized_unit_filename = Utf8_lexeme.uncapitalize + + let find_in_path_normalized path name = +- let uname = normalized_unit_filename name in ++ match normalized_unit_filename name with ++ | Error _ -> raise Not_found ++ | Ok uname -> + let rec try_dir = function + [] -> raise Not_found + | dir::rem -> +@@ -651,11 +883,12 @@ + + + let as_inline_code printer ppf x = +- Format.pp_open_stag ppf (Format.String_tag "inline_code"); ++ let open Format_doc in ++ pp_open_stag ppf (Format.String_tag "inline_code"); + printer ppf x; +- Format.pp_close_stag ppf () ++ pp_close_stag ppf () + +- let inline_code ppf s = as_inline_code Format.pp_print_string ppf s ++ let inline_code ppf s = as_inline_code Format_doc.pp_print_string ppf s + + (* either prints the tag of [s] or delegates to [or_else] *) + let mark_open_tag ~or_else s = +@@ -769,19 +1002,20 @@ + let env = List.sort_uniq (fun s1 s2 -> String.compare s2 s1) env in + fst (List.fold_left (compare name) ([], max_int) env) + ++ + let did_you_mean ppf get_choices = ++ let open Format_doc in + (* flush now to get the error report early, in the (unheard of) case + where the search in the get_choices function would take a bit of + time; in the worst case, the user has seen the error, she can + interrupt the process before the spell-checking terminates. *) +- Format.fprintf ppf "@?"; ++ fprintf ppf "@?"; + match get_choices () with + | [] -> () + | choices -> + let rest, last = split_last choices in +- let comma ppf () = Format.fprintf ppf ", " in +- Format.fprintf ppf "@\n@{Hint@}: Did you mean %a%s%a?@?" +- (Format.pp_print_list ~pp_sep:comma Style.inline_code) rest ++ fprintf ppf "@\n@[@{Hint@}: Did you mean %a%s%a?@]" ++ (pp_print_list ~pp_sep:comma Style.inline_code) rest + (if rest = [] then "" else " or ") + Style.inline_code last + +@@ -832,27 +1066,6 @@ + let stop = loop 0 0 in + Bytes.sub_string dst 0 stop + +-let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) = +- let left_column_size = +- List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines in +- let lines_nb = List.length lines in +- let ellipsed_first, ellipsed_last = +- match max_lines with +- | Some max_lines when lines_nb > max_lines -> +- let printed_lines = max_lines - 1 in (* the ellipsis uses one line *) +- let lines_before = printed_lines / 2 + printed_lines mod 2 in +- let lines_after = printed_lines / 2 in +- (lines_before, lines_nb - lines_after - 1) +- | _ -> (-1, -1) +- in +- Format.fprintf ppf "@["; +- List.iteri (fun k (line_l, line_r) -> +- if k = ellipsed_first then Format.fprintf ppf "...@,"; +- if ellipsed_first <= k && k <= ellipsed_last then () +- else Format.fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r +- ) lines; +- Format.fprintf ppf "@]" +- + (* showing configuration and configuration variables *) + let show_config_and_exit () = + Config.print_config stdout; +@@ -909,16 +1122,16 @@ + [] + end + +-let print_if ppf flag printer arg = +- if !flag then Format.fprintf ppf "%a@." printer arg; +- arg +- + let print_see_manual ppf manual_section = +- let open Format in ++ let open Format_doc in + fprintf ppf "(see manual section %a)" + (pp_print_list ~pp_sep:(fun f () -> pp_print_char f '.') pp_print_int) + manual_section + ++let print_if ppf flag printer arg = ++ if !flag then Format.fprintf ppf "%a@." printer arg; ++ arg ++ + + type filepath = string + type modname = string diff --git a/upstream/patches_503/utils/misc.mli.patch b/upstream/patches_503/utils/misc.mli.patch new file mode 100644 index 000000000..e55460526 --- /dev/null +++ b/upstream/patches_503/utils/misc.mli.patch @@ -0,0 +1,137 @@ +--- ocaml_502/utils/misc.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/misc.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -217,8 +217,9 @@ + val find_in_path_rel: string list -> string -> string + (** Search a relative file in a list of directories. *) + +- (** Normalize file name [Foo.ml] to [foo.ml] *) +-val normalized_unit_filename: string -> string ++ (** Normalize file name [Foo.ml] to [foo.ml], using NFC and case-folding. ++ Return [Error] if the input is not a valid utf-8 byte sequence *) ++val normalized_unit_filename: string -> (string,string) Result.t + + val find_in_path_normalized: string list -> string -> string + (** Same as {!find_in_path_rel} , but search also for normalized unit filename, +@@ -445,7 +446,8 @@ + list of suggestions taken from [env], that are close enough to + [name] that it may be a typo for one of them. *) + +-val did_you_mean : Format.formatter -> (unit -> string list) -> unit ++val did_you_mean : ++ Format_doc.formatter -> (unit -> string list) -> unit + (** [did_you_mean ppf get_choices] hints that the user may have meant + one of the option returned by calling [get_choices]. It does nothing + if the returned list is empty. +@@ -505,8 +507,8 @@ + inline_code: tag_style; + } + +- val as_inline_code: (Format.formatter -> 'a -> unit as 'printer) -> 'printer +- val inline_code: Format.formatter -> string -> unit ++ val as_inline_code: 'a Format_doc.printer -> 'a Format_doc.printer ++ val inline_code: string Format_doc.printer + + val default_styles: styles + val get_styles: unit -> styles +@@ -536,33 +538,7 @@ + Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a + (** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *) + +-val pp_two_columns : +- ?sep:string -> ?max_lines:int -> +- Format.formatter -> (string * string) list -> unit +-(** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two +- columns separated by [sep] ("|" by default). [max_lines] can be used to +- indicate a maximum number of lines to print -- an ellipsis gets inserted at +- the middle if the input has too many lines. +- +- Example: +- +- {v pp_two_columns ~max_lines:3 Format.std_formatter [ +- "abc", "hello"; +- "def", "zzz"; +- "a" , "bllbl"; +- "bb" , "dddddd"; +- ] v} +- +- prints +- +- {v +- abc | hello +- ... +- bb | dddddd +- v} +-*) +- +-val print_see_manual : Format.formatter -> int list -> unit ++val print_see_manual : int list Format_doc.printer + (** See manual section *) + + (** {1 Displaying configuration variables} *) +@@ -787,6 +763,66 @@ + val all_kinds : kind list + end + ++(** {1 Minimal support for Unicode characters in identifiers} *) ++ ++(** Characters allowed in identifiers are, currently: ++ - ASCII letters A-Z a-z ++ - Latin-1 letters (U+00C0 - U+00FF except U+00D7 and U+00F7) ++ - Character sequences which normalize to the above character under NFC ++ - digits 0-9, underscore, single quote ++*) ++ ++module Utf8_lexeme: sig ++ type t = string ++ ++ val normalize: string -> (t,t) Result.t ++ (** Normalize the given UTF-8 encoded string. ++ Invalid UTF-8 sequences results in a error and are replaced ++ by U+FFFD. ++ Identifier characters are put in NFC normalized form. ++ Other Unicode characters are left unchanged. *) ++ ++ val capitalize: string -> (t,t) Result.t ++ (** Like [normalize], but if the string starts with a lowercase identifier ++ character, it is replaced by the corresponding uppercase character. ++ Subsequent characters are not changed. *) ++ ++ val uncapitalize: string -> (t,t) Result.t ++ (** Like [normalize], but if the string starts with an uppercase identifier ++ character, it is replaced by the corresponding lowercase character. ++ Subsequent characters are not changed. *) ++ ++ val is_capitalized: t -> bool ++ (** Returns [true] if the given normalized string starts with an ++ uppercase identifier character, [false] otherwise. May return ++ wrong results if the string is not normalized. *) ++ ++ val is_valid_identifier: t -> bool ++ (** Check whether the given normalized string is a valid OCaml identifier: ++ - all characters are identifier characters ++ - it does not start with a digit or a single quote ++ *) ++ ++ val is_lowercase: t -> bool ++ (** Returns [true] if the given normalized string only contains lowercase ++ identifier character, [false] otherwise. May return wrong results if the ++ string is not normalized. *) ++ ++ type validation_result = ++ | Valid ++ | Invalid_character of Uchar.t (** Character not allowed *) ++ | Invalid_beginning of Uchar.t (** Character not allowed as first char *) ++ ++ val validate_identifier: ?with_dot:bool -> t -> validation_result ++ (** Like [is_valid_identifier], but returns a more detailed error code. Dots ++ can be allowed to extend support to path-like identifiers. *) ++ ++ val starts_like_a_valid_identifier: t -> bool ++ (** Checks whether the given normalized string starts with an identifier ++ character other than a digit or a single quote. Subsequent characters ++ are not checked. *) ++end ++ + (** {1 Miscellaneous type aliases} *) + + type filepath = string diff --git a/upstream/patches_503/utils/warnings.ml.patch b/upstream/patches_503/utils/warnings.ml.patch new file mode 100644 index 000000000..ef908e263 --- /dev/null +++ b/upstream/patches_503/utils/warnings.ml.patch @@ -0,0 +1,110 @@ +--- ocaml_502/utils/warnings.ml 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/warnings.ml 2024-09-17 01:19:03.395759607 +0200 +@@ -52,7 +52,7 @@ + | Implicit_public_methods of string list (* 15 *) + | Unerasable_optional_argument (* 16 *) + | Undeclared_virtual_method of string (* 17 *) +- | Not_principal of string (* 18 *) ++ | Not_principal of Format_doc.t (* 18 *) + | Non_principal_labels of string (* 19 *) + | Ignored_extra_argument (* 20 *) + | Nonreturning_statement (* 21 *) +@@ -109,6 +109,7 @@ + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) ++ | Degraded_to_partial_match (* 74 *) + + (* If you remove a warning, leave a hole in the numbering. NEVER change + the numbers of existing warnings. +@@ -190,12 +191,13 @@ + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 + | Generative_application_expects_unit -> 73 ++ | Degraded_to_partial_match -> 74 + ;; + (* DO NOT REMOVE the ;; above: it is used by + the testsuite/ests/warnings/mnemonics.mll test to determine where + the definition of the number function above ends *) + +-let last_warning_number = 73 ++let last_warning_number = 74 + + type description = + { number : int; +@@ -534,6 +536,11 @@ + description = "A generative functor is applied to an empty structure \ + (struct end) rather than to ()."; + since = since 5 1 }; ++ { number = 74; ++ names = ["degraded-to-partial-match"]; ++ description = "A pattern-matching is compiled as partial \ ++ even if it appears to be total."; ++ since = since 5 3 }; + ] + + let name_to_number = +@@ -863,7 +870,7 @@ + alerts + + (* If you change these, don't forget to change them in man/ocamlc.m *) +-let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70" ++let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70-74" + let defaults_warn_error = "-a" + let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] + +@@ -926,7 +933,9 @@ + ^ String.concat " " l ^ "." + | Unerasable_optional_argument -> "this optional argument cannot be erased." + | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared." +- | Not_principal s -> s^" is not principal." ++ | Not_principal msg -> ++ Format_doc.asprintf "%a is not principal." ++ Format_doc.pp_doc msg + | Non_principal_labels s -> s^" without principality." + | Ignored_extra_argument -> "this argument will not be used by the function." + | Nonreturning_statement -> +@@ -1040,7 +1049,7 @@ + "Code should not depend on the actual values of\n\ + this constructor's arguments. They are only for information\n\ + and may change in future versions. %a" +- Misc.print_see_manual ref_manual ++ (Format_doc.compat Misc.print_see_manual) ref_manual + | Unreachable_case -> + "this match case is unreachable.\n\ + Consider replacing it with a refutation case ' -> .'" +@@ -1071,7 +1080,7 @@ + %s.\n\ + Only the first match will be used to evaluate the guard expression.\n\ + %a" +- vars_explanation Misc.print_see_manual ref_manual ++ vars_explanation (Format_doc.compat Misc.print_see_manual) ref_manual + | No_cmx_file name -> + Printf.sprintf + "no cmx file was found in path for module %s, \ +@@ -1096,7 +1105,7 @@ + | Erroneous_printed_signature s -> + "The printed interface differs from the inferred interface.\n\ + The inferred interface contained items which could not be printed\n\ +- properly due to name collisions between identifiers." ++ properly due to name collisions between identifiers.\n" + ^ s + ^ "\nBeware that this warning is purely informational and will not catch\n\ + all instances of erroneous printed interface." +@@ -1136,6 +1145,16 @@ + | Generative_application_expects_unit -> + "A generative functor\n\ + should be applied to '()'; using '(struct end)' is deprecated." ++ | Degraded_to_partial_match -> ++ let[@manual.ref "ss:warn74"] ref_manual = [ 13; 5; 5 ] in ++ Format.asprintf ++ "This pattern-matching is compiled \n\ ++ as partial, even if it appears to be total. \ ++ It may generate a Match_failure\n\ ++ exception. This typically occurs due to \ ++ complex matches on mutable fields.\n\ ++ %a" ++ (Format_doc.compat Misc.print_see_manual) ref_manual + ;; + + let nerrors = ref 0 diff --git a/upstream/patches_503/utils/warnings.mli.patch b/upstream/patches_503/utils/warnings.mli.patch new file mode 100644 index 000000000..466a2b0f3 --- /dev/null +++ b/upstream/patches_503/utils/warnings.mli.patch @@ -0,0 +1,19 @@ +--- ocaml_502/utils/warnings.mli 2024-06-27 15:42:08.730793912 +0200 ++++ ocaml_503/utils/warnings.mli 2024-09-17 01:19:03.395759607 +0200 +@@ -57,7 +57,7 @@ + | Implicit_public_methods of string list (* 15 *) + | Unerasable_optional_argument (* 16 *) + | Undeclared_virtual_method of string (* 17 *) +- | Not_principal of string (* 18 *) ++ | Not_principal of Format_doc.t (* 18 *) + | Non_principal_labels of string (* 19 *) + | Ignored_extra_argument (* 20 *) + | Nonreturning_statement (* 21 *) +@@ -116,6 +116,7 @@ + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) ++ | Degraded_to_partial_match (* 74 *) + + type alert = {kind:string; message:string; def:loc; use:loc} + From 9407959e262b0baa6f2a52f7415453b35fcab5a7 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 1 Oct 2024 04:21:01 +0200 Subject: [PATCH 07/36] Fix conflict and patch type incoherence --- src/ocaml/parsing/ast_helper.ml | 5 +- src/ocaml/parsing/location.ml | 156 +++-- src/ocaml/parsing/location.mli | 15 +- src/ocaml/parsing/printast.ml | 18 +- src/ocaml/preprocess/parser_raw.mly | 703 ++++++++------------ src/ocaml/typing/btype.ml | 70 +- src/ocaml/typing/btype.mli | 5 +- src/ocaml/typing/env.ml | 4 +- src/ocaml/typing/envaux.ml | 2 +- src/ocaml/typing/errortrace_report.ml | 2 +- src/ocaml/typing/includeclass.ml | 1 - src/ocaml/typing/includecore.ml | 1 - src/ocaml/typing/includemod.ml | 2 +- src/ocaml/typing/includemod_errorprinter.ml | 1 - src/ocaml/typing/msupport.ml | 7 +- src/ocaml/typing/printtyp.ml | 268 +++----- src/ocaml/typing/printtyp.mli | 251 ++++--- src/ocaml/typing/saved_parts.mli | 4 +- src/ocaml/typing/stypes.ml | 4 +- src/ocaml/typing/typeclass.ml | 5 +- src/ocaml/typing/typecore.ml | 174 +++-- src/ocaml/typing/typecore.mli | 1 - src/ocaml/typing/typedecl.ml | 1 - src/ocaml/typing/typemod.ml | 9 +- src/ocaml/typing/typetexp.ml | 7 +- src/ocaml/utils/clflags.ml | 1 + src/ocaml/utils/clflags.mli | 1 + src/ocaml/utils/config.ml | 2 +- src/ocaml/utils/config.mli | 13 +- src/utils/misc.ml | 15 +- src/utils/misc.mli | 3 +- 31 files changed, 780 insertions(+), 971 deletions(-) diff --git a/src/ocaml/parsing/ast_helper.ml b/src/ocaml/parsing/ast_helper.ml index 862dacb69..78e68b900 100644 --- a/src/ocaml/parsing/ast_helper.ml +++ b/src/ocaml/parsing/ast_helper.ml @@ -30,7 +30,10 @@ type attrs = attribute list let default_loc = ref Location.none -let const_string s = Pconst_string (s, !default_loc, None) +let const_string s = + let pconst_desc = Pconst_string (s, !default_loc, None) in + let pconst_loc = !default_loc in + {pconst_loc; pconst_desc} let with_default_loc l f = Misc.protect_refs [Misc.R (default_loc, l)] f diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml index e33cbfb54..58d3ba10d 100644 --- a/src/ocaml/parsing/location.ml +++ b/src/ocaml/parsing/location.ml @@ -122,13 +122,6 @@ let echo_eof () = print_newline (); incr num_loc_lines -(* This is used by the toplevel and the report printers below. *) -let separate_new_message ppf = - if not (is_first_message ()) then begin - Format.pp_print_newline ppf (); - incr num_loc_lines - end - (* Code printing errors and warnings must be wrapped using this function, in order to update [num_loc_lines]. @@ -216,8 +209,17 @@ let show_filename file = module Fmt = Format_doc -let print_filename ppf file = - Format.pp_print_string ppf (show_filename file) +module Doc = struct + + (* This is used by the toplevel and the report printers below. *) + let separate_new_message ppf () = + if not (is_first_message ()) then begin + Fmt.pp_print_newline ppf (); + incr num_loc_lines + end + + let filename ppf file = + Fmt.pp_print_string ppf (show_filename file) (* Best-effort printing of the text describing a location, of the form 'File "foo.ml", line 3, characters 10-12'. @@ -225,59 +227,73 @@ let print_filename ppf file = Some of the information (filename, line number or characters numbers) in the location might be invalid; in which case we do not print it. *) -let print_loc ppf loc = - (* setup_tags (); *) - let file_valid = function - | "_none_" -> - (* This is a dummy placeholder, but we print it anyway to please editors - that parse locations in error messages (e.g. Emacs). *) - true - | "" | "//toplevel//" -> false - | _ -> true - in - let line_valid line = line > 0 in - let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in - - let file = - (* According to the comment in location.mli, if [pos_fname] is "", we must - use [!input_name]. *) - if loc.loc_start.pos_fname = "" then !input_name - else loc.loc_start.pos_fname - in - let line = loc.loc_start.pos_lnum in - let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in - - let first = ref true in - let capitalize s = - if !first then (first := false; String.capitalize_ascii s) - else s in - let comma () = - if !first then () else Format.fprintf ppf ", " in - - Format.fprintf ppf "@{"; - - if file_valid file then - Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file; - - (* Print "line 1" in the case of a dummy line number. This is to please the - existing setup of editors that parse locations in error messages (e.g. - Emacs). *) - comma (); - Format.fprintf ppf "%s %i" (capitalize "line") - (if line_valid line then line else 1); - - if chars_valid ~startchar ~endchar then ( + let loc ppf loc = + let file_valid = function + | "_none_" -> + (* This is a dummy placeholder, but we print it anyway to please + editors that parse locations in error messages (e.g. Emacs). *) + true + | "" | "//toplevel//" -> false + | _ -> true + in + let line_valid line = line > 0 in + let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in + + let file = + (* According to the comment in location.mli, if [pos_fname] is "", we must + use [!input_name]. *) + if loc.loc_start.pos_fname = "" then !input_name + else loc.loc_start.pos_fname + in + let startline = loc.loc_start.pos_lnum in + let endline = loc.loc_end.pos_lnum in + let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in + let endchar = loc.loc_end.pos_cnum - loc.loc_end.pos_bol in + + let first = ref true in + let capitalize s = + if !first then (first := false; String.capitalize_ascii s) + else s in + let comma () = + if !first then () else Fmt.fprintf ppf ", " in + + Fmt.fprintf ppf "@{"; + + if file_valid file then + Fmt.fprintf ppf "%s \"%a\"" (capitalize "file") filename file; + + (* Print "line 1" in the case of a dummy line number. This is to please the + existing setup of editors that parse locations in error messages (e.g. + Emacs). *) comma (); - Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar - ); + let startline = if line_valid startline then startline else 1 in + let endline = if line_valid endline then endline else startline in + begin if startline = endline then + Fmt.fprintf ppf "%s %i" (capitalize "line") startline + else + Fmt.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline + end; + + if chars_valid ~startchar ~endchar then ( + comma (); + Fmt.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar + ); + + Fmt.fprintf ppf "@}" + + (* Print a comma-separated list of locations *) + let locs ppf locs = + Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.fprintf ppf ",@ ") + loc ppf locs + let quoted_filename ppf f = Misc.Style.as_inline_code filename ppf f + +end - Format.fprintf ppf "@}" +let print_filename = Fmt.compat Doc.filename +let print_loc = Fmt.compat Doc.loc +let print_locs = Fmt.compat Doc.locs +let separate_new_message ppf = Fmt.compat Doc.separate_new_message ppf () -(* Print a comma-separated list of locations *) -let print_locs ppf locs = - Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") - print_loc ppf locs (******************************************************************************) (* An interval set structure; additionally, it stores user-provided information @@ -616,10 +632,11 @@ let lines_around_from_current_input ~start_pos ~end_pos = (******************************************************************************) (* Reporting errors and warnings *) -type msg = (Format.formatter -> unit) loc + +type msg = Fmt.t loc let msg ?(loc = none) fmt = - Format.kdprintf (fun txt -> { loc; txt }) fmt + Fmt.kdoc_printf (fun txt -> { loc; txt }) fmt type report_kind = | Report_error @@ -628,8 +645,6 @@ type report_kind = | Report_alert of string | Report_alert_as_error of string -type error_source = Lexer | Parser | Typer | Warning | Unknown | Env | Config - type report = { kind : report_kind; main : msg; @@ -638,7 +653,7 @@ type report = { } let loc_of_report { main; _ } = main.loc -let print_msg fmt msg = msg.txt fmt +let print_msg fmt msg = Fmt.Doc.format fmt msg.txt let print_main fmt { main; _ } = print_msg fmt main let print_sub_msg = print_msg @@ -653,7 +668,7 @@ type report_printer = { pp_main_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_main_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; + Format.formatter -> Fmt.t -> unit; pp_submsgs : report_printer -> report -> Format.formatter -> msg list -> unit; pp_submsg : report_printer -> report -> @@ -661,9 +676,8 @@ type report_printer = { pp_submsg_loc : report_printer -> report -> Format.formatter -> t -> unit; pp_submsg_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; + Format.formatter -> Fmt.t -> unit; } - (* let is_dummy_loc loc = (* Fixme: this should be just [loc.loc_ghost] and the function should be @@ -727,7 +741,10 @@ let batch_mode_printer : report_printer = *) () in - let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in + let pp_txt ppf txt = Format.fprintf ppf "@[%a@]" Fmt.Doc.format txt in + let pp_footnote ppf f = + Option.iter (Format.fprintf ppf "@,%a" pp_txt) f + in let pp self ppf report = (* setup_tags (); *) separate_new_message ppf; @@ -736,13 +753,14 @@ let batch_mode_printer : report_printer = to be aligned with the main message box *) print_updating_num_loc_lines ppf (fun ppf () -> - Format.fprintf ppf "@[%a%a%a: %a%a%a%a@]@." + Format.fprintf ppf "@[%a%a%a: %a%a%a%a%a@]@." Format.pp_open_tbox () (self.pp_main_loc self report) report.main.loc (self.pp_report_kind self report) report.kind Format.pp_set_tab () (self.pp_main_txt self report) report.main.txt (self.pp_submsgs self report) report.sub + pp_footnote report.footnote Format.pp_close_tbox () ) () in diff --git a/src/ocaml/parsing/location.mli b/src/ocaml/parsing/location.mli index bdee872d2..af863eda6 100644 --- a/src/ocaml/parsing/location.mli +++ b/src/ocaml/parsing/location.mli @@ -107,7 +107,9 @@ val rewrite_absolute_path: string -> string the BUILD_PATH_PREFIX_MAP spec} *) +(* val rewrite_find_first_existing: string -> string option +*) (** [rewrite_find_first_existing path] uses a BUILD_PATH_PREFIX_MAP mapping and tries to find a source in mapping that maps to a result that exists in the file system. @@ -129,7 +131,9 @@ val rewrite_find_first_existing: string -> string option the BUILD_PATH_PREFIX_MAP spec} *) +(* val rewrite_find_all_existing_dirs: string -> string list +*) (** [rewrite_find_all_existing_dirs dir] accumulates a list of existing directories, [dirs], that are the result of mapping a potentially abstract directory, [dir], over all the mapping pairs in the @@ -183,9 +187,10 @@ end (** {1 Toplevel-specific location highlighting} *) +(* val highlight_terminfo: Lexing.lexbuf -> formatter -> t list -> unit - +*) (** {1 Reporting errors and warnings} *) @@ -209,6 +214,12 @@ type report = { footnote: Format_doc.t option } + +(* Exposed for Merlin *) +val loc_of_report: report -> t +val print_main : formatter -> report -> unit +val print_sub_msg : formatter -> msg -> unit + type report_printer = { (* The entry point *) pp : report_printer -> @@ -238,10 +249,12 @@ type report_printer = { val batch_mode_printer: report_printer +(* val terminfo_toplevel_printer: Lexing.lexbuf -> report_printer val best_toplevel_printer: unit -> report_printer (** Detects the terminal capabilities and selects an adequate printer *) +*) (** {2 Printing a [report]} *) diff --git a/src/ocaml/parsing/printast.ml b/src/ocaml/parsing/printast.ml index 034f0d35e..7a3fc332e 100644 --- a/src/ocaml/parsing/printast.ml +++ b/src/ocaml/parsing/printast.ml @@ -59,15 +59,15 @@ let fmt_char_option f = function | None -> fprintf f "None" | Some c -> fprintf f "Some %c" c -let fmt_constant f x = - match x with - | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; - | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c) - | Pconst_string (s, strloc, None) -> - fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc - | Pconst_string (s, strloc, Some delim) -> - fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim - | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m +(* let fmt_constant f x = *) +(* match x with *) +(* | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; *) +(* | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c) *) +(* | Pconst_string (s, strloc, None) -> *) +(* fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc *) +(* | Pconst_string (s, strloc, Some delim) -> *) +(* fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim *) +(* | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m *) let fmt_mutable_flag f x = match x with diff --git a/src/ocaml/preprocess/parser_raw.mly b/src/ocaml/preprocess/parser_raw.mly index 917ab96e8..84597d962 100644 --- a/src/ocaml/preprocess/parser_raw.mly +++ b/src/ocaml/preprocess/parser_raw.mly @@ -24,8 +24,6 @@ %{ -[@@@ocaml.warning "-9"] - [@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) [@@@ocaml.warning "+60"] @@ -35,7 +33,6 @@ open Parsetree open Ast_helper open Docstrings open Docstrings.WithMenhir -open Msupport_parsing let mkloc = Location.mkloc let mknoloc = Location.mknoloc @@ -61,6 +58,7 @@ let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d +let mkconst ~loc c = Const.mk ~loc:(make_loc loc) c let pstr_typext (te, ext) = (Pstr_typext te, ext) @@ -153,20 +151,31 @@ let neg_string f = then String.sub f 1 (String.length f - 1) else "-" ^ f -let mkuminus ~oploc name arg = - match name, arg.pexp_desc with - | "-", Pexp_constant(Pconst_integer (n,m)) -> - Pexp_constant(Pconst_integer(neg_string n,m)) - | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) -> - Pexp_constant(Pconst_float(neg_string f, m)) +(* Pre-apply the special [-], [-.], [+] and [+.] prefix operators into + constants if possible, otherwise turn them into the corresponding prefix + operators [~-], [~-.], etc.. *) +let mkuminus ~sloc ~oploc name arg = + match name, arg.pexp_desc, arg.pexp_attributes with + | "-", + Pexp_constant({pconst_desc = Pconst_integer (n,m); pconst_loc=_}), + [] -> + Pexp_constant(mkconst ~loc:sloc (Pconst_integer(neg_string n, m))) + | ("-" | "-."), + Pexp_constant({pconst_desc = Pconst_float (f, m); pconst_loc=_}), [] -> + Pexp_constant(mkconst ~loc:sloc (Pconst_float(neg_string f, m))) | _ -> Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) -let mkuplus ~oploc name arg = +let mkuplus ~sloc ~oploc name arg = let desc = arg.pexp_desc in - match name, desc with - | "+", Pexp_constant(Pconst_integer _) - | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc + match name, desc, arg.pexp_attributes with + | "+", + Pexp_constant({pconst_desc = Pconst_integer _ as desc; pconst_loc=_}), + [] + | ("+" | "+."), + Pexp_constant({pconst_desc = Pconst_float _ as desc; pconst_loc=_}), + [] -> + Pexp_constant(mkconst ~loc:sloc desc) | _ -> Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) @@ -232,12 +241,18 @@ let mkpat_opt_constraint ~loc p = function | None -> p | Some typ -> mkpat ~loc (Ppat_constraint(p, typ)) +let syntax_error () = + raise Syntaxerr.Escape_error -(*let syntax_error () = - raise Syntaxerr.Escape_error*) +let unclosed opening_name opening_loc closing_name closing_loc = + raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name, + make_loc closing_loc, closing_name))) + +let expecting loc nonterm = + raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm))) let removed_string_set loc = - raise_error Syntaxerr.(Error(Syntaxerr.Removed_string_set(make_loc loc))) + raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc))) (* Using the function [not_expecting] in a semantic action means that this syntactic form is recognized by the parser but is in fact incorrect. This @@ -253,16 +268,7 @@ let removed_string_set loc = [not_expecting] should be marked with AVOID. *) let not_expecting loc nonterm = - raise_error Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm))) - -(* -let unclosed opening_name opening_loc closing_name closing_loc = - raise(Syntaxerr.Error(Syntaxerr.Unclosed(make_loc opening_loc, opening_name, - make_loc closing_loc, closing_name))) -*) - -let expecting loc nonterm = - raise_error Syntaxerr.(Error(Expecting(make_loc loc, nonterm))) + raise Syntaxerr.(Error(Not_expecting(make_loc loc, nonterm))) (* Helper functions for desugaring array indexing operators *) type paren_kind = Paren | Brace | Bracket @@ -286,7 +292,6 @@ type ('dot,'index) array_family = { This functions computes the name of the explicit indexing operator associated with a sugared array indexing expression. - For instance, for builtin arrays, if Clflags.unsafe is set, * [ a.[index] ] => [String.unsafe_get] * [ a.{x,y} <- 1 ] => [ Bigarray.Array2.unsafe_set] @@ -320,12 +325,12 @@ let bigarray_untuplify = function let builtin_arraylike_name loc _ ~assign paren_kind n = let opname = if assign then "set" else "get" in - let opname = if !Clflags.fast then "unsafe_" ^ opname else opname in + let opname = if !Clflags.unsafe then "unsafe_" ^ opname else opname in let prefix = match paren_kind with | Paren -> Lident "Array" | Bracket -> - if assign then removed_string_set loc; - Lident "String" + if assign then removed_string_set loc + else Lident "String" | Brace -> let submodule_name = match n with | One -> "Array1" @@ -388,11 +393,9 @@ let mk_indexop_expr array_indexing_operator ~loc let args = (Nolabel,array) :: index @ set_arg in mkexp ~loc (Pexp_apply(ghexp ~loc (Pexp_ident fn), args)) - (* let indexop_unclosed_error loc_s s loc_e = let left, right = paren_to_strings s in unclosed left loc_s right loc_e - *) let lapply ~loc p1 p2 = if !Clflags.applicative_functors @@ -487,7 +490,8 @@ let wrap_mksig_ext ~loc (item, ext) = let mk_quotedext ~loc (id, idloc, str, strloc, delim) = let exp_id = mkloc id idloc in - let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in + let const = Const.mk ~loc:strloc (Pconst_string (str, strloc, delim)) in + let e = ghexp ~loc (Pexp_constant const) in (exp_id, PStr [mkstrexp e []]) let text_str pos = Str.text (rhs_text pos) @@ -521,7 +525,6 @@ let extra_rhs_core_type ct ~pos = let docs = rhs_info pos in { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes } -(* moved to ast_helper type let_binding = { lb_pattern: pattern; lb_expression: expression; @@ -536,7 +539,6 @@ type let_bindings = { lbs_bindings: let_binding list; lbs_rec: rec_flag; lbs_extension: string Asttypes.loc option } -*) let mklb first ~loc (p, e, typ, is_pun) attrs = { @@ -552,12 +554,7 @@ let mklb first ~loc (p, e, typ, is_pun) attrs = } let addlb lbs lb = - if lb.lb_is_pun && lbs.lbs_extension = None then ( - let err = - Syntaxerr.Expecting (lb.lb_loc, "let-extension (with punning)") - in - raise_error (Syntaxerr.Error err) - ); + if lb.lb_is_pun && lbs.lbs_extension = None then syntax_error (); { lbs with lbs_bindings = lb :: lbs.lbs_bindings } let mklbs ext rf lb = @@ -664,12 +661,17 @@ let mkfunction params body_constraint body = | Some newtypes -> mkghost_newtype_function_body newtypes body_constraint body_exp +let mk_functor_typ args mty = + List.fold_left (fun acc (startpos, arg) -> + mkmty ~loc:(startpos, mty.pmty_loc.loc_end) (Pmty_functor (arg, acc))) + mty args + (* Alternatively, we could keep the generic module type in the Parsetree and extract the package type during type-checking. In that case, the assertions below should be turned into explicit checks. *) let package_type_of_module_type pmty = let err loc s = - raise_error (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s))) + raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s))) in let map_cstr = function | Pwith_type (lid, ptyp) -> @@ -682,23 +684,23 @@ let package_type_of_module_type pmty = err loc Syntaxerr.Private_types; (* restrictions below are checked by the 'with_constraint' rule *) - (* assert (ptyp.ptype_kind = Ptype_abstract); *) - (* assert (ptyp.ptype_attributes = []); *) - begin match ptyp.ptype_manifest with - | Some ty -> Some (lid, ty) - | None -> None - end + assert (ptyp.ptype_kind = Ptype_abstract); + assert (ptyp.ptype_attributes = []); + let ty = + match ptyp.ptype_manifest with + | Some ty -> ty + | None -> assert false + in + (lid, ty) | _ -> - err pmty.pmty_loc Not_with_type; - None + err pmty.pmty_loc Not_with_type in match pmty with | {pmty_desc = Pmty_ident lid} -> (lid, [], pmty.pmty_attributes) | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} -> - (lid, List.filter_map map_cstr cstrs, pmty.pmty_attributes) + (lid, List.map map_cstr cstrs, pmty.pmty_attributes) | _ -> err pmty.pmty_loc Neither_identifier_nor_with_type - ; (Location.mkloc (Lident "_") pmty.pmty_loc, [], []) let mk_directive_arg ~loc k = { pdira_desc = k; @@ -712,52 +714,8 @@ let mk_directive ~loc name arg = pdir_loc = make_loc loc; } -let merloc startpos ?endpos x = - let endpos = match endpos with - | None -> x.pexp_loc.Location.loc_end - | Some endpos -> endpos - in - let loc = make_loc (startpos, endpos) in - let str = mkloc "merlin.loc" loc in - let attr = { attr_name = str; attr_loc = loc; attr_payload = PStr [] } in - { x with pexp_attributes = attr :: x.pexp_attributes } - %} -%[@printer.header - let string_of_INT = function - | (s, None) -> Printf.sprintf "INT(%s)" s - | (s, Some c) -> Printf.sprintf "INT(%s%c)" s c - - let string_of_FLOAT = function - | (s, None) -> Printf.sprintf "FLOAT(%s)" s - | (s, Some c) -> Printf.sprintf "FLOAT(%s%c)" s c - - let string_of_STRING = function - | s, _, Some s' -> Printf.sprintf "STRING(%S,%S)" s s' - | s, _, None -> Printf.sprintf "STRING(%S)" s - - let string_of_quoted_STRING = function - | _, _, s, _, Some s' -> Printf.sprintf "QUOTED_STRING(%S,%S)" s s' - | _, _, s, _, None -> Printf.sprintf "QUOTED_STRING(%S)" s -] - -%[@recovery.header - open Parsetree - open Ast_helper - - let default_loc = ref Location.none - - let default_expr () = - let id = Location.mkloc Ast_helper.hole_txt !default_loc in - Exp.mk ~loc:!default_loc (Pexp_extension (id, PStr [])) - - let default_pattern () = Pat.any ~loc:!default_loc () - - let default_module_expr () = Mod.structure ~loc:!default_loc [] - let default_module_type () = Mty.signature ~loc:!default_loc [] -] - /* Tokens */ /* The alias that follows each token is used by Menhir when it needs to @@ -769,139 +727,140 @@ let merloc startpos ?endpos x = string that will not trigger a syntax error; see how [not_expecting] is used in the definition of [type_variance]. */ -%token AMPERAMPER [@symbol "&&"] -%token AMPERSAND [@symbol "&"] -%token AND [@symbol "and"] -%token AS [@symbol "as"] -%token ASSERT [@symbol "assert"] -%token BACKQUOTE [@symbol "`"] -%token BANG [@symbol "!"] -%token BAR [@symbol "|"] -%token BARBAR [@symbol "||"] -%token BARRBRACKET [@symbol "|]"] -%token BEGIN [@symbol "begin"] -%token CHAR [@cost 2] [@recovery '_'] -%token CLASS [@symbol "class"] -%token COLON [@symbol ":"] -%token COLONCOLON [@symbol "::"] -%token COLONEQUAL [@symbol ":="] -%token COLONGREATER [@symbol ":>"] -%token COMMA [@symbol ","] -%token CONSTRAINT [@symbol "constraint"] -%token DO [@symbol "do"] -%token DONE [@symbol "done"] -%token DOT [@symbol "."] -%token DOTDOT [@symbol ".."] -%token DOWNTO [@symbol "downto"] -%token ELSE [@symbol "else"] -%token END [@symbol "end"] -%token EOF -%token EQUAL [@symbol "="] -%token EXCEPTION [@symbol "exception"] -%token EXTERNAL [@symbol "external"] -%token FALSE [@symbol "false"] -%token FLOAT [@cost 2] [@recovery ("0.",None)] [@printer string_of_FLOAT] -%token FOR [@symbol "for"] -%token FUN [@symbol "fun"] -%token FUNCTION [@symbol "function"] -%token FUNCTOR [@symbol "functor"] -%token GREATER [@symbol ">"] -%token GREATERRBRACE [@symbol ">}"] -%token GREATERRBRACKET [@symbol ">]"] -%token IF [@symbol "if"] -%token IN [@symbol "in"] -%token INCLUDE [@symbol "include"] -%token INFIXOP0 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP0(%S)"] -%token INFIXOP1 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP1(%S)"] -%token INFIXOP2 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP2(%S)"] -%token INFIXOP3 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP3(%S)"] -%token INFIXOP4 [@cost 2] [@recovery "_"][@printer Printf.sprintf "INFIXOP4(%S)"] -%token DOTOP -%token LETOP /* TODO: recovery & printing */ -%token ANDOP /* TODO: recovery & printing */ -%token INHERIT [@symbol "inherit"] -%token INITIALIZER [@symbol "initializer"] -%token INT [@cost 1] [@recovery ("0",None)] [@printer string_of_INT] -%token LABEL [@cost 2] [@recovery "_"][@printer Printf.sprintf "LABEL(%S)"] [@symbol "label"] -%token LAZY [@symbol "lazy"] -%token LBRACE [@symbol "{"] -%token LBRACELESS [@symbol "{<"] -%token LBRACKET [@symbol "["] -%token LBRACKETBAR [@symbol "[|"] -%token LBRACKETLESS [@symbol "[<"] -%token LBRACKETGREATER [@symbol "[>"] -%token LBRACKETPERCENT [@symbol "[%"] -%token LBRACKETPERCENTPERCENT [@symbol "[%%"] -%token LESS [@symbol "<"] -%token LESSMINUS [@symbol "<-"] [@cost 2] -%token LET [@symbol "let"] -%token LIDENT [@cost 2] [@recovery "_"][@printer Printf.sprintf "LIDENT(%S)"] -%token LPAREN [@symbol ")"] -%token LBRACKETAT [@symbol "[@"] -%token LBRACKETATAT [@symbol "[@@"] -%token LBRACKETATATAT [@symbol "[@@@"] -%token MATCH [@symbol "match"] -%token METHOD [@symbol "method"] -%token MINUS [@symbol "-"] -%token MINUSDOT [@symbol "-."] -%token MINUSGREATER [@symbol "->"] -%token MODULE [@symbol "module"] -%token MUTABLE [@symbol "mutable"] -%token NEW [@symbol "new"] -%token NONREC [@cost 1] [@symbol "nonrec"] -%token OBJECT [@symbol "object"] -%token OF [@symbol "of"] -%token OPEN [@symbol "open"] -%token OPTLABEL [@cost 2] [@recovery "_"][@printer Printf.sprintf "OPTLABEL(%S)"] [@symbol "?