From 38f77e96db4f723b2da459593c4dbc43523fb534 Mon Sep 17 00:00:00 2001 From: Diana Kalinichenko Date: Tue, 5 May 2026 11:37:11 -0400 Subject: [PATCH 1/2] Import ocaml sources for oxcaml/oxcaml.git@02fe39378b --- src/ocaml/parsing/ast_helper.ml | 40 +- src/ocaml/parsing/ast_helper.mli | 37 +- src/ocaml/parsing/ast_iterator.ml | 115 +- src/ocaml/parsing/ast_iterator.mli | 1 + src/ocaml/parsing/ast_mapper.ml | 187 +- src/ocaml/parsing/ast_mapper.mli | 1 + src/ocaml/parsing/asttypes.mli | 4 + src/ocaml/parsing/builtin_attributes.mli | 2 +- src/ocaml/parsing/docstrings.ml | 6 +- src/ocaml/parsing/language_extension.ml | 18 +- src/ocaml/parsing/language_extension.mli | 1 - src/ocaml/parsing/longident.ml | 31 +- src/ocaml/parsing/longident.mli | 10 +- src/ocaml/parsing/parsetree.mli | 77 +- src/ocaml/parsing/pprintast.ml | 412 +- src/ocaml/parsing/pprintast.mli | 7 + src/ocaml/parsing/printast.ml | 77 +- src/ocaml/parsing/printast.mli | 4 +- src/ocaml/typing/btype.ml | 89 +- src/ocaml/typing/btype.mli | 23 +- src/ocaml/typing/cmt_format.mli | 2 + src/ocaml/typing/ctype.ml | 1201 +++--- src/ocaml/typing/ctype.mli | 81 +- src/ocaml/typing/datarepr.ml | 25 +- src/ocaml/typing/datarepr.mli | 5 +- src/ocaml/typing/envaux.ml | 2 +- src/ocaml/typing/errortrace.ml | 12 +- src/ocaml/typing/errortrace.mli | 8 + src/ocaml/typing/ident.mli | 4 + src/ocaml/typing/includeclass.ml | 9 +- src/ocaml/typing/includeclass.mli | 4 +- src/ocaml/typing/includecore.ml | 131 +- src/ocaml/typing/includecore.mli | 15 + src/ocaml/typing/includemod.mli | 17 +- src/ocaml/typing/includemod_errorprinter.ml | 314 +- src/ocaml/typing/includemod_errorprinter.mli | 2 + src/ocaml/typing/jkind.ml | 6 + src/ocaml/typing/jkind.mli | 3 + src/ocaml/typing/jkind_intf.ml | 4 + src/ocaml/typing/jkind_types.ml | 4 + src/ocaml/typing/oprint.ml | 164 +- src/ocaml/typing/oprint.mli | 2 +- src/ocaml/typing/outcometree.mli | 24 +- src/ocaml/typing/parmatch.ml | 107 +- src/ocaml/typing/parmatch.mli | 9 +- src/ocaml/typing/path.ml | 4 + src/ocaml/typing/path.mli | 3 + src/ocaml/typing/patterns.ml | 1 + src/ocaml/typing/patterns.mli | 1 + src/ocaml/typing/predef.ml | 1223 +++--- src/ocaml/typing/printpat.ml | 2 +- src/ocaml/typing/shape.ml | 41 +- src/ocaml/typing/shape.mli | 7 +- src/ocaml/typing/shape_reduce.ml | 12 +- src/ocaml/typing/stypes.ml | 5 +- src/ocaml/typing/subst.ml | 9 +- src/ocaml/typing/type_shape.ml | 2 +- src/ocaml/typing/typedecl.mli | 3 +- src/ocaml/typing/typedecl_separability.ml | 6 +- src/ocaml/typing/typedecl_variance.ml | 61 +- src/ocaml/typing/typedecl_variance.mli | 6 +- src/ocaml/typing/typedtree.ml | 74 +- src/ocaml/typing/typedtree.mli | 114 +- src/ocaml/typing/typemod.mli | 4 +- src/ocaml/typing/typeopt.ml | 185 +- src/ocaml/typing/types.mli | 85 +- src/ocaml/typing/typetexp.mli | 4 +- src/ocaml/typing/uniqueness_analysis.ml | 20 +- src/ocaml/typing/unit_info.mli | 21 +- src/ocaml/typing/untypeast.ml | 121 +- src/ocaml/typing/value_rec_check.ml | 53 +- .../typing/vicuna_traverse_typed_tree.ml | 1 - src/ocaml/utils/diffing.ml | 17 +- src/ocaml/utils/language_extension_kernel.ml | 2 - src/ocaml/utils/language_extension_kernel.mli | 1 - src/ocaml/utils/load_path.ml | 65 +- src/ocaml/utils/local_store.mli | 3 +- src/ocaml/utils/warnings.mli | 16 +- src/utils/format_doc.ml | 77 + src/utils/format_doc.mli | 9 + upstream/ocaml_flambda/base-rev.txt | 2 +- .../ocaml_flambda/file_formats/cmt_format.ml | 53 +- .../ocaml_flambda/file_formats/cmt_format.mli | 2 + .../file_formats/linear_format.ml | 8 +- upstream/ocaml_flambda/parsing/ast_helper.ml | 40 +- upstream/ocaml_flambda/parsing/ast_helper.mli | 37 +- .../ocaml_flambda/parsing/ast_invariants.ml | 105 +- .../ocaml_flambda/parsing/ast_invariants.mli | 10 + .../ocaml_flambda/parsing/ast_iterator.ml | 115 +- .../ocaml_flambda/parsing/ast_iterator.mli | 1 + upstream/ocaml_flambda/parsing/ast_mapper.ml | 187 +- upstream/ocaml_flambda/parsing/ast_mapper.mli | 1 + upstream/ocaml_flambda/parsing/asttypes.ml | 75 + upstream/ocaml_flambda/parsing/asttypes.mli | 4 + .../parsing/builtin_attributes.ml | 55 +- .../parsing/builtin_attributes.mli | 2 +- upstream/ocaml_flambda/parsing/depend.ml | 42 +- upstream/ocaml_flambda/parsing/docstrings.ml | 6 +- .../parsing/language_extension.ml | 18 +- .../parsing/language_extension.mli | 1 - upstream/ocaml_flambda/parsing/lexer.mli | 12 +- upstream/ocaml_flambda/parsing/lexer.mll | 377 +- upstream/ocaml_flambda/parsing/location.ml | 92 +- upstream/ocaml_flambda/parsing/location.mli | 44 +- upstream/ocaml_flambda/parsing/longident.ml | 31 +- upstream/ocaml_flambda/parsing/longident.mli | 10 +- upstream/ocaml_flambda/parsing/parse.ml | 26 +- upstream/ocaml_flambda/parsing/parser.mly | 494 ++- upstream/ocaml_flambda/parsing/parsetree.mli | 77 +- upstream/ocaml_flambda/parsing/pprintast.ml | 412 +- upstream/ocaml_flambda/parsing/pprintast.mli | 7 + upstream/ocaml_flambda/parsing/printast.ml | 77 +- upstream/ocaml_flambda/parsing/printast.mli | 4 +- upstream/ocaml_flambda/parsing/unit_info.ml | 72 +- upstream/ocaml_flambda/parsing/unit_info.mli | 21 +- upstream/ocaml_flambda/typing/btype.ml | 89 +- upstream/ocaml_flambda/typing/btype.mli | 23 +- upstream/ocaml_flambda/typing/cmt2annot.ml | 10 +- upstream/ocaml_flambda/typing/ctype.ml | 1201 +++--- upstream/ocaml_flambda/typing/ctype.mli | 81 +- upstream/ocaml_flambda/typing/data_types.ml | 100 + upstream/ocaml_flambda/typing/data_types.mli | 96 + upstream/ocaml_flambda/typing/datarepr.ml | 25 +- upstream/ocaml_flambda/typing/datarepr.mli | 5 +- upstream/ocaml_flambda/typing/env.ml | 624 +-- upstream/ocaml_flambda/typing/env.mli | 20 +- upstream/ocaml_flambda/typing/envaux.ml | 2 +- upstream/ocaml_flambda/typing/errortrace.ml | 12 +- upstream/ocaml_flambda/typing/errortrace.mli | 8 + .../ocaml_flambda/typing/errortrace_report.ml | 657 +++ .../typing/errortrace_report.mli | 56 + upstream/ocaml_flambda/typing/gprinttyp.ml | 999 +++++ upstream/ocaml_flambda/typing/gprinttyp.mli | 326 ++ upstream/ocaml_flambda/typing/ident.ml | 52 +- upstream/ocaml_flambda/typing/ident.mli | 4 + upstream/ocaml_flambda/typing/includeclass.ml | 9 +- .../ocaml_flambda/typing/includeclass.mli | 4 +- upstream/ocaml_flambda/typing/includecore.ml | 131 +- upstream/ocaml_flambda/typing/includecore.mli | 15 + upstream/ocaml_flambda/typing/includemod.ml | 465 +- upstream/ocaml_flambda/typing/includemod.mli | 17 +- .../typing/includemod_errorprinter.ml | 314 +- .../typing/includemod_errorprinter.mli | 2 + upstream/ocaml_flambda/typing/jkind.ml | 6 + upstream/ocaml_flambda/typing/jkind.mli | 3 + upstream/ocaml_flambda/typing/jkind_intf.ml | 4 + upstream/ocaml_flambda/typing/jkind_types.ml | 4 + upstream/ocaml_flambda/typing/mtype.ml | 11 +- upstream/ocaml_flambda/typing/oprint.ml | 164 +- upstream/ocaml_flambda/typing/oprint.mli | 2 +- upstream/ocaml_flambda/typing/out_type.ml | 2880 +++++++++++++ upstream/ocaml_flambda/typing/out_type.mli | 295 ++ upstream/ocaml_flambda/typing/outcometree.mli | 24 +- upstream/ocaml_flambda/typing/parmatch.ml | 107 +- upstream/ocaml_flambda/typing/parmatch.mli | 9 +- upstream/ocaml_flambda/typing/path.ml | 4 + upstream/ocaml_flambda/typing/path.mli | 3 + upstream/ocaml_flambda/typing/patterns.ml | 1 + upstream/ocaml_flambda/typing/patterns.mli | 1 + upstream/ocaml_flambda/typing/predef.ml | 1223 +++--- upstream/ocaml_flambda/typing/predef.mli | 68 + upstream/ocaml_flambda/typing/printpat.ml | 2 +- upstream/ocaml_flambda/typing/printtyp.ml | 3779 +---------------- upstream/ocaml_flambda/typing/printtyp.mli | 327 +- upstream/ocaml_flambda/typing/printtyped.ml | 74 +- upstream/ocaml_flambda/typing/rawprinttyp.ml | 196 + upstream/ocaml_flambda/typing/rawprinttyp.mli | 22 + upstream/ocaml_flambda/typing/shape.ml | 41 +- upstream/ocaml_flambda/typing/shape.mli | 7 +- upstream/ocaml_flambda/typing/shape_reduce.ml | 12 +- upstream/ocaml_flambda/typing/stypes.ml | 5 +- upstream/ocaml_flambda/typing/subst.ml | 9 +- .../ocaml_flambda/typing/tast_iterator.ml | 103 +- upstream/ocaml_flambda/typing/tast_mapper.ml | 128 +- upstream/ocaml_flambda/typing/type_shape.ml | 2 +- upstream/ocaml_flambda/typing/typeclass.ml | 144 +- upstream/ocaml_flambda/typing/typecore.ml | 2646 +++++++----- upstream/ocaml_flambda/typing/typecore.mli | 57 +- upstream/ocaml_flambda/typing/typedecl.ml | 846 ++-- upstream/ocaml_flambda/typing/typedecl.mli | 3 +- .../typing/typedecl_separability.ml | 6 +- .../ocaml_flambda/typing/typedecl_variance.ml | 61 +- .../typing/typedecl_variance.mli | 6 +- upstream/ocaml_flambda/typing/typedtree.ml | 74 +- upstream/ocaml_flambda/typing/typedtree.mli | 114 +- upstream/ocaml_flambda/typing/typemod.ml | 292 +- upstream/ocaml_flambda/typing/typemod.mli | 4 +- upstream/ocaml_flambda/typing/typeopt.ml | 185 +- upstream/ocaml_flambda/typing/types.ml | 101 +- upstream/ocaml_flambda/typing/types.mli | 85 +- upstream/ocaml_flambda/typing/typetexp.ml | 383 +- upstream/ocaml_flambda/typing/typetexp.mli | 4 +- .../typing/uniqueness_analysis.ml | 20 +- upstream/ocaml_flambda/typing/untypeast.ml | 121 +- .../ocaml_flambda/typing/value_rec_check.ml | 53 +- .../typing/vicuna_traverse_typed_tree.ml | 1 - upstream/ocaml_flambda/utils/ccomp.ml | 17 +- upstream/ocaml_flambda/utils/ccomp.mli | 2 - upstream/ocaml_flambda/utils/clflags.ml | 174 +- upstream/ocaml_flambda/utils/clflags.mli | 39 +- upstream/ocaml_flambda/utils/compression.ml | 31 - upstream/ocaml_flambda/utils/compression.mli | 34 - upstream/ocaml_flambda/utils/config.mli | 49 +- upstream/ocaml_flambda/utils/diffing.ml | 17 +- upstream/ocaml_flambda/utils/format_doc.ml | 77 + upstream/ocaml_flambda/utils/format_doc.mli | 9 + .../utils/language_extension_kernel.ml | 2 - .../utils/language_extension_kernel.mli | 1 - upstream/ocaml_flambda/utils/linkdeps.ml | 143 + upstream/ocaml_flambda/utils/linkdeps.mli | 64 + upstream/ocaml_flambda/utils/load_path.ml | 65 +- upstream/ocaml_flambda/utils/local_store.mli | 3 +- upstream/ocaml_flambda/utils/misc.ml | 309 +- upstream/ocaml_flambda/utils/misc.mli | 160 +- .../utils/profile_counters_functions.ml | 16 +- upstream/ocaml_flambda/utils/warnings.ml | 667 +-- upstream/ocaml_flambda/utils/warnings.mli | 16 +- 217 files changed, 18015 insertions(+), 12024 deletions(-) create mode 100644 upstream/ocaml_flambda/parsing/asttypes.ml create mode 100644 upstream/ocaml_flambda/typing/data_types.ml create mode 100644 upstream/ocaml_flambda/typing/data_types.mli create mode 100644 upstream/ocaml_flambda/typing/errortrace_report.ml create mode 100644 upstream/ocaml_flambda/typing/errortrace_report.mli create mode 100644 upstream/ocaml_flambda/typing/gprinttyp.ml create mode 100644 upstream/ocaml_flambda/typing/gprinttyp.mli create mode 100644 upstream/ocaml_flambda/typing/out_type.ml create mode 100644 upstream/ocaml_flambda/typing/out_type.mli create mode 100644 upstream/ocaml_flambda/typing/rawprinttyp.ml create mode 100644 upstream/ocaml_flambda/typing/rawprinttyp.mli create mode 100644 upstream/ocaml_flambda/utils/linkdeps.ml create mode 100644 upstream/ocaml_flambda/utils/linkdeps.mli diff --git a/src/ocaml/parsing/ast_helper.ml b/src/ocaml/parsing/ast_helper.ml index cef93281b..cd0cd801f 100644 --- a/src/ocaml/parsing/ast_helper.ml +++ b/src/ocaml/parsing/ast_helper.ml @@ -36,15 +36,21 @@ 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 untagged_char ?loc c = mk ?loc (Pconst_untagged_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 @@ -76,7 +82,7 @@ module Typ = struct let alias ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_alias (a, b, c)) 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 package ?loc ?attrs a = mk ?loc ?attrs (Ptyp_package a) 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 quote ?loc ?attrs t = mk ?loc ?attrs (Ptyp_quote t) @@ -138,8 +144,8 @@ module Typ = struct v, jkind) var_lst in Ptyp_poly(var_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + | Ptyp_package ptyp -> + Ptyp_package (loop_package_type ptyp) | Ptyp_open (mod_ident, core_type) -> Ptyp_open (mod_ident, loop core_type) | Ptyp_quote core_type -> @@ -184,9 +190,17 @@ module Typ = struct Oinherit (loop t) in { field with pof_desc; } + and loop_package_type ptyp = + { ptyp with + ppt_cstrs = List.map (fun (n,typ) -> (n,loop typ) ) ptyp.ppt_cstrs } in loop t + let package_type ?(loc = !default_loc) ?(attrs = []) p c = + {ppt_loc = loc; + ppt_path = p; + ppt_cstrs = c; + ppt_attrs = attrs} end module Pat = struct @@ -219,6 +233,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 @@ -274,7 +289,7 @@ module Exp = struct 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 c = mk ?loc ?attrs (Pexp_newtype (a, b, c)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) + let pack ?loc ?attrs a b = mk ?loc ?attrs (Pexp_pack (a, b)) 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}) @@ -704,7 +719,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 3ee9e9a23..ce48415fa 100644 --- a/src/ocaml/parsing/ast_helper.mli +++ b/src/ocaml/parsing/ast_helper.mli @@ -46,15 +46,17 @@ 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 untagged_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} *) @@ -77,7 +79,8 @@ module Typ : -> core_type val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> mode with_loc list -> mode with_loc list -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> (string option * core_type) list -> core_type + val tuple: ?loc:loc -> ?attrs:attrs -> (string option * core_type) list + -> core_type val unboxed_tuple: ?loc:loc -> ?attrs:attrs -> (string option * core_type) list -> core_type val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type @@ -91,8 +94,7 @@ module Typ : -> label list option -> core_type val poly: ?loc:loc -> ?attrs:attrs -> (str * jkind_annotation option) list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type + val package: ?loc:loc -> ?attrs:attrs -> package_type -> core_type val open_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type -> core_type val quote : ?loc:loc -> ?attrs:attrs -> core_type -> core_type val splice : ?loc:loc -> ?attrs:attrs -> core_type -> core_type @@ -113,6 +115,10 @@ module Typ : ['a. 'a -> 'a] during parsing. @since 4.05 *) + + val package_type: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list + -> package_type + (** @since 5.4 *) end (** Patterns *) @@ -128,11 +134,11 @@ module Pat: val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern val unboxed_unit: ?loc:loc -> ?attrs:attrs -> unit -> pattern val unboxed_bool: ?loc:loc -> ?attrs:attrs -> bool -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> (string option * pattern) list -> - closed_flag -> pattern val unboxed_tuple: ?loc:loc -> ?attrs:attrs -> (string option * pattern) list -> closed_flag -> pattern + val tuple: ?loc:loc -> ?attrs:attrs -> (string option * pattern) list + -> closed_flag -> pattern val construct: ?loc:loc -> ?attrs:attrs -> lid -> ((str * jkind_annotation option) list * pattern) option -> pattern val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern @@ -150,6 +156,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 @@ -173,9 +180,10 @@ module Exp: val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression val unboxed_unit: ?loc:loc -> ?attrs:attrs -> unit -> expression val unboxed_bool: ?loc:loc -> ?attrs:attrs -> bool -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> (string option * expression) list -> expression val unboxed_tuple: ?loc:loc -> ?attrs:attrs -> (string option * expression) list -> expression + val tuple: ?loc:loc -> ?attrs:attrs -> (string option * expression) list + -> expression val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option @@ -223,7 +231,8 @@ module Exp: val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression val newtype: ?loc:loc -> ?attrs:attrs -> str -> jkind_annotation option -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression + val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> package_type option + -> expression val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression -> expression val letop: ?loc:loc -> ?attrs:attrs -> binding_op diff --git a/src/ocaml/parsing/ast_iterator.ml b/src/ocaml/parsing/ast_iterator.ml index 2a7e8c353..cdee6c44b 100644 --- a/src/ocaml/parsing/ast_iterator.ml +++ b/src/ocaml/parsing/ast_iterator.ml @@ -60,6 +60,7 @@ type iterator = { module_type_declaration: iterator -> module_type_declaration -> unit; open_declaration: iterator -> open_declaration -> unit; open_description: iterator -> open_description -> unit; + package_type: iterator -> package_type -> unit; pat: iterator -> pattern -> unit; payload: iterator -> payload -> unit; signature: iterator -> signature -> unit; @@ -92,6 +93,20 @@ let iter_opt f = function None -> () | Some x -> f x let iter_loc sub {loc; txt = _} = sub.location sub loc +let rec iter_lid sub lid = + let open Longident in + match lid with + | Lident _ -> () + | Ldot (lid, id) -> + iter_loc sub lid; iter_lid sub lid.txt; iter_loc sub id + | Lapply (lid, lid') -> + iter_loc sub lid; iter_lid sub lid.txt; + iter_loc sub lid'; iter_lid sub lid'.txt + +let iter_loc_lid sub {loc; txt} = + iter_loc sub {loc; txt}; + iter_lid sub txt + module T = struct (* Type expressions for the core language *) @@ -123,8 +138,6 @@ module T = struct | None -> () | Some annot -> sub.jkind_annotation sub annot - let iter_labeled_tuple sub tl = List.iter (iter_snd (sub.typ sub)) tl - let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = sub.location sub loc; sub.attributes sub attrs; @@ -134,14 +147,14 @@ module T = struct | Ptyp_arrow (_lab, t1, t2, m1, m2) -> sub.typ sub t1; sub.typ sub t2; sub.modes sub m1; sub.modes sub m2 - | Ptyp_tuple tyl -> iter_labeled_tuple sub tyl - | Ptyp_unboxed_tuple tyl -> iter_labeled_tuple sub tyl + | Ptyp_tuple tyl -> List.iter (fun (_, e) -> sub.typ sub e) tyl + | Ptyp_unboxed_tuple tyl -> List.iter (fun (_, e) -> sub.typ sub e) tyl | Ptyp_constr (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl + iter_loc_lid 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 + iter_loc_lid sub lid; List.iter (sub.typ sub) tl | Ptyp_alias (t, _, jkind) -> sub.typ sub t; Option.iter (sub.jkind_annotation sub) jkind @@ -150,11 +163,10 @@ module T = struct | Ptyp_poly (bound_vars, t) -> List.iter (bound_var sub) bound_vars; sub.typ sub t; - | Ptyp_package (lid, l) -> - iter_loc sub lid; - List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l + | Ptyp_package ptyp -> + sub.package_type sub ptyp | Ptyp_open (mod_ident, t) -> - iter_loc sub mod_ident; + iter_loc_lid sub mod_ident; sub.typ sub t | Ptyp_quote t -> sub.typ sub t | Ptyp_splice t -> sub.typ sub t @@ -207,7 +219,7 @@ module T = struct ptyext_private = _; ptyext_loc; ptyext_attributes} = - iter_loc sub ptyext_path; + iter_loc_lid 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; @@ -225,7 +237,7 @@ module T = struct iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto | Pext_rebind li -> - iter_loc sub li + iter_loc_lid sub li let iter_extension_constructor sub {pext_name; @@ -237,6 +249,12 @@ module T = struct iter_extension_constructor_kind sub pext_kind; sub.attributes sub pext_attributes + let iter_package_type sub {ppt_path; ppt_cstrs; ppt_loc; ppt_attrs} = + sub.location sub ppt_loc; + iter_loc_lid sub ppt_path; + List.iter (iter_tuple (iter_loc_lid sub) (sub.typ sub)) ppt_cstrs; + sub.attributes sub ppt_attrs + end module CT = struct @@ -247,7 +265,7 @@ module CT = struct sub.attributes sub attrs; match desc with | Pcty_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys + iter_loc_lid 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 @@ -287,8 +305,8 @@ module MT = struct 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_ident s -> iter_loc_lid sub s + | Pmty_alias s -> iter_loc_lid sub s | Pmty_signature sg -> sub.signature sub sg | Pmty_functor (param, mt2, mm2) -> iter_functor_param sub param; @@ -305,19 +323,19 @@ module MT = struct let iter_with_constraint sub = function | Pwith_type (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d + iter_loc_lid sub lid; sub.type_declaration sub d | Pwith_module (lid, lid2) -> - iter_loc sub lid; iter_loc sub lid2 + iter_loc_lid sub lid; iter_loc_lid sub lid2 | Pwith_modtype (lid, mty) -> - iter_loc sub lid; sub.module_type sub mty + iter_loc_lid sub lid; sub.module_type sub mty | Pwith_jkind (lid, d) -> iter_loc sub lid; sub.jkind_declaration sub d | Pwith_typesubst (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d + iter_loc_lid sub lid; sub.type_declaration sub d | Pwith_modsubst (s, lid) -> - iter_loc sub s; iter_loc sub lid + iter_loc_lid sub s; iter_loc_lid sub lid | Pwith_modtypesubst (lid, mty) -> - iter_loc sub lid; sub.module_type sub mty + iter_loc_lid sub lid; sub.module_type sub mty | Pwith_jkindsubst (lid, d) -> iter_loc sub lid; sub.jkind_declaration sub d @@ -357,7 +375,7 @@ module M = struct sub.location sub loc; sub.attributes sub attrs; match desc with - | Pmod_ident x -> iter_loc sub x + | Pmod_ident x -> iter_loc_lid sub x | Pmod_structure str -> sub.structure sub str | Pmod_functor (param, body) -> iter_functor_param sub param; @@ -461,20 +479,18 @@ module E = struct sub.location sub loc; sub.attributes sub attrs - let iter_labeled_tuple sub el = List.iter (iter_snd (sub.expr sub)) el - let iter_block_access sub = function - | Baccess_field lid -> iter_loc sub lid + | Baccess_field lid -> iter_loc_lid sub lid | Baccess_block (_, idx) -> sub.expr sub idx let iter_unboxed_access sub = function - | Uaccess_unboxed_field lid -> iter_loc sub lid + | Uaccess_unboxed_field lid -> iter_loc_lid sub lid 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_ident x -> iter_loc_lid sub x | Pexp_constant _ -> () | Pexp_let (_m, _r, vbs, e) -> List.iter (sub.value_binding sub) vbs; @@ -490,21 +506,21 @@ module E = struct | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel | Pexp_unboxed_unit -> () | Pexp_unboxed_bool _ -> () - | Pexp_tuple el -> iter_labeled_tuple sub el - | Pexp_unboxed_tuple el -> iter_labeled_tuple sub el + | Pexp_tuple el -> List.iter (fun (_, e) -> sub.expr sub e) el + | Pexp_unboxed_tuple el -> List.iter (fun (_, e) -> sub.expr sub e) el | Pexp_construct (lid, arg) -> - iter_loc sub lid; iter_opt (sub.expr sub) arg + iter_loc_lid sub lid; iter_opt (sub.expr sub) arg | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo | Pexp_record (l, eo) | Pexp_record_unboxed_product (l, eo) -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; + List.iter (iter_tuple (iter_loc_lid sub) (sub.expr sub)) l; iter_opt (sub.expr sub) eo | Pexp_field (e, lid) | Pexp_unboxed_field (e, lid) -> - sub.expr sub e; iter_loc sub lid + sub.expr sub e; iter_loc_lid sub lid | Pexp_setfield (e1, lid, e2) -> - sub.expr sub e1; iter_loc sub lid; + sub.expr sub e1; iter_loc_lid sub lid; sub.expr sub e2 | Pexp_array (_mut, el) -> List.iter (sub.expr sub) el | Pexp_idx (ba, uas) -> @@ -528,7 +544,7 @@ module E = struct Option.iter (sub.typ sub) t; sub.modes sub m | Pexp_send (e, _s) -> sub.expr sub e - | Pexp_new lid -> iter_loc sub lid + | Pexp_new lid -> iter_loc_lid sub lid | Pexp_setvar (s, e) -> iter_loc sub s; sub.expr sub e | Pexp_override sel -> @@ -548,7 +564,9 @@ module E = struct iter_loc sub s; Option.iter (sub.jkind_annotation sub) jkind; sub.expr sub e - | Pexp_pack me -> sub.module_expr sub me + | Pexp_pack (me, optyp) -> + sub.module_expr sub me; + Option.iter (sub.package_type sub) optyp | Pexp_open (o, e) -> sub.open_declaration sub o; sub.expr sub e | Pexp_letop {let_; ands; body} -> @@ -576,8 +594,6 @@ end module P = struct (* Patterns *) - let iter_labeled_tuple sub pl = List.iter (iter_snd (sub.pat sub)) pl - let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = sub.location sub loc; sub.attributes sub attrs; @@ -589,10 +605,10 @@ module P = struct | Ppat_interval _ -> () | Ppat_unboxed_unit -> () | Ppat_unboxed_bool _ -> () - | Ppat_tuple (pl, _) -> iter_labeled_tuple sub pl - | Ppat_unboxed_tuple (pl, _) -> iter_labeled_tuple sub pl + | Ppat_tuple (pl, _) -> List.iter (fun (_, p) -> sub.pat sub p) pl + | Ppat_unboxed_tuple (pl, _) -> List.iter (fun (_, p) -> sub.pat sub p) pl | Ppat_construct (l, p) -> - iter_loc sub l; + iter_loc_lid sub l; iter_opt (fun (vl,p) -> List.iter @@ -605,18 +621,19 @@ module P = struct | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p | Ppat_record (lpl, _cf) | Ppat_record_unboxed_product (lpl, _cf) -> - List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl + List.iter (iter_tuple (iter_loc_lid sub) (sub.pat sub)) lpl | Ppat_array (_mut, pl) -> List.iter (sub.pat sub) pl | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 | Ppat_constraint (p, t, m) -> sub.pat sub p; Option.iter (sub.typ sub) t; sub.modes sub m; - | Ppat_type s -> iter_loc sub s + | Ppat_type s -> iter_loc_lid 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 + iter_loc_lid sub lid; sub.pat sub p end @@ -628,7 +645,7 @@ module CE = struct sub.attributes sub attrs; match desc with | Pcl_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys + iter_loc_lid sub lid; List.iter (sub.typ sub) tys | Pcl_structure s -> sub.class_structure sub s | Pcl_fun (_lab, e, p, ce) -> @@ -716,6 +733,7 @@ let default_iterator = type_extension = T.iter_type_extension; type_exception = T.iter_type_exception; extension_constructor = T.iter_extension_constructor; + package_type = T.iter_package_type; value_description = (fun this {pval_name; pval_type; pval_modalities; pval_prim = _; pval_poly=_; pval_loc; pval_attributes} -> @@ -741,7 +759,7 @@ let default_iterator = module_substitution = (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> iter_loc this pms_name; - iter_loc this pms_manifest; + iter_loc_lid this pms_manifest; this.location this pms_loc; this.attributes this pms_attributes; ); @@ -770,7 +788,7 @@ let default_iterator = open_description = (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> - iter_loc this popen_expr; + iter_loc_lid this popen_expr; this.location this popen_loc; this.attributes this popen_attributes ); @@ -893,7 +911,10 @@ let default_iterator = directive_argument = (fun this a -> - this.location this a.pdira_loc + this.location this a.pdira_loc; + match a.pdira_desc with + | Pdir_ident lid -> iter_lid this lid + | Pdir_int _ | Pdir_string _ | Pdir_bool _ -> () ); toplevel_directive = diff --git a/src/ocaml/parsing/ast_iterator.mli b/src/ocaml/parsing/ast_iterator.mli index 87544e63c..021eca6dd 100644 --- a/src/ocaml/parsing/ast_iterator.mli +++ b/src/ocaml/parsing/ast_iterator.mli @@ -63,6 +63,7 @@ type iterator = { module_type_declaration: iterator -> module_type_declaration -> unit; open_declaration: iterator -> open_declaration -> unit; open_description: iterator -> open_description -> unit; + package_type: iterator -> package_type -> unit; pat: iterator -> pattern -> unit; payload: iterator -> payload -> unit; signature: iterator -> signature -> unit; diff --git a/src/ocaml/parsing/ast_mapper.ml b/src/ocaml/parsing/ast_mapper.ml index e566c2fb5..e1568806e 100644 --- a/src/ocaml/parsing/ast_mapper.ml +++ b/src/ocaml/parsing/ast_mapper.ml @@ -70,6 +70,7 @@ type mapper = { -> module_type_declaration; open_declaration: mapper -> open_declaration -> open_declaration; open_description: mapper -> open_description -> open_description; + package_type: mapper -> package_type -> package_type; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; signature: mapper -> signature -> signature; @@ -96,20 +97,40 @@ let map_opt f = function None -> None | Some x -> Some (f x) let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +let rec map_lid sub lid = + let open Longident in + match lid with + | Lident id -> Lident id + | Ldot (lid, id) -> + let lid = { lid with txt = map_lid sub lid.txt } in + Ldot (map_loc sub lid, map_loc sub id) + | Lapply (lid, lid') -> + let lid = { lid with txt = map_lid sub lid.txt } in + let lid' = { lid' with txt = map_lid sub lid'.txt } in + Lapply(map_loc sub lid, map_loc sub lid') + +let map_loc_lid sub {loc; txt} = + let txt = map_lid sub txt in + map_loc sub {loc; txt} + module C = struct (* Constants *) - let map sub c = match c with - | Pconst_integer _ - | Pconst_unboxed_integer _ - | Pconst_char _ - | Pconst_untagged_char _ - | Pconst_float _ - | Pconst_unboxed_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_unboxed_integer _ + | Pconst_char _ + | Pconst_untagged_char _ + | Pconst_float _ + | Pconst_unboxed_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 @@ -150,8 +171,6 @@ module T = struct let map_bound_vars sub bound_vars = List.map (var_jkind sub) bound_vars - let map_labeled_tuple sub tl = List.map (map_snd (sub.typ sub)) tl - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = let open Typ in let loc = sub.location sub loc in @@ -165,15 +184,17 @@ module T = struct var ~loc ~attrs s jkind | Ptyp_arrow (lab, t1, t2, m1, m2) -> arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) (sub.modes sub m1) (sub.modes sub m2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (map_labeled_tuple sub tyl) + | Ptyp_tuple tyl -> + tuple ~loc ~attrs (List.map (fun (l, t) -> l, sub.typ sub t) tyl) | Ptyp_unboxed_tuple tyl -> - unboxed_tuple ~loc ~attrs (map_labeled_tuple sub tyl) + unboxed_tuple ~loc ~attrs + (List.map (fun (l, t) -> l, sub.typ sub t) tyl) | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + constr ~loc ~attrs (map_loc_lid 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) + class_ ~loc ~attrs (map_loc_lid sub lid) (List.map (sub.typ sub) tl) | Ptyp_alias (t, s, jkind) -> let s = map_opt (map_loc sub) s in let jkind = map_opt (sub.jkind_annotation sub) jkind in @@ -189,11 +210,10 @@ module T = struct in let t = sub.typ sub t in poly ~loc ~attrs sl t - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_package ptyp -> + package ~loc ~attrs (sub.package_type sub ptyp) | Ptyp_open (mod_ident, t) -> - open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t) + open_ ~loc ~attrs (map_loc_lid sub mod_ident) (sub.typ sub t) | Ptyp_quote t -> quote ~loc ~attrs (sub.typ sub t) | Ptyp_splice t -> @@ -259,7 +279,7 @@ module T = struct 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) + (map_loc_lid sub ptyext_path) (List.map (sub.extension_constructor sub) ptyext_constructors) ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) ~priv:ptyext_private @@ -277,7 +297,7 @@ module T = struct map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) | Pext_rebind li -> - Pext_rebind (map_loc sub li) + Pext_rebind (map_loc_lid sub li) let map_extension_constructor sub {pext_name; @@ -291,6 +311,12 @@ module T = struct name (map_extension_constructor_kind sub pext_kind) + let map_package_type sub {ppt_loc; ppt_path; ppt_cstrs; ppt_attrs} = + let loc = sub.location sub ppt_loc in + let attrs = sub.attributes sub ppt_attrs in + Typ.package_type ~loc ~attrs (map_loc_lid sub ppt_path) + (List.map (map_tuple (map_loc_lid sub) (sub.typ sub)) ppt_cstrs) + end module CT = struct @@ -302,7 +328,7 @@ module CT = struct 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) + constr ~loc ~attrs (map_loc_lid 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) @@ -344,8 +370,8 @@ module MT = struct 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_ident s -> ident ~loc ~attrs (map_loc_lid sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc_lid sub s) | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) | Pmty_functor (param, mt, mm) -> functor_ ~loc ~attrs ~ret_mode:(sub.modes sub mm) @@ -363,21 +389,21 @@ module MT = struct let map_with_constraint sub = function | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) + Pwith_type (map_loc_lid sub lid, sub.type_declaration sub d) | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) + Pwith_module (map_loc_lid sub lid, map_loc_lid sub lid2) | Pwith_modtype (lid, mty) -> - Pwith_modtype (map_loc sub lid, sub.module_type sub mty) + Pwith_modtype (map_loc_lid sub lid, sub.module_type sub mty) | Pwith_jkind (lid, d) -> - Pwith_jkind (map_loc sub lid, sub.jkind_declaration sub d) + Pwith_jkind (map_loc_lid sub lid, sub.jkind_declaration sub d) | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) + Pwith_typesubst (map_loc_lid sub lid, sub.type_declaration sub d) | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) + Pwith_modsubst (map_loc_lid sub s, map_loc_lid sub lid) | Pwith_modtypesubst (lid, mty) -> - Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) + Pwith_modtypesubst (map_loc_lid sub lid, sub.module_type sub mty) | Pwith_jkindsubst (lid, d) -> - Pwith_jkindsubst (map_loc sub lid, sub.jkind_declaration sub d) + Pwith_jkindsubst (map_loc_lid sub lid, sub.jkind_declaration sub d) let map_signature_item sub {psig_desc = desc; psig_loc = loc} = let open Sig in @@ -418,7 +444,7 @@ module M = struct 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_ident x -> ident ~loc ~attrs (map_loc_lid sub x) | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) | Pmod_functor (param, body) -> functor_ ~loc ~attrs @@ -502,11 +528,11 @@ module E = struct } let map_block_access sub = function - | Baccess_field lid -> Baccess_field (map_loc sub lid) + | Baccess_field lid -> Baccess_field (map_loc_lid sub lid) | Baccess_block (mut, e) -> Baccess_block (mut, sub.expr sub e) let map_unboxed_access sub = function - | Uaccess_unboxed_field lid -> Uaccess_unboxed_field (map_loc sub lid) + | Uaccess_unboxed_field lid -> Uaccess_unboxed_field (map_loc_lid sub lid) let map_iterator sub = function | Pcomp_range { start; stop; direction } -> @@ -536,13 +562,12 @@ module E = struct | Pcomp_array_comprehension (mut, comp) -> Pcomp_array_comprehension (mut, map_comp sub comp) - let map_ltexp sub el = List.map (map_snd (sub.expr sub)) el 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_ident x -> ident ~loc ~attrs (map_loc_lid sub x) | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) | Pexp_let (m, r, vbs, e) -> let_ ~loc ~attrs m r (List.map (sub.value_binding sub) vbs) @@ -560,26 +585,28 @@ module E = struct | Pexp_unboxed_unit -> unboxed_unit ~loc ~attrs () | Pexp_unboxed_bool b -> unboxed_bool ~loc ~attrs b | Pexp_tuple el -> - tuple ~loc ~attrs (map_ltexp sub el) + tuple ~loc ~attrs (List.map (fun (l, e) -> l, sub.expr sub e) el) | Pexp_unboxed_tuple el -> - unboxed_tuple ~loc ~attrs (map_ltexp sub el) + unboxed_tuple ~loc ~attrs + (List.map (fun (l, e) -> l, sub.expr sub e) el) | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + construct ~loc ~attrs (map_loc_lid 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) + record ~loc ~attrs + (List.map (map_tuple (map_loc_lid sub) (sub.expr sub)) l) (map_opt (sub.expr sub) eo) | Pexp_record_unboxed_product (l, eo) -> record_unboxed_product ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (List.map (map_tuple (map_loc_lid 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) + field ~loc ~attrs (sub.expr sub e) (map_loc_lid sub lid) | Pexp_unboxed_field (e, lid) -> - unboxed_field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + unboxed_field ~loc ~attrs (sub.expr sub e) (map_loc_lid sub lid) | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) + setfield ~loc ~attrs (sub.expr sub e1) (map_loc_lid sub lid) (sub.expr sub e2) | Pexp_array (mut, el) -> array ~loc ~attrs mut (List.map (sub.expr sub) el) | Pexp_idx (ba, uas) -> @@ -602,7 +629,7 @@ module E = struct constraint_ ~loc ~attrs (sub.expr sub e) (Option.map (sub.typ sub) t) (sub.modes sub m) | 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_new lid -> new_ ~loc ~attrs (map_loc_lid sub lid) | Pexp_setvar (s, e) -> setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_override sel -> @@ -624,7 +651,9 @@ module E = struct newtype ~loc ~attrs (map_loc sub s) (map_opt (sub.jkind_annotation sub) jkind) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_pack (me, optyp) -> + let optyp = Option.map (sub.package_type sub) optyp in + pack ~loc ~attrs (sub.module_expr sub me) optyp | Pexp_open (o, e) -> open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) | Pexp_letop {let_; ands; body} -> @@ -653,8 +682,6 @@ end module P = struct (* Patterns *) - let map_ltpat sub pl = List.map (map_snd (sub.pat sub)) pl - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = let open Pat in let loc = sub.location sub loc in @@ -668,11 +695,13 @@ module P = struct interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) | Ppat_unboxed_unit -> unboxed_unit ~loc ~attrs () | Ppat_unboxed_bool b -> unboxed_bool ~loc ~attrs b - | Ppat_tuple (pl, c) -> tuple ~loc ~attrs (map_ltpat sub pl) c + | Ppat_tuple (pl,c) -> + tuple ~loc ~attrs (List.map (fun (l, p) -> l, sub.pat sub p) pl) c | Ppat_unboxed_tuple (pl, c) -> - unboxed_tuple ~loc ~attrs (map_ltpat sub pl) c + unboxed_tuple ~loc ~attrs + (List.map (fun (l, p) -> l, sub.pat sub p) pl) c | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) + construct ~loc ~attrs (map_loc_lid sub l) (map_opt (fun (vl, p) -> List.map @@ -684,7 +713,7 @@ module P = struct | 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 + (List.map (map_tuple (map_loc_lid sub) (sub.pat sub)) lpl) cf | Ppat_record_unboxed_product (lpl, cf) -> record_unboxed_product ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf @@ -692,11 +721,14 @@ module P = struct | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_constraint (p, t, m) -> constraint_ ~loc ~attrs (sub.pat sub p) (Option.map (sub.typ sub) t) (sub.modes sub m) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_type s -> type_ ~loc ~attrs (map_loc_lid 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_open (lid,p) -> + open_ ~loc ~attrs (map_loc_lid 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 @@ -709,7 +741,7 @@ module CE = struct 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) + constr ~loc ~attrs (map_loc_lid 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) -> @@ -805,6 +837,7 @@ let default_mapper = type_extension = T.map_type_extension; type_exception = T.map_type_exception; extension_constructor = T.map_extension_constructor; + package_type = T.map_package_type; value_description = (fun this {pval_name; pval_type; pval_modalities; pval_prim; pval_poly; pval_loc; pval_attributes} -> @@ -836,7 +869,7 @@ let default_mapper = (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> Ms.mk (map_loc this pms_name) - (map_loc this pms_manifest) + (map_loc_lid this pms_manifest) ~attrs:(this.attributes this pms_attributes) ~loc:(this.location this pms_loc) ); @@ -868,7 +901,7 @@ let default_mapper = open_description = (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) + Opn.mk (map_loc_lid this popen_expr) ~override:popen_override ~loc:(this.location this popen_loc) ~attrs:(this.attributes this popen_attributes) @@ -1011,7 +1044,10 @@ let default_mapper = directive_argument = (fun this a -> - { pdira_desc= a.pdira_desc + { pdira_desc= begin match a.pdira_desc with + | Pdir_ident lid -> Pdir_ident (map_lid this lid) + | Pdir_int _ | Pdir_bool _ | Pdir_string _ as x -> x + end ; pdira_loc= this.location this a.pdira_loc} ); toplevel_directive = @@ -1033,17 +1069,17 @@ let extension_of_error {kind; main; sub} = let extension_of_sub sub = { loc = sub.loc; txt = "ocaml.error" }, PStr ([Str.eval (Exp.constant - (Pconst_string (str_of_msg 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_msg 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 @@ -1064,7 +1100,7 @@ module PpxContext = struct open Asttypes open Ast_helper - let lid name = { txt = Lident name; loc = Location.none } + let lid name = mknoloc (Lident name) let make_string s = Exp.constant (Const.string s) @@ -1076,7 +1112,8 @@ module PpxContext = struct let rec make_list f lst = match lst with | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [None, f x; None, make_list f rest])) + Exp.construct (lid "::") + (Some (Exp.tuple [None, f x; None, make_list f rest])) | [] -> Exp.construct (lid "[]") None @@ -1129,7 +1166,7 @@ module PpxContext = struct 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 "no_alias_deps", make_bool !Clflags.no_alias_deps; lid "unboxed_types", make_bool !Clflags.unboxed_types; lid "unsafe_string", make_bool false; (* kept for compatibility *) get_cookies () @@ -1147,7 +1184,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 = @@ -1163,7 +1201,8 @@ module PpxContext = struct and get_list elem = function | {pexp_desc = Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [None, exp; None, rest]}) } -> + Some {pexp_desc = Pexp_tuple [None, exp; + None, rest]}) } -> elem exp :: get_list elem rest | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> @@ -1177,10 +1216,12 @@ module PpxContext = struct { %s }] pair syntax" name and get_option elem = function | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> + Pexp_construct ({ txt = Longident.Lident "Some" }, + Some exp) } -> Some (elem exp) | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> + Pexp_construct ({ txt = Longident.Lident "None" }, + None) } -> None | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ { %s }] option syntax" name @@ -1234,8 +1275,8 @@ module PpxContext = struct Clflags.recursive_types := get_bool payload | "principal" -> Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload + | "no_alias_deps" -> + Clflags.no_alias_deps := get_bool payload | "unboxed_types" -> Clflags.unboxed_types := get_bool payload | "cookies" -> diff --git a/src/ocaml/parsing/ast_mapper.mli b/src/ocaml/parsing/ast_mapper.mli index e2e8dbb54..8e6b1ca75 100644 --- a/src/ocaml/parsing/ast_mapper.mli +++ b/src/ocaml/parsing/ast_mapper.mli @@ -105,6 +105,7 @@ type mapper = { -> module_type_declaration; open_declaration: mapper -> open_declaration -> open_declaration; open_description: mapper -> open_description -> open_description; + package_type: mapper -> package_type -> package_type; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; signature: mapper -> signature -> signature; diff --git a/src/ocaml/parsing/asttypes.mli b/src/ocaml/parsing/asttypes.mli index 11594108c..db001848d 100644 --- a/src/ocaml/parsing/asttypes.mli +++ b/src/ocaml/parsing/asttypes.mli @@ -40,6 +40,8 @@ type private_flag = Private | Public type mutable_flag = Immutable | Mutable +type atomic_flag = Nonatomic | Atomic + type virtual_flag = Virtual | Concrete type override_flag = Override | Fresh @@ -64,8 +66,10 @@ type variance = | Covariant | Contravariant | NoVariance + | Bivariant type injectivity = | Injective | NoInjectivity +val string_of_label: arg_label -> string diff --git a/src/ocaml/parsing/builtin_attributes.mli b/src/ocaml/parsing/builtin_attributes.mli index b45bc97c6..7490eca8f 100644 --- a/src/ocaml/parsing/builtin_attributes.mli +++ b/src/ocaml/parsing/builtin_attributes.mli @@ -189,7 +189,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/language_extension.ml b/src/ocaml/parsing/language_extension.ml index e313dbbb7..fd91b3c5a 100644 --- a/src/ocaml/parsing/language_extension.ml +++ b/src/ocaml/parsing/language_extension.ml @@ -70,7 +70,6 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = | Module_strengthening -> (module Unit) | Layouts -> (module Maturity) | SIMD -> (module Maturity) - | Labeled_tuples -> (module Unit) | Small_numbers -> (module Maturity) | Instances -> (module Unit) | Let_mutable -> (module Unit) @@ -88,8 +87,8 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = let is_erasable : type a. a t -> bool = function | Mode | Unique | Overwriting | Layouts | Layout_poly -> true | Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays - | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances - | Let_mutable | Runtime_metaprogramming -> + | Module_strengthening | SIMD | Small_numbers | Instances | Let_mutable + | Runtime_metaprogramming -> false let maturity_of_unique_for_drf = Stable @@ -110,7 +109,6 @@ module Exist_pair = struct | Pair (Module_strengthening, ()) -> Stable | Pair (Layouts, m) -> m | Pair (SIMD, m) -> m - | Pair (Labeled_tuples, ()) -> Stable | Pair (Small_numbers, m) -> m | Pair (Instances, ()) -> Stable | Pair (Let_mutable, ()) -> Stable @@ -130,9 +128,8 @@ module Exist_pair = struct to_string Layout_poly ^ "_" ^ maturity_to_string m | Pair ( (( Comprehensions | Include_functor | Polymorphic_parameters - | Immutable_arrays | Module_strengthening | Labeled_tuples - | Instances | Overwriting | Let_mutable | Runtime_metaprogramming ) - as ext), + | Immutable_arrays | Module_strengthening | Instances | Overwriting + | Let_mutable | Runtime_metaprogramming ) as ext), _ ) -> to_string ext @@ -160,7 +157,6 @@ module Exist_pair = struct | "simd" -> Some (Pair (SIMD, Stable)) | "simd_beta" -> Some (Pair (SIMD, Beta)) | "simd_alpha" -> Some (Pair (SIMD, Alpha)) - | "labeled_tuples" -> Some (Pair (Labeled_tuples, ())) | "small_numbers" -> Some (Pair (Small_numbers, Stable)) | "small_numbers_beta" -> Some (Pair (Small_numbers, Beta)) | "instances" -> Some (Pair (Instances, ())) @@ -187,7 +183,6 @@ let all_extensions = Pack Module_strengthening; Pack Layouts; Pack SIMD; - Pack Labeled_tuples; Pack Small_numbers; Pack Instances; Pack Let_mutable; @@ -228,7 +223,6 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc_stdlib.eq option = | Module_strengthening, Module_strengthening -> Some Refl | Layouts, Layouts -> Some Refl | SIMD, SIMD -> Some Refl - | Labeled_tuples, Labeled_tuples -> Some Refl | Small_numbers, Small_numbers -> Some Refl | Instances, Instances -> Some Refl | Let_mutable, Let_mutable -> Some Refl @@ -236,8 +230,8 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc_stdlib.eq option = | Runtime_metaprogramming, Runtime_metaprogramming -> Some Refl | ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor | Polymorphic_parameters | Immutable_arrays | Module_strengthening - | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances - | Let_mutable | Layout_poly | Runtime_metaprogramming ), + | Layouts | SIMD | Small_numbers | Instances | Let_mutable | Layout_poly + | Runtime_metaprogramming ), _ ) -> None diff --git a/src/ocaml/parsing/language_extension.mli b/src/ocaml/parsing/language_extension.mli index 724b3feef..0ffebeec4 100644 --- a/src/ocaml/parsing/language_extension.mli +++ b/src/ocaml/parsing/language_extension.mli @@ -27,7 +27,6 @@ type 'a t = 'a Language_extension_kernel.t = | Module_strengthening : unit t | Layouts : maturity t | SIMD : maturity t - | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : unit t | Let_mutable : unit t diff --git a/src/ocaml/parsing/longident.ml b/src/ocaml/parsing/longident.ml index 837c6a952..c4ecc0677 100644 --- a/src/ocaml/parsing/longident.ml +++ b/src/ocaml/parsing/longident.ml @@ -12,15 +12,34 @@ (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) +open Location type t = Lident of string - | Ldot of t * string - | Lapply of t * t + | Ldot of t loc * string loc + | Lapply of t loc * t loc + + +let rec same t t' = + t == t' + || match t, t' with + | Lident s, Lident s' -> + String.equal s s' + | Ldot ({ txt = t; _ }, { txt = s; _ }), + Ldot ({ txt = t'; _ }, { txt = s'; _ }) -> + if String.equal s s' then + same t t' + else + false + | Lapply ({ txt = tl; _ }, { txt = tr; _ }), + Lapply ({ txt = tl'; _ }, { txt = tr'; _ }) -> + same tl tl' && same tr tr' + | _, _ -> false + let rec flat accu = function Lident s -> s :: accu - | Ldot(lid, s) -> flat (s :: accu) lid + | Ldot({ txt = lid; _ }, { txt = s; _ }) -> flat (s :: accu) lid | Lapply(_, _) -> Misc.fatal_error "Longident.flat" let flatten lid = flat [] lid @@ -32,7 +51,7 @@ let rec head = function let last = function Lident s -> s - | Ldot(_, s) -> s + | Ldot(_, s) -> s.txt | Lapply(_, _) -> Misc.fatal_error "Longident.last" @@ -46,7 +65,9 @@ let rec split_at_dots s pos = let unflatten l = match l with | [] -> None - | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) + | hd :: tl -> + Some (List.fold_left (fun p s -> Ldot(mknoloc p, mknoloc s)) + (Lident hd) tl) let parse s = match unflatten (split_at_dots s 0) with diff --git a/src/ocaml/parsing/longident.mli b/src/ocaml/parsing/longident.mli index 72c5964fb..9d8f4fd25 100644 --- a/src/ocaml/parsing/longident.mli +++ b/src/ocaml/parsing/longident.mli @@ -23,10 +23,16 @@ *) +open Location + type t = Lident of string - | Ldot of t * string - | Lapply of t * t + | Ldot of t loc * string loc + | Lapply of t loc * t loc + +(** [same t t'] compares the longidents [t] and [t'] without taking locations + into account. *) +val same: t -> t -> bool val flatten: t -> string list val unflatten: string list -> t option diff --git a/src/ocaml/parsing/parsetree.mli b/src/ocaml/parsing/parsetree.mli index 36f266cb7..067b3d4a4 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]. @@ -121,9 +126,12 @@ and core_type_desc = *) | Ptyp_tuple of (string option * core_type) list (** [Ptyp_tuple(tl)] represents a product type: - - [T1 * ... * Tn] when [tl] is [(None,T1);...;(None,Tn)] - - [L1:T1 * ... * Ln:Tn] when [tl] is [(Some L1,T1);...;(Some Ln,Tn)] - - A mix, e.g. [L1:T1 * T2] when [tl] is [(Some L1,T1);(None,T2)] + - [T1 * ... * Tn] + when [tl] is [(None, T1); ...; (None, Tn)] + - [L1:T1 * ... * Ln:Tn] + when [tl] is [(Some L1, T1); ...; (Some Ln, Tn)] + - A mix, e.g., [L1:T1 * T2] + when [tl] is [(Some L1, T1); (None, T2)] Invariant: [n >= 2]. *) @@ -223,10 +231,16 @@ and arg_label = Asttypes.arg_label = | Labelled of string | Optional of string -and package_type = Longident.t loc * (Longident.t loc * core_type) list +and package_type = + { + ppt_path: Longident.t loc; + ppt_cstrs: (Longident.t loc * core_type) list; + ppt_loc: Location.t; + ppt_attrs: attributes; + } (** As {!package_type} typed values: - - [(S, [])] represents [(module S)], - - [(S, [(t1, T1) ; ... ; (tn, Tn)])] + - [{ppt_path: S; ppt_cstrs: []}] represents [(module S)], + - [{ppt_path: S; ppt_cstrs: [(t1, T1) ; ... ; (tn, Tn)]}] represents [(module S with type t1 = T1 and ... and tn = Tn)]. *) @@ -285,18 +299,6 @@ and pattern_desc = but rejected by the type-checker. *) | Ppat_unboxed_unit (** [#()] *) | Ppat_unboxed_bool of bool (** [#false] or [#true] *) - | Ppat_tuple of (string option * pattern) list * Asttypes.closed_flag - (** [Ppat_tuple(pl, Closed)] represents - - [(P1, ..., Pn)] when [pl] is [(None, P1);...;(None, Pn)] - - [(~L1:P1, ..., ~Ln:Pn)] when [pl] is - [(Some L1, P1);...;(Some Ln, Pn)] - - A mix, e.g. [(~L1:P1, P2)] when [pl] is [(Some L1, P1);(None, P2)] - - If pattern is open, then it also ends in a [..] - - Invariant: - - If Closed, [n >= 2]. - - If Open, [n >= 1]. - *) | Ppat_unboxed_tuple of (string option * pattern) list * Asttypes.closed_flag (** Unboxed tuple patterns: [#(l1:P1, ..., ln:Pn)] is [([(Some l1,P1);...;(Some l2,Pn)], Closed)], and the labels are optional. An @@ -306,6 +308,22 @@ and pattern_desc = - If Closed, [n >= 2] - If Open, [n >= 1] *) + | Ppat_tuple of (string option * pattern) list * Asttypes.closed_flag + (** [Ppat_tuple(pl, Closed)] represents + - [(P1, ..., Pn)] + when [pl] is [(None, P1); ...; (None, Pn)] + - [(~L1:P1, ..., ~Ln:Pn)] + when [pl] is [(Some L1, P1); ...; (Some Ln, Pn)] + - A mix, e.g. [(~L1:P1, P2)] + when [pl] is [(Some L1, P1); (None, P2)] + + [Ppat_tuple(pl, Open)] is similar, but indicates the pattern + additionally ends in a [..]. + + Invariant: + - If Closed, [n >= 2]. + - If Open, [n >= 1]. + *) | Ppat_construct of Longident.t loc * ((string loc * jkind_annotation option) list * pattern) option @@ -360,6 +378,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)] *) @@ -403,8 +422,9 @@ and expression_desc = [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. + A function must have parameters: in [Pexp_function (params, _, body)], + if [params] does not contain a [Pparam_val _], [body] must be + [Pfunction_cases _]. *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] @@ -426,11 +446,11 @@ and expression_desc = | Pexp_tuple of (string option * expression) list (** [Pexp_tuple(el)] represents - [(E1, ..., En)] - when [el] is [(None, E1);...;(None, En)] + when [el] is [(None, E1); ...; (None, En)] - [(~L1:E1, ..., ~Ln:En)] - when [el] is [(Some L1, E1);...;(Some Ln, En)] - - A mix, e.g.: - [(~L1:E1, E2)] when [el] is [(Some L1, E1); (None, E2)] + when [el] is [(Some L1, E1); ...; (Some Ln, En)] + - A mix, e.g., [(~L1:E1, E2)] + when [el] is [(Some L1, E1); (None, E2)] Invariant: [n >= 2] *) @@ -520,11 +540,8 @@ and expression_desc = | Pexp_object of class_structure (** [object ... end] *) | Pexp_newtype of string loc * jkind_annotation option * expression (** [fun (type t) -> E] or [fun (type t : k) -> E] *) - | Pexp_pack of module_expr - (** [(module ME)]. - - [(module ME : S)] is represented as - [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) + | Pexp_pack of module_expr * package_type option + (** [(module ME)] or [(module ME : S)]. *) | Pexp_open of open_declaration * expression (** - [M.(E)] - [let open M in E] diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index 244706f45..151daeddf 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -81,13 +81,46 @@ let last_is c str = let first_is_in cs str = str <> "" && List.mem str.[0] cs +(** The OCaml grammar generates [longident]s from five different rules: + - module longident (a sequence of uppercase identifiers [A.B.C]) + - constructor longident, either + - a module [longident] + - [[]], [()], [true], [false] + - an optional module [longident] followed by [(::)] ([A.B.(::)]) + - class longident, an optional module [longident] followed by a lowercase + identifier. + - value longident, an optional module [longident] followed by either: + - a lowercase identifier ([A.x]) + - an operator (and in particular the [mod] keyword), ([A.(+), B.(mod)]) + - type [longident]: a tree of applications and projections of + uppercase identifiers followed by a projection ending with + a lowercase identifier (for ordinary types), or any identifier + (for module types) (e.g [A.B(C.D(E.F).K)(G).X.Y.t]) +All these [longident]s share a common core and optionally add some extensions. +Unfortunately, these extensions intersect while having different escaping +and parentheses rules depending on the kind of [longident]: + - [true] or [false] can be either constructor [longident]s, + or value, type or class [longident]s using the raw identifier syntax. + - [mod] can be either an operator value [longident], or a class or type + [longident] using the raw identifier syntax. +Thus in order to print correctly [longident]s, we need to keep track of their +kind using the context in which they appear. +*) +type longindent_kind = + | Constr (** variant constructors *) + | Type (** core types, module types, class types, and classes *) + | Other (** values and modules *) + (* 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 +let needs_parens ~kind txt = + match kind with + | Type -> false + | Constr | Other -> + 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 *) @@ -110,38 +143,99 @@ let tyvar_of_name s = end of the file to include [jkind_annotation]. *) module Doc_internal = 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 = + in case it is a keyword, or parenthesis when it is an infix or prefix + operator. *) + let ident_of_name ~kind ppf txt = let format : (_, _, _) format = - if Lexer.is_keyword txt then "\\#%s" - else if not (needs_parens txt) then "%s" + if Lexer.is_keyword txt then begin + match kind, txt with + | Constr, ("true"|"false") -> "%s" + | _ -> "\\#%s" + end + else if not (needs_parens ~kind 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 + let protect_longident ~kind ppf print_longident longprefix txt = + if not (needs_parens ~kind txt) then Format_doc.fprintf ppf "%a.%a" print_longident longprefix - ident_of_name txt + (ident_of_name ~kind) 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 + let rec any_longident ~kind f = function + | Lident s -> ident_of_name ~kind f s + | Ldot(y,s) -> + protect_longident ~kind f (any_longident ~kind:Other) y.txt s.txt | Lapply (y,s) -> - Format_doc.fprintf f "%a(%a)" longident y longident s + Format_doc.fprintf f "%a(%a)" + (any_longident ~kind:Other) y.txt + (any_longident ~kind:Other) s.txt + + let value_longident ppf l = any_longident ~kind:Other ppf l + let longident = value_longident + let constr ppf l = any_longident ~kind:Constr ppf l + let type_longident ppf l = any_longident ~kind:Type ppf l 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 ?(is_constr=false) l = + let kind= if is_constr then Constr else Other in + Format_doc.doc_printer (any_longident ~kind) 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 ~is_constr:true 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_internal.longident ppf l -let ident_of_name ppf i = Format_doc.compat Doc_internal.ident_of_name ppf i +let value_longident ppf l = Format_doc.compat Doc_internal.value_longident ppf l +let type_longident ppf l = Format_doc.compat Doc_internal.type_longident ppf l + +let ident_of_name ppf i = + Format_doc.compat (Doc_internal.ident_of_name ~kind:Other) ppf i + +let constr ppf l = Format_doc.compat Doc_internal.constr ppf l let is_curry_attr attr = attr.attr_name.txt = Builtin_attributes.curry_attr_name @@ -166,6 +260,7 @@ let type_variance = function | NoVariance -> "" | Covariant -> "+" | Contravariant -> "-" + | Bivariant -> "+-" let type_injectivity = function | NoInjectivity -> "" @@ -183,10 +278,10 @@ type construct = 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 "()"; _},None) -> `tuple + | Pexp_construct ( {txt= Lident "true"; _},None) -> `btrue + | Pexp_construct ( {txt= Lident "false"; _},None) -> `bfalse + | Pexp_construct ( {txt= Lident "[]";_},None) -> `nil | Pexp_construct ( {txt= Lident"::";_},Some _) -> let rec loop exp acc = match exp with | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); @@ -194,7 +289,7 @@ let view_expr x = (List.rev acc,true) | {pexp_desc= Pexp_construct ({txt=Lident "::";_}, - Some ({pexp_desc= Pexp_tuple([None, e1;None, e2]); + Some ({pexp_desc= Pexp_tuple([None, e1; None, e2]); pexp_attributes = []})); pexp_attributes = []} -> @@ -265,9 +360,10 @@ 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 longident_loc f x = pp f "%a" longident x.txt +let with_loc pr ppf x = pr ppf x.txt +let value_longident_loc = with_loc value_longident -let constant f = function +let constant_desc f = function | Pconst_char i -> pp f "%C" i | Pconst_untagged_char i -> @@ -296,6 +392,8 @@ let bool f = function | false -> pp f "false" | true -> pp f "true" +let constant f const = constant_desc f const.pconst_desc + (* trailing space*) let mutable_flag f = function | Immutable -> () @@ -325,7 +423,6 @@ 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_internal.tyvar ppf v let string_loc ppf x = fprintf ppf "%s" x.txt @@ -405,7 +502,7 @@ and type_with_label ctxt f (label, c, mode) = and jkind_annotation ?(nested = false) ctxt f k = match k.pjka_desc with | Pjk_default -> pp f "_" | Pjk_abbreviation (s, sa) -> - longident_loc f s; + value_longident_loc f s; List.iter (fun a -> pp f " %s" a.Location.txt) sa | Pjk_mod (t, modes) -> begin match modes with @@ -499,6 +596,13 @@ and core_type ctxt f x = pp f "@[(type@ :@ %a)@]" (jkind_annotation reset_ctxt) jkind | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x +and tuple_type_component ctxt f (label, ty) = + begin match label with + | None -> () + | Some s -> pp f "%s:" s + end; + core_type1 ctxt f ty + and core_type1 ctxt f x = if x.ptyp_attributes <> [] then core_type ctxt f x else @@ -506,7 +610,7 @@ and core_type1 ctxt f x = | Ptyp_any jkind -> tyvar_loc_option_jkind f (None, jkind) | Ptyp_var (s, jkind) -> (tyvar_jkind tyvar) f (s, jkind) | Ptyp_tuple tl -> - pp f "(%a)" (list (labeled_core_type1 ctxt) ~sep:"@;*@;") tl + pp f "(%a)" (list (tuple_type_component ctxt) ~sep:"@;*@;") tl | Ptyp_unboxed_tuple l -> core_type1_labeled_tuple ctxt f ~unboxed:true l | Ptyp_constr (li, l) -> @@ -515,7 +619,7 @@ and core_type1 ctxt f x = |[] -> () |[x]-> pp f "%a@;" (core_type1 ctxt) x | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) - l longident_loc li + l (with_loc type_longident) li | Ptyp_variant (l, closed, low) -> let first_is_inherit = match l with | {Parsetree.prf_desc = Rinherit _}::_ -> true @@ -569,17 +673,11 @@ and core_type1 ctxt f x = | 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) + (with_loc type_longident) li + | Ptyp_package pck_ty -> + pp f "@[(module@ %a)@]" (package_type ctxt) pck_ty | Ptyp_open(li, ct) -> - pp f "@[%a.(%a)@]" longident_loc li (core_type ctxt) ct + pp f "@[%a.(%a)@]" value_longident_loc li (core_type ctxt) ct | Ptyp_quote t -> pp f "@[<[%a]>@]" (core_type ctxt) t | Ptyp_splice t -> @@ -613,14 +711,7 @@ and tyvar_loc_option f str = tyvar_option f (Option.map Location.get_txt str) and core_type1_labeled_tuple ctxt f ~unboxed tl = pp f "%s(%a)" (if unboxed then "#" else "") - (list (labeled_core_type1 ctxt) ~sep:"@;*@;") tl - -and labeled_core_type1 ctxt f (label, ty) = - begin match label with - | None -> () - | Some s -> pp f "%s:" s - end; - core_type1 ctxt f ty + (list (tuple_type_component ctxt) ~sep:"@;*@;") tl and return_type ctxt f (x, m) = let is_curry, ptyp_attributes = split_out_curry_attr x.ptyp_attributes in @@ -633,6 +724,17 @@ and core_type2_with_optional_modes ctxt f (ty, modes) = | [] -> core_type ctxt f ty | _ :: _ -> pp f "%a%a" (core_type2 ctxt) ty optional_at_modes modes +and package_type ctxt f ptyp = + let aux f (s, ct) = + pp f "type %a@ =@ %a" (with_loc type_longident) s (core_type ctxt) ct + in + match ptyp.ppt_cstrs with + | [] -> with_loc type_longident f ptyp.ppt_path + | _ -> + pp f "%a@ with@ %a" + (with_loc type_longident) ptyp.ppt_path + (list aux ~sep:"@ and@ ") ptyp.ppt_cstrs + (********************pattern********************) (* be cautious when use [pattern], [pattern1] is preferred *) and pattern ctxt f x = @@ -658,53 +760,52 @@ and pattern_or ctxt f x = pp f "@[%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = - let rec pattern_list_helper f p = match p with - | {ppat_desc = - Ppat_construct - ({ txt = Lident("::") ;_}, - Some ([], inner_pat)); - ppat_attributes = []} -> - begin match inner_pat.ppat_desc with - | Ppat_tuple([None, pat1; None, pat2], Closed) -> - pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) - | _ -> pattern1 ctxt f p - end - | _ -> 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) -> + | Ppat_construct ({txt=Lident("::");_}, Some ([], + {ppat_desc = Ppat_tuple([None, pat1; None, pat2], Closed);_})) -> + (* Right associative*) + pp f "%a::%a" (simple_pattern ctxt) pat1 (pattern1 ctxt) pat2 + | Ppat_construct (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:"@ " name_loc_jkind) vl - (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) + (match po with + | Some ([], x) -> + (* [true] and [false] are handled above *) + pp f "%a@;%a" value_longident_loc li (simple_pattern ctxt) x + | Some (vl, x) -> + pp f "%a@ (type %a)@;%a" value_longident_loc li + (list ~sep:"@ " name_loc_jkind) vl + (simple_pattern ctxt) x + | None -> pp f "%a" value_longident_loc li) | _ -> simple_pattern ctxt f x -and labeled_pattern1 ctxt (f:Format.formatter) (label, x) : unit = +and tuple_pattern_component ctxt (f:Format.formatter) (label, x) : unit = let simple_name = match x with | {ppat_desc = Ppat_var { txt=s; _ }; ppat_attributes = []; _} -> Some s | _ -> None in match label, simple_name with - | None, _ -> - pattern1 ctxt f x + (* Labeled component can be represented with pun *) | Some lbl, Some simple_name when String.equal simple_name lbl -> pp f "~%s" lbl - | Some lbl, _ -> - pp f "~%s:" lbl; - pattern1 ctxt f x + (* Labeled component general case *) + | Some lbl, _ -> pp f "~%s:%a" lbl (pattern1 ctxt) x + (* Unlabeled component *) + | None, _ -> pattern1 ctxt f x + +and tuple_pattern ctxt f ~unboxed l closed = + let closed_flag ppf = function + | Closed -> () + | Open -> pp ppf ",@;.." + in + pp f "@[<1>%s(%a%a)@]" + (if unboxed then "#" else "") + (list ~sep:",@;" (tuple_pattern_component ctxt)) l + closed_flag closed and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = if x.ppat_attributes <> [] then pattern ctxt f x @@ -728,17 +829,17 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_unpack { txt = Some s } -> pp f "(module@ %s)@ " s | Ppat_type li -> - pp f "#%a" longident_loc li + pp f "#%a" (with_loc type_longident) li | Ppat_record (l, closed) -> record_pattern ctxt f ~unboxed:false l closed | Ppat_record_unboxed_product (l, closed) -> record_pattern ctxt f ~unboxed:true l closed | Ppat_unboxed_unit -> pp f "#()" | Ppat_unboxed_bool b -> pp f "#%a" bool b - | Ppat_tuple (l, closed) -> - labeled_tuple_pattern ctxt f ~unboxed:false l closed - | Ppat_unboxed_tuple (l, closed) -> - labeled_tuple_pattern ctxt f ~unboxed:true l closed + | Ppat_tuple (l, c) -> + tuple_pattern ctxt f ~unboxed:false l c + | Ppat_unboxed_tuple (l, c) -> + tuple_pattern ctxt f ~unboxed:true l c | 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 @@ -748,6 +849,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 = @@ -756,7 +859,7 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false");_}), None) -> false | _ -> true in - pp f "@[<2>%a.%a @]" longident_loc lid + pp f "@[<2>%a.%a @]" value_longident_loc lid (paren with_paren @@ pattern1 ctxt) p | _ -> paren true (pattern ctxt) f x @@ -767,9 +870,9 @@ and record_pattern ctxt f ~unboxed l closed = {ppat_desc=Ppat_var {txt;_}; ppat_attributes=[]; _}) when s = txt -> - pp f "@[<2>%a@]" longident_loc li + pp f "@[<2>%a@]" value_longident_loc li | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + pp f "@[<2>%a@;=@;%a@]" value_longident_loc li (pattern1 ctxt) p in let hash = if unboxed then "#" else "" in match closed with @@ -778,16 +881,6 @@ and record_pattern ctxt f ~unboxed l closed = | Open -> pp f "@[<2>%s{@;%a;_}@]" hash (list longident_x_pattern ~sep:";@;") l -and labeled_tuple_pattern ctxt f ~unboxed l closed = - let closed_flag ppf = function - | Closed -> () - | Open -> pp ppf ",@;.." - in - pp f "@[<1>%s(%a%a)@]" - (if unboxed then "#" else "") - (list ~sep:",@;" (labeled_pattern1 ctxt)) l - closed_flag closed - (** for special treatment of modes in labeled expressions *) and pattern2 ctxt f p = match p.ppat_desc with @@ -847,7 +940,7 @@ and sugar_expr ctxt f e = rem_args = let print_path ppf = function | None -> () - | Some m -> pp ppf ".%a" longident m in + | Some m -> pp ppf ".%a" value_longident m in match assign, rem_args with | false, [] -> pp f "@[%a%a%s%a%s@]" @@ -862,7 +955,8 @@ and sugar_expr ctxt f e = 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 + | Ldot ({txt=path;_}, {txt=("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 @@ -870,18 +964,20 @@ and sugar_expr ctxt f e = print ".(" "" ")" (expression ctxt) [i] rest | Lident "String", i :: rest -> print ".[" "" "]" (expression ctxt) [i] rest - | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + | Ldot ({txt=Lident "Bigarray";_}, {txt="Array1";_}), i1 :: rest -> print ".{" "," "}" (simple_expr ctxt) [i1] rest - | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + | Ldot ({txt=Lident "Bigarray";_}, {txt="Array2";_}), + i1 :: i2 :: rest -> print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest - | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + | Ldot ({txt=Lident "Bigarray";_}, {txt="Array3";_}), + i1 :: i2 :: i3 :: rest -> print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest - | Ldot (Lident "Bigarray", "Genarray"), + | Ldot ({txt=Lident "Bigarray";_}, {txt="Genarray";_}), {pexp_desc = Pexp_array (_, indexes); pexp_attributes = []} :: rest -> print ".{" "," "}" (simple_expr ctxt) indexes rest | _ -> false end - | (Lident s | Ldot(_,s)) , a :: i :: rest + | (Lident s | Ldot(_,{txt=s;_})) , a :: i :: rest when first_is '.' s -> (* extract operator: assignment operators end with [right_bracket ^ "<-"], @@ -903,7 +999,7 @@ and sugar_expr ctxt f e = | '}' -> '{', "}" | _ -> assert false in let path_prefix = match id with - | Ldot(m,_) -> Some m + | Ldot(m,_) -> Some m.txt | _ -> None in let left = String.sub s 0 (1+String.index s left) in print_indexop a path_prefix assign left ";" right @@ -1025,12 +1121,12 @@ and expression ctxt f x = (match view_expr x with | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" | `normal -> - pp f "@[<2>%a@;%a@]" longident_loc li + pp f "@[<2>%a@;%a@]" (with_loc constr) 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 + (simple_expr ctxt) e1 value_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 @@ -1049,7 +1145,7 @@ and expression ctxt f x = pp f "@[%a@]" (list (expression (under_semi ctxt)) ~sep:";@;") lst | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; + pp f "@[new@ %a@]" (with_loc type_longident) li; | Pexp_setvar (s, e) -> pp f "@[%a@ <-@ %a@]" ident_of_name s.txt (expression ctxt) e | Pexp_override l -> (* FIXME *) @@ -1114,9 +1210,9 @@ 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 + pp f "@[%a.%a@]" (simple_expr ctxt) e value_longident_loc li | Pexp_unboxed_field (e, li) -> - pp f "@[%a.#%a@]" (simple_expr ctxt) e longident_loc li + pp f "@[%a.#%a@]" (simple_expr ctxt) e value_longident_loc li | Pexp_send (e, s) -> pp f "@[%a#%a@]" (simple_expr ctxt) e ident_of_name s.txt @@ -1134,16 +1230,18 @@ and simple_expr ctxt f x = | `list xs -> pp f "@[[%a]@]" (list (expression (under_semi ctxt)) ~sep:";@;") xs - | `simple x -> longident f x + | `simple x -> constr f x | _ -> assert false) | Pexp_ident li -> - longident_loc f li + value_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_pack (me, opty) -> + pp f "(module@;%a" (module_expr ctxt) me; + Option.iter (pp f " :@ %a" (package_type ctxt)) opty; + pp f ")" | Pexp_unboxed_unit -> pp f "#()" | Pexp_unboxed_bool b -> pp f "#%a" bool b | Pexp_tuple l -> @@ -1270,7 +1368,7 @@ and class_type ctxt f x = (fun f l -> match l with | [] -> () | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l - longident_loc li + (with_loc type_longident) li (attributes ctxt) x.pcty_attributes | Pcty_arrow (l, co, cl) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) @@ -1281,7 +1379,7 @@ and class_type ctxt f x = 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 + (override o.popen_override) value_longident_loc o.popen_expr (class_type ctxt) e (* [class type a = object end] *) @@ -1403,7 +1501,7 @@ and class_expr ctxt f x = (fun f l-> if l <>[] then pp f "[%a]@ " (list (core_type ctxt) ~sep:",") l) l - longident_loc li + (with_loc type_longident) li | Pcl_constraint (ce, ct) -> pp f "(%a@ :@ %a)" (class_expr ctxt) ce @@ -1411,7 +1509,7 @@ and class_expr ctxt f x = | 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 + (override o.popen_override) value_longident_loc o.popen_expr (class_expr ctxt) e and include_ : 'a. ctxt -> formatter -> @@ -1467,7 +1565,7 @@ and module_type ctxt f x = (module_type1_with_optional_modes ctxt) (mt1, mm1) (module_type_with_optional_modes ctxt) (mt2, mm2) | Some name -> - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name + pp f "@[(%s@ :@ %a)@ ->@ %a@]" name (module_type_with_optional_modes ctxt) (mt1, mm1) (module_type_with_optional_modes ctxt) (mt2, mm2) end @@ -1479,40 +1577,44 @@ and module_type ctxt f x = | Pmty_strengthen (mty, mod_id) -> pp f "@[%a@ with@ %a@]" (module_type1 ctxt) mty - longident_loc mod_id + (with_loc type_longident) mod_id | _ -> 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 ls - longident_loc li (type_declaration ctxt) td + (with_loc type_longident) li (type_declaration ctxt) td | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; + pp f "module %a =@ %a" value_longident_loc li value_longident_loc li2; | Pwith_modtype (li, mty) -> - pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty; + pp f "module type %a =@ %a" + (with_loc type_longident) li + (module_type ctxt) mty; | Pwith_jkind (li, jd) -> - pp f "kind_ %a =@ %a" longident_loc li (jkind_declaration ctxt) jd; + pp f "kind_ %a =@ %a" value_longident_loc li (jkind_declaration ctxt) jd; | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> pp f "type@ %a %a :=@ %a" type_params ls - longident_loc li + (with_loc type_longident) li (type_declaration ctxt) td | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 + pp f "module %a :=@ %a" value_longident_loc li value_longident_loc li2 | Pwith_modtypesubst (li, mty) -> - pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty; + pp f "module type %a :=@ %a" + (with_loc type_longident) li + (module_type ctxt) mty; | Pwith_jkindsubst (li, jd) -> - pp f "kind_ %a :=@ %a" longident_loc li (jkind_declaration ctxt) jd; + pp f "kind_ %a :=@ %a" value_longident_loc li (jkind_declaration ctxt) jd; 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; + pp f "%a" (with_loc type_longident) li; | Pmty_alias li -> - pp f "(module %a)" longident_loc li; + pp f "(module %a)" (with_loc type_longident) li; | Pmty_signature {psg_items; psg_modalities} -> pp f "@[@[sig%a@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) optional_space_atat_modalities psg_modalities @@ -1571,7 +1673,7 @@ and signature_item ctxt f x : unit = pmty_attributes=[]; _}; _} as pmd) -> pp f "@[module@ %s@ =@ %a%a@]%a" (Option.value pmd.pmd_name.txt ~default:"_") - longident_loc alias + value_longident_loc alias optional_space_atat_modalities pmd.pmd_modalities (item_attributes ctxt) pmd.pmd_attributes | Psig_module pmd -> @@ -1582,18 +1684,18 @@ and signature_item ctxt f x : unit = (item_attributes ctxt) pmd.pmd_attributes | Psig_modsubst pms -> pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt - longident_loc pms.pms_manifest + value_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 + value_longident_loc od.popen_expr (item_attributes ctxt) od.popen_attributes | Psig_include (incl, modalities) -> sig_include ctxt f incl modalities | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt + pp f "@[module@ type@ %a%a@]%a" + ident_of_name s.txt (fun f md -> match md with | None -> () | Some mt -> @@ -1656,7 +1758,7 @@ and module_expr ctxt f x = (module_type_with_optional_modes ctxt) (mt, mm) end | Pmod_ident (li) -> - pp f "%a" longident_loc li; + pp f "%a" value_longident_loc li; | Pmod_functor (Unit, me) -> pp f "functor ()@;->@;%a" (module_expr ctxt) me | Pmod_functor (Named (s, mt, mm), me) -> @@ -1716,7 +1818,7 @@ and pp_print_params_then_equals ctxt f x = and poly_type ctxt core_type f (vars, typ) = pp f "type@;%a.@;%a" - (list ~sep:"@;" (tyvar_loc_jkind pp_print_string)) vars + (list ~sep:"@;" (tyvar_loc_jkind ident_of_name)) vars (core_type ctxt) typ and poly_type_with_optional_modes ctxt f (vars, typ, modes) = @@ -1889,8 +1991,8 @@ and structure_item ctxt f x = (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 + pp f "@[module@ type@ %a%a@]%a" + ident_of_name s.txt (fun f md -> match md with | None -> () | Some mt -> @@ -2118,7 +2220,7 @@ and type_extension ctxt f x = in pp f "@[<2>type %a%a += %a@ %a@]%a" type_params x.ptyext_params - longident_loc x.ptyext_path + (with_loc type_longident) x.ptyext_path private_flag x.ptyext_private (* Cf: #7200 *) (list ~sep:"" extension_constructor) x.ptyext_constructors @@ -2169,7 +2271,7 @@ and extension_constructor ctxt f x = (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 + (with_loc constr) li (attributes ctxt) x.pext_attributes and case_list ctxt f l : unit = @@ -2198,30 +2300,30 @@ and label_x_expression_param ctxt f (l,e) = else pp f "~%a:%a" ident_of_name lbl (simple_expr ctxt) e -and tuple_component ctxt f (l,e) = +and tuple_expr_component ctxt f (l,e) = let simple_name = match e with - | {pexp_desc=Pexp_ident {txt=Lident l;_}; - pexp_attributes=[]} -> Some l + | {pexp_desc=Pexp_ident {txt=Lident l;_}; pexp_attributes=[]} -> Some l | _ -> None in match (simple_name, l) with (* Labeled component can be represented with pun *) - | Some simple_name, Some lbl when String.equal simple_name lbl -> pp f "~%s" lbl + | Some simple_name, Some lbl when String.equal simple_name lbl -> + pp f "~%s" lbl (* Labeled component general case *) | _, Some lbl -> pp f "~%s:%a" lbl (simple_expr ctxt) e (* Unlabeled component *) - | _, None -> expression2 ctxt f e (* level 2*) + | _, None -> expression2 ctxt f 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_ident (li) -> pp f "@ %a" value_longident li | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) and block_access ctxt f = function | Baccess_field li -> - pp f ".%a" longident_loc li + pp f ".%a" value_longident_loc li | Baccess_block (mut, index) -> let s = match mut with @@ -2232,7 +2334,7 @@ and block_access ctxt f = function and unboxed_access f = function | Uaccess_unboxed_field li -> - pp f ".#%a" longident_loc li + pp f ".#%a" value_longident_loc li and comprehension_expr ctxt f cexp = let punct, comp = match cexp with @@ -2327,16 +2429,16 @@ and function_params_then_body ctxt f params constraint_ body ~delimiter = and labeled_tuple_expr ctxt f ~unboxed x = pp f "@[%s(%a)@]" (if unboxed then "#" else "") - (list (tuple_component ctxt) ~sep:",@;") x + (list (tuple_expr_component ctxt) ~sep:",@;") x and record_expr ctxt f ~unboxed 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 + pexp_attributes=[]; _} when Longident.same li.txt txt -> + pp f "@[%a@]" value_longident_loc li | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + pp f "@[%a@;=@;%a@]" value_longident_loc li (simple_expr ctxt) e in let hash = if unboxed then "#" else "" in pp f "@[@[%s{@;%a%a@]@;}@]"(* "@[%s{%a%a}@]" *) @@ -2401,7 +2503,7 @@ let top_phrase f x = pp f ";;"; pp_print_newline f () -let longident = print_with_maximal_extensions longident +let longident = print_with_maximal_extensions value_longident let core_type = print_reset_with_maximal_extensions core_type let pattern = print_reset_with_maximal_extensions pattern let signature = print_reset_with_maximal_extensions signature diff --git a/src/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli index f6b8f46ac..3f6003887 100644 --- a/src/ocaml/parsing/pprintast.mli +++ b/src/ocaml/parsing/pprintast.mli @@ -24,6 +24,8 @@ type space_formatter = (unit, Format.formatter, unit) format val longident : Format.formatter -> Longident.t -> unit +val constr : Format.formatter -> Longident.t -> unit + val expression : Format.formatter -> Parsetree.expression -> unit val string_of_expression : Parsetree.expression -> string @@ -70,8 +72,13 @@ val mode : Format.formatter -> Parsetree.mode Location.loc -> unit (** {!Format_doc} functions for error messages *) module Doc:sig val longident: Longident.t Format_doc.printer + val constr: Longident.t Format_doc.printer val tyvar: string Format_doc.printer val jkind_annotation: Parsetree.jkind_annotation 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 (* merlin *) diff --git a/src/ocaml/parsing/printast.ml b/src/ocaml/parsing/printast.ml index f215c185a..7878e3175 100644 --- a/src/ocaml/parsing/printast.ml +++ b/src/ocaml/parsing/printast.ml @@ -40,9 +40,9 @@ let fmt_location f loc = 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.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y.txt s.txt | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + fprintf f "%a(%a)" fmt_longident_aux y.txt fmt_longident_aux z.txt let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x @@ -59,27 +59,10 @@ 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_unboxed_integer (i,m) -> fprintf f "PConst_unboxed_int (%s,%c)" i m - | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c) - | Pconst_untagged_char (c) -> - fprintf f "PConst_untagged_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 - | Pconst_unboxed_float (s,m) -> - fprintf f "PConst_unboxed_float (%s,%a)" s fmt_char_option m - let fmt_bool f x = match x with - | false -> fprintf f "false"; - | true -> fprintf f "true"; -;; - + | false -> fprintf f "false" + | true -> fprintf f "true" let fmt_mutable_flag f x = match x with | Immutable -> fprintf f "Immutable" @@ -119,6 +102,23 @@ 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_unboxed_integer (j,m) -> line i f "PConst_unboxed_int (%s,%c)\n" j m + | Pconst_char c -> line i f "PConst_char %02x\n" (Char.code c) + | Pconst_untagged_char c -> + line i f "PConst_untagged_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 + | Pconst_unboxed_float (s,m) -> + line i f "PConst_unboxed_float (%s,%a)\n" s fmt_char_option m + let list i f ppf l = match l with | [] -> line i ppf "[]\n" @@ -225,9 +225,9 @@ let rec core_type i ppf x = line i ppf "Ptyp_poly\n"; list i typevar ppf 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_package ptyp -> + line i ppf "Ptyp_package\n"; + package_type i ppf ptyp; | Ptyp_open (mod_ident, t) -> line i ppf "Ptyp_open \"%a\"\n" fmt_longident_loc mod_ident; core_type i ppf t @@ -258,6 +258,12 @@ and typevar i ppf (s, jkind) = and reprvar i ppf s = line i ppf "reprvar: %s\n" s.txt +and package_type i ppf ptyp = + let i = i + 1 in + line i ppf "package_type %a\n" fmt_longident_loc ptyp.ppt_path; + list i package_with ppf ptyp.ppt_cstrs; + attributes i ppf ptyp.ppt_attrs + and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident_loc s; core_type i ppf t @@ -272,14 +278,18 @@ 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_unboxed_unit -> line i ppf "Ppat_unboxed_unit\n"; | Ppat_unboxed_bool b -> line i ppf "Ppat_unboxed_bool %a\n" fmt_bool b; | Ppat_tuple (l, c) -> line i ppf "Ppat_tuple\n %a\n" fmt_closed_flag c; - list i (labeled_tuple_element pattern) ppf l + list i (labeled_tuple_element pattern) ppf l; | Ppat_unboxed_tuple (l, c) -> line i ppf "Ppat_unboxed_tuple %a\n" fmt_closed_flag c; list i (labeled_tuple_element pattern) ppf l @@ -326,6 +336,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 @@ -339,7 +353,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 (mf, rf, l, e) -> line i ppf "Pexp_let %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf; list i value_binding ppf l; @@ -467,9 +483,10 @@ and expression i ppf x = line i ppf "Pexp_newtype \"%s\"\n" s.txt; jkind_annotation_opt i ppf jkind; expression i ppf e - | Pexp_pack me -> + | Pexp_pack (me, optyp) -> line i ppf "Pexp_pack\n"; - module_expr i ppf me + module_expr i ppf me; + option i package_type ppf optyp | Pexp_open (o, e) -> line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override; module_expr i ppf o.popen_expr; diff --git a/src/ocaml/parsing/printast.mli b/src/ocaml/parsing/printast.mli index 182a31e78..d8fe83f2b 100644 --- a/src/ocaml/parsing/printast.mli +++ b/src/ocaml/parsing/printast.mli @@ -26,10 +26,10 @@ open Format val interface : formatter -> signature -> unit val implementation : formatter -> structure_item list -> unit val top_phrase : formatter -> toplevel_phrase -> unit -val constant: formatter -> constant -> unit +val constant: int -> formatter -> constant -> unit -val expression: int -> formatter -> expression -> unit val pattern: int -> formatter -> pattern -> unit +val expression: int -> formatter -> expression -> unit val structure: int -> formatter -> structure -> unit val payload: int -> formatter -> payload -> unit val core_type: int -> formatter -> core_type -> unit diff --git a/src/ocaml/typing/btype.ml b/src/ocaml/typing/btype.ml index e442c8165..add3b82ed 100644 --- a/src/ocaml/typing/btype.ml +++ b/src/ocaml/typing/btype.ml @@ -113,14 +113,67 @@ module TypePairs = struct 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 jkind = newgenty (Tvar { name; jkind }) let newgenstub ~scope jkind = @@ -136,6 +189,8 @@ 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_Tpoly ty = match get_desc ty with Tpoly _ -> 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 = @@ -300,8 +355,8 @@ let fold_type_expr f init ty = | Tarrow (_, ty1, ty2, _) -> let result = f init ty1 in f result ty2 - | Ttuple l -> List.fold_left f init (List.map snd l) - | Tunboxed_tuple l -> List.fold_left f init (List.map snd l) + | Ttuple l -> List.fold_left (fun acc (_, t) -> f acc t) init l + | Tunboxed_tuple l -> List.fold_left (fun acc (_, t) -> f acc t) init l | Tconstr (_, l, _) -> List.fold_left f init l | Tobject(ty, {contents = Some (_, p)}) -> let result = f init ty in @@ -325,8 +380,8 @@ let fold_type_expr f init ty = List.fold_left f result tyl | Trepr (ty, _sort_vars) -> f init ty - | Tpackage (_, fl) -> - List.fold_left (fun result (_n, ty) -> f result ty) init fl + | Tpackage pack -> + List.fold_left (fun result (_n, ty) -> f result ty) init pack.pack_cstrs | Tof_kind _ -> init let iter_type_expr f ty = @@ -490,7 +545,7 @@ let type_iterators mark = match get_desc ty with Tconstr (p, _, _) | Tobject (_, {contents=Some (p, _)}) - | Tpackage (p, _) -> + | Tpackage {pack_path = p} -> it.it_path p | Tvariant row -> Option.iter (fun (p,_) -> it.it_path p) (row_name row) @@ -566,7 +621,9 @@ let rec copy_type_desc ?(keep_names=false) f = function Tpoly (f ty, tyl) | Trepr (ty, sort_vars) -> Trepr (f ty, sort_vars) - | Tpackage (p, fl) -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl) + | Tpackage pack -> + Tpackage {pack with + pack_cstrs = List.map (fun (n, ty) -> (n, f ty)) pack.pack_cstrs} | Tof_kind jk -> Tof_kind jk (* TODO: rename to [module Copy_scope] *) @@ -842,17 +899,6 @@ let tpoly_get_poly ty = let tpoly_get_mono ty = match get_desc ty with | Tpoly(ty, []) -> ty - | _ -> assert false - - (**********) - (* Misc *) - (**********) - -(**** Type information getter ****) - -let cstr_type_path cstr = - match get_desc cstr.cstr_res with - | Tconstr (p, _, _) -> p | _ -> assert false (************) @@ -2439,6 +2485,13 @@ module Jkind0 = struct } ~annotation:None ~why:(Value_creation why) + let for_effect_arg ident = + let why : Jkind_intf.History.value_creation_reason = + Type_argument + { parent_path = Path.Pident ident; position = 1; arity = 1 } + in + Builtin.value ~why + let for_variant_with_null_result path param = let why : Jkind_intf.History.value_or_null_creation_reason = Type_argument diff --git a/src/ocaml/typing/btype.mli b/src/ocaml/typing/btype.mli index 484a20071..caff16961 100644 --- a/src/ocaml/typing/btype.mli +++ b/src/ocaml/typing/btype.mli @@ -64,6 +64,19 @@ val generic_level: int 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 -> jkind_lr -> type_expr @@ -85,10 +98,10 @@ val is_Tvar: type_expr -> bool val is_Tunivar: type_expr -> bool val is_Tconstr: type_expr -> bool val is_Tpoly: 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 (**** polymorphic variants ****) @@ -320,10 +333,6 @@ 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 - (* These modules exists here to resolve a dependency cycle: [Subst], [Predef], [Datarepr], and [Env] must not depend on [Jkind]. The portions intended for use outside of those modules are re-exported as [Jkind.With_bounds] and @@ -710,6 +719,8 @@ module Jkind0 : sig val for_or_null_argument : Ident.t -> 'd jkind val for_variant_with_null_result : Path.t -> type_expr -> jkind_l + val for_effect_arg : Ident.t -> 'd jkind + (** The jkind of a float. *) val for_float : Ident.t -> jkind_l diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli index 4793d0cba..72f1f1480 100644 --- a/src/ocaml/typing/cmt_format.mli +++ b/src/ocaml/typing/cmt_format.mli @@ -55,6 +55,8 @@ type cmt_infos = { cmt_declaration_dependencies : (dependency_kind * Uid.t * Uid.t) list; cmt_comments : (string * Location.t) list; cmt_args : string array; + (** {!Sys.argv} from the compiler invocation which created the file. + [Sys.argv.(0)] is rewritten using [BUILD_PATH_PREFIX_MAP]. *) cmt_sourcefile : string option; cmt_builddir : string; cmt_loadpath : Load_path.paths; diff --git a/src/ocaml/typing/ctype.ml b/src/ocaml/typing/ctype.ml index 51de2ab78..6a75383fe 100644 --- a/src/ocaml/typing/ctype.ml +++ b/src/ocaml/typing/ctype.ml @@ -25,6 +25,7 @@ end open Misc open Asttypes open Types +open Data_types open Btype open Errortrace open Mode @@ -33,16 +34,6 @@ open Local_store let debug_ikind_crossing_mismatch = Sys.getenv_opt "OXCAML_IKIND_CROSSING_MISMATCH" <> None -(* - 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 ============= @@ -153,8 +144,35 @@ exception Cannot_subst exception Cannot_unify_universal_variables +exception Out_of_scope_universal_variable + exception Incompatible +(**** Control tracing of GADT instances *) + +let trace_gadt_instances = ref false +let check_trace_gadt_instances ?(force=false) env = + not !trace_gadt_instances && (force || 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 ?force env f x = + let b = check_trace_gadt_instances ?force env in + Misc.try_finally (fun () -> f x) + ~always:(fun () -> reset_trace_gadt_instances b) + +(**** 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 @@ -198,11 +216,82 @@ 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 +(* [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 = + with_new_pool ~level:!current_level begin fun () -> + let result = wrap_end_def f in + Option.iter (fun g -> g result) before_generalize; + result + end + in + simple_abbrevs := Mnil; + (* Nodes in [pool] were either created by the above calls to [f] + and [before_generalize], 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 ~before_generalize f = + with_local_level_gen + ~begin_def:begin_class_def ~structure:false ~before_generalize f + let mark_toplevel_in_quotations env = let scope = !current_level in (* Create a new scope to make sure we only capture what came before *) @@ -218,7 +307,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 = @@ -229,8 +318,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 () @@ -254,32 +342,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 *) @@ -326,22 +388,22 @@ module Pattern_env : sig type t = private { mutable env : Env.t; equations_scope : int; - allow_recursive_equations : bool; + in_counterexample : bool; is_lpoly : bool; } val make: ?is_lpoly:bool -> Env.t -> equations_scope:int - -> allow_recursive_equations:bool -> t + -> in_counterexample: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; + in_counterexample : bool; is_lpoly : bool; } - let make ?(is_lpoly=false) env ~equations_scope ~allow_recursive_equations = + let make ?(is_lpoly=false) env ~equations_scope ~in_counterexample = { env; equations_scope; - allow_recursive_equations; + in_counterexample; is_lpoly; } let copy ?equations_scope penv = let equations_scope = @@ -352,10 +414,6 @@ end (**** unification mode ****) -type equations_generation = - | Forbidden - | Allowed of { equated_types : TypePairs.t; pattern_stage : Env.stage } - type unification_environment = | Expression of { env : Env.t; @@ -363,7 +421,7 @@ type unification_environment = (* normal unification mode *) | Pattern of { penv : Pattern_env.t; - equations_generation : equations_generation; + equated_types : TypePairs.t; assume_injective : bool; unify_eq_set : TypePairs.t } (* GADT constraint unification mode: @@ -410,18 +468,13 @@ let in_subst_mode = function | Expression {in_subst} -> in_subst | Pattern _ -> false -let can_generate_equations = function - | Expression _ | Pattern { equations_generation = Forbidden } -> false - | Pattern { penv; equations_generation = Allowed { pattern_stage } } -> - Env.stage penv.env >= pattern_stage - (* Can only be called when generate_equations is true. Tracks equations only to improve error messages. *) let record_equation uenv t1 t2 = match uenv with - | Expression _ | Pattern { equations_generation = Forbidden } -> + | Expression _ -> invalid_arg "Ctype.record_equation" - | Pattern { equations_generation = Allowed { equated_types } } -> + | Pattern { equated_types } -> TypePairs.add equated_types (t1, t2) let can_assume_injective = function @@ -431,7 +484,7 @@ let can_assume_injective = function let in_counterexample uenv = match uenv with | Expression _ -> false - | Pattern { penv } -> penv.allow_recursive_equations + | Pattern { penv } -> penv.in_counterexample let allow_recursive_equations uenv = !Clflags.recursive_types || in_counterexample uenv @@ -443,11 +496,6 @@ let without_assume_injective uenv f = | 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 }) - (* In type checking, we only use [decr_stage] when we observe a spliced type. [Env.enter_splice] only fails when the splice would be top-level. Hence, no legitimate errors will ever be raised there and we can omit the [loc]. @@ -532,7 +580,6 @@ let unify_with_decr_stage uenv f = with exn -> Pattern_env.set_env p.penv (incr_stage p.penv.env); raise exn - (* Unification generally must check that the jkinds of the two types being unified agree. However, sometimes we need to delay these jkind checks, and this is tracked by the [jkind_unification_mode] in [lmode]. @@ -734,14 +781,14 @@ exception Non_closed of type_expr * variable_kind the abbreviations for use when displaying the type). [free_vars] accumulates its answer in a monoid-like structure, with - an initial element [zero] and a combining function [add_one], passing + an initial element [init] and a combining function [add_one], passing [add_one] information about whether the variable is a normal type variable or a row variable. [add_one] also received jkind information about [Tvar]s (but not [Tconstr]s that are expanded). It is marked [@inline] so that calls to [add_one] are not indirect. *) -let[@inline] free_vars ~zero ~add_one ?env mark tys = +let[@inline] free_vars ~init ~add_one ?env mark tys = let rec fv ~kind acc ty = if not (try_mark_node mark ty) then acc else match get_desc ty, env with @@ -770,11 +817,15 @@ let[@inline] free_vars ~zero ~add_one ?env mark tys = | _ -> fold_type_expr (fv ~kind) acc ty in - List.fold_left (fv ~kind:Type_variable) zero tys + List.fold_left (fv ~kind:Type_variable) init tys let free_variables ?env ty = let add_one ty _jkind _kind acc = ty :: acc in - with_type_mark (fun mark -> free_vars ~zero:[] ~add_one ?env mark [ty]) + with_type_mark (fun mark -> free_vars ~init:[] ~add_one ?env mark [ty]) + +let free_variables_list ?env tyl = + let add_one ty _jkind _kind acc = ty :: acc in + with_type_mark (fun mark -> free_vars ~init:[] ~add_one ?env mark tyl) let free_non_row_variables_of_list tyl = let add_one ty _jkind kind acc = @@ -782,7 +833,7 @@ let free_non_row_variables_of_list tyl = | Type_variable -> ty :: acc | Row_variable -> acc in - with_type_mark (fun mark -> free_vars ~zero:[] ~add_one mark tyl) + with_type_mark (fun mark -> free_vars ~init:[] ~add_one mark tyl) let free_variable_set_of_list env tys = let add_one ty jkind _kind acc = @@ -791,7 +842,7 @@ let free_variable_set_of_list env tys = | Some _jkind -> TypeSet.add ty acc in with_type_mark (fun mark -> - free_vars ~zero:TypeSet.empty ~add_one ~env mark tys) + free_vars ~init:TypeSet.empty ~add_one ~env mark tys) let exists_free_variable f ty = let exception Exists in @@ -802,12 +853,12 @@ let exists_free_variable f ty = | None -> assert false (* this only happens passing ~env to [free_vars] *) in with_type_mark (fun mark -> - try free_vars ~zero:() ~add_one mark [ty]; false + try free_vars ~init:() ~add_one mark [ty]; false with Exists -> true) let closed_type ?env mark ty = let add_one ty _jkind kind _acc = raise (Non_closed (ty, kind)) in - free_vars ~zero:() ~add_one ?env mark [ty] + free_vars ~init:() ~add_one ?env mark [ty] let closed_type_expr ?env ty = with_type_mark (fun mark -> @@ -981,55 +1032,63 @@ let generalize ty = simple_abbrevs := Mnil; generalize 0 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, Trepr, 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 (fun (_,t) -> generalize_spine t) tyl - | Tunboxed_tuple tyl -> - set_level ty generic_level; - List.iter (fun (_,t) -> generalize_spine t) 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 _ + | Tquote _ + | Tsplice _ + | Tquote_eval _ + | Tof_kind _ -> ty + | ( Tarrow _ | Tpoly _ | Trepr _ | Ttuple _ | Tunboxed_tuple _ | 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) (Jkind.Builtin.any ~why:Dummy_jkind) + 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) + | Trepr (ty', sl) -> + Trepr (copy_rec ty', sl) + | Ttuple tyl -> + Ttuple (List.map (fun (lbl, ty) -> (lbl, copy_rec ty)) tyl) + | Tunboxed_tuple tyl -> + Tunboxed_tuple (List.map (fun (lbl, ty) -> (lbl, copy_rec ty)) tyl) + | Tpackage {pack_path; pack_cstrs} -> + let fl = List.map (fun (n, ty) -> n, copy_rec ty) pack_cstrs in + Tpackage {pack_path; pack_cstrs = 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) @@ -1068,11 +1127,12 @@ let rec check_scope_escape mark env level ty = | exception Cannot_expand -> raise_escape_exn (Constructor p) end - | Tpackage (p, fl) when level < Path.scope p -> + | Tpackage ({pack_path = p} as pack) 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))) + (newty2 ~level:orig_level + (Tpackage {pack with pack_path = p'})) | _ -> iter_type_expr_with_stages (fun env -> check_scope_escape mark env level) env ty @@ -1108,8 +1168,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. *) @@ -1136,13 +1202,13 @@ 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 -> + | Tpackage ({pack_path = p} as pack) 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)); + set_type_desc ty (Tpackage {pack with pack_path = p'}); update_level env level expand ty | Tobject (_, ({contents=Some(p, _tl)} as nm)) when level < Path.scope p -> @@ -1154,13 +1220,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_with_stages (fun env -> update_level env level expand) env ty @@ -1223,8 +1289,8 @@ let rec lower_contravariant env var_level visited contra ty = | 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 + | Tpackage p -> + List.iter (fun (_n, ty) -> lower_rec true ty) p.pack_cstrs | Tarrow (_, t1, t2, _) -> lower_rec true t1; lower_rec contra t2 @@ -1241,11 +1307,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; @@ -1253,20 +1319,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 @@ -1307,8 +1363,8 @@ let limited_generalize ty0 ty = 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 *) @@ -1525,11 +1581,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 -> @@ -1571,7 +1623,7 @@ let new_local_type ?(loc = Location.none) ?manifest_and_scope origin jkind = type_loc = loc; type_attributes = []; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); type_unboxed_version = None; } @@ -1579,7 +1631,7 @@ let new_local_jkind ?(loc = Location.none) ?manifest () = { jkind_manifest = manifest; jkind_attributes = []; - jkind_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + jkind_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); jkind_loc = loc; } @@ -1697,11 +1749,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 @@ -2090,33 +2138,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 (Jkind.Builtin.any ~why:Dummy_jkind) 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 (Jkind.Builtin.any ~why:Dummy_jkind) 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 let jkind_subst env level params args jkind = (* CR layouts v2.8: This function is used a lot, but there is a better way. @@ -2194,6 +2240,7 @@ let check_abbrev_env env = if not (Env.same_type_declarations env !previous_env) then begin (* prerr_endline "cleanup expansion cache"; *) cleanup_abbrev (); + simple_abbrevs := Mnil; previous_env := env end @@ -2437,9 +2484,12 @@ let rec try_reduce_once env t = Trepr (new_quote_eval_ty t, sl) (* [<[ module S with type typ = t ]> eval] ==> [module S with type typ = <[t]> eval] *) - | Tpackage (p, fl) -> - path_must_be_toplevel env p; - Tpackage (p, List.map (fun (n, t) -> n, new_quote_eval_ty t) fl) + | Tpackage { pack_path; pack_cstrs } -> + path_must_be_toplevel env pack_path; + Tpackage { pack_path; + pack_cstrs = + List.map (fun (n, t) -> n, new_quote_eval_ty t) + pack_cstrs } (* It is safe not to expand [Tof_kind], and we do not need to currently *) | Tof_kind _ -> raise Cannot_expand | Tlink _ | Tsubst _ -> assert false @@ -2643,7 +2693,7 @@ let unbox_once env ty = GADTs, but projected onto the instantiated head arguments of the wrapper type rather than the declaration parameters. *) let res_args = - match get_desc cstr.Types.cstr_res with + match get_desc cstr.cstr_res with | Tconstr (_, res_args, _) -> res_args | _ -> Misc.fatal_error "Ctype.unbox_once: cstr_res" in @@ -3404,8 +3454,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 @@ -3566,6 +3616,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 *) (* Invariant: [jkind1] and [jkind2] (newly added) have to be the @@ -3593,15 +3654,24 @@ let unify_univar env t1 t2 jkind1 jkind2 pairs = | _ -> raise Cannot_unify_universal_variables end - | [] -> raise Cannot_unify_universal_variables + | [] -> + raise Out_of_scope_universal_variable in inner t1 t2 pairs (* The same as [unify_univar], but raises the appropriate exception instead of [Cannot_unify_universal_variables] *) -let unify_univar_for tr_exn env t1 t2 jkind1 jkind2 univar_pairs = - try unify_univar env t1 t2 jkind1 jkind2 univar_pairs - with Cannot_unify_universal_variables -> raise_unexplained_for tr_exn +let unify_univar_for (type a) (tr_exn : a trace_exn) env t1 t2 jkind1 jkind2 + univar_pairs = + try unify_univar env t1 t2 jkind1 jkind2 univar_pairs with + | Cannot_unify_universal_variables -> raise_unexplained_for tr_exn + | Out_of_scope_universal_variable -> + (* Allow unscoped univars when checking for equality, since one + might want to compare arbitrary subparts of types, ignoring scopes; + see Typedecl_variance (#13514) for instance *) + match tr_exn with + | Equality -> raise_unexplained_for tr_exn + | _ -> fatal_error "Ctype.unify_univar_for: univar not in scope" (* Test the occurrence of free univars in a type *) (* That's way too expensive. Must do some kind of caching *) @@ -3713,8 +3783,16 @@ let univars_escape env univar_pairs vl ty = occur env 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) @@ -3726,17 +3804,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 = @@ -3830,29 +3906,26 @@ let unexpanded_diff ~got ~expected = (**** Unification ****) +(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) let rec deep_occur_rec mark t0 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 (deep_occur_rec mark t0) ty end -(* Return whether [t0] occurs in any type in [tyl]. Objects are also traversed. *) -let deep_occur_list t0 tyl = - with_type_mark (fun mark -> - try - List.iter (deep_occur_rec mark t0) tyl; - false - with Occur -> - true) - let deep_occur t0 ty = - with_type_mark (fun mark -> - try - deep_occur_rec mark t0 ty; - false - with Occur -> - true) + try + with_type_mark (fun mark -> deep_occur_rec mark t0 ty); + false + with + | Occur -> true +let deep_occur_list t0 tyl = + try + with_type_mark (fun mark -> List.iter (deep_occur_rec mark t0) tyl); + false + with + | Occur -> true (* a local constraint can be added only if the rhs of the constraint does not contain any Tvars. @@ -3978,6 +4051,26 @@ 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 +let equivalent_with_nolabels l1 l2 = + l1 = l2 || (match l1, l2 with + | (Nolabel | Labelled _), (Nolabel | Labelled _) -> true + | _ -> false) + +(* 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) + && equivalent_with_nolabels l1 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 @@ -3989,23 +4082,27 @@ let rec expands_to_datatype env ty = end | _ -> false -let equivalent_with_nolabels l1 l2 = - l1 = l2 || (match l1, l2 with - | (Nolabel | Labelled _), (Nolabel | Labelled _) -> true - | _ -> false) - (* the [tk] means we're comparing a type against a jkind; axes do not matter, so a jkind extracted from a type_declaration does not need to be substed *) let may_have_jkind_intersection_tk env ty jkind = Jkind.may_have_intersection env (type_jkind env ty) jkind -(* [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] tests if two types are "compatible" -- i.e., if there could + exist a witness of their equality. This is distinct from [eqtype], + which checks if two types *are* exactly the same. + [mcomp] is used to decide whether GADT cases are unreachable. + The existence of a witness is necessarily an incomplete property, + i.e. there exists types for which we cannot tell if an equality + witness could exist or not. Typically, this is the case for + abstract types, which could be equal to anything, depending on + their actual definition. As a result [mcomp] overapproximates + compatibilty, i.e. when it says that two types are incompatible, we + are sure that there exists no equality witness, but if it does not + say so, there is no guarantee that such a witness could exist. + *) -(* mcomp type_pairs subst env t1 t2 does not raise an +(* [mcomp type_pairs subst env t1 t2] should 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. @@ -4066,9 +4163,9 @@ let rec mcomp type_pairs env t1 t2 = | (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 + raise Incompatible | (_, Tconstr (_, [], _), _, _) when has_injective_univars env t1' -> - raise_unexplained_for Unify + raise Incompatible | (Tconstr (p, _, _), _, _, other) | (_, Tconstr (p, _, _), other, _) -> begin try let decl = Env.find_type p env in @@ -4080,7 +4177,7 @@ let rec mcomp type_pairs env t1 t2 = end (* Rigid cases -- neither side is flexible nor aliasable *) | (Tarrow ((l1,_,_), t1, u1, _), Tarrow ((l2,_,_), t2, u2, _), _, _) - when equivalent_with_nolabels l1 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, _, _) -> @@ -4108,7 +4205,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) | (Trepr (t1, sort_vars1), Trepr (t2, sort_vars2), _, _) -> @@ -4120,8 +4217,10 @@ let rec mcomp type_pairs env t1 t2 = (fun () -> mcomp type_pairs env t1 t2) with Invalid_argument _ -> raise Incompatible) | (Tunivar {jkind=jkind1}, Tunivar {jkind=jkind2}, _, _) -> - (try unify_univar env t1' t2' jkind1 jkind2 !univar_pairs - with Cannot_unify_universal_variables -> raise Incompatible) + begin try unify_univar env t1' t2' jkind1 jkind2 !univar_pairs with + | Cannot_unify_universal_variables -> raise Incompatible + | Out_of_scope_universal_variable -> () + end | (_, _, _, _) -> raise Incompatible end @@ -4132,7 +4231,7 @@ and mcomp_list type_pairs env tl1 tl2 = List.iter2 (mcomp type_pairs env) tl1 tl2 and mcomp_labeled_list type_pairs env labeled_tl1 labeled_tl2 = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then raise Incompatible; List.iter2 (fun (label1, ty1) (label2, ty2) -> @@ -4427,29 +4526,18 @@ let eq_package_path env 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) +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 - 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 +(* Find the type paths nl1 in the module type pack2, 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 = +let complete_type_list ?(allow_absent=false) env fl1 lv2 pack2 = (* 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. @@ -4461,14 +4549,15 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = 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 env' = Env.add_module id2 Mp_present (Mty_ident pack2.pack_path) 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 + let lid = "Pkg" :: n in + let lid = Option.get (Longident.unflatten lid) in match Env.find_type_by_name lid env' with | (_, {type_arity = 0; type_kind = Type_abstract _; type_private = Public; type_manifest = Some t2}) -> @@ -4488,7 +4577,7 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = | exception Not_found when allow_absent-> complete nl fl2 in - match complete fl1 fl2 with + match complete fl1 pack2.pack_cstrs with | res -> res | exception Exit -> raise Not_found @@ -4497,7 +4586,7 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = let rec is_instantiable_ty uenv ty = match get_desc ty with | Tconstr (path, [], _) -> - can_generate_equations uenv && + in_pattern_mode uenv && is_instantiable (get_env uenv) ~for_jkind_eqn:false path | Tquote ty' -> unify_with_incr_stage uenv (fun uenv -> @@ -4525,13 +4614,14 @@ let rec instantiable_scope ty = | _ -> -1 (* 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 +let compare_package env unify_list lv1 pack1 lv2 pack2 = + let ntl2 = complete_type_list env pack1.pack_cstrs lv2 pack2 + and ntl1 = complete_type_list env pack2.pack_cstrs lv1 pack1 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 pack1.pack_path pack2.pack_path then Ok () + else Result.bind + (!package_subtype env pack1 pack2) + (fun () -> !package_subtype env pack2 pack1) let unify_alloc_mode_for tr_exn a b = match Alloc.equate a b with @@ -4588,24 +4678,22 @@ let unify3_var uenv jkind1 t1' t2 t2' = backtrack snap; reify uenv t1'; reify uenv t2'; - if can_generate_equations uenv then begin - begin match get_desc t2' with - | Tconstr(path,[],_) - when is_instantiable (get_env uenv) ~for_jkind_eqn:false path -> - add_gadt_equation uenv path t1' - (* This is necessary because a failed kind-check above - might meaningfully refine a type constructor *) - | _ -> - occur_univar ~inj_only:true (get_env uenv) t2'; - mcomp_for Unify (get_env uenv) t1' t2' - (* the call to [mcomp] can be skipped in the other case in this - [match] because [add_gadt_equation] checks for jkind - intersection, which is the only interesting check in [mcomp] - when one side is a variable. We could pull that check out - here specially, but it seems simpler not to. *) - end; - record_equation uenv t1' t2'; - end + begin match get_desc t2' with + | Tconstr(path,[],_) + when is_instantiable (get_env uenv) ~for_jkind_eqn:false path -> + add_gadt_equation uenv path t1' + (* This is necessary because a failed kind-check above + might meaningfully refine a type constructor *) + | _ -> + occur_univar ~inj_only:true (get_env uenv) t2'; + mcomp_for Unify (get_env uenv) t1' t2' + (* the call to [mcomp] can be skipped in the other case in this + [match] because [add_gadt_equation] checks for jkind + intersection, which is the only interesting check in [mcomp] + when one side is a variable. We could pull that check out + here specially, but it seems simpler not to. *) + end; + record_equation uenv t1' t2' (* 1. When unifying two non-abbreviated types, one type is made a link @@ -4773,15 +4861,11 @@ and unify3 uenv t1 t1' t2 t2' = end; try begin match (d1, d2) with - (Tarrow ((l1,a1,r1), t1, u1, c1), - Tarrow ((l2,a2,r2), t2, u2, c2)) - when - (l1 = l2 || - (!Clflags.classic || in_pattern_mode uenv) && - equivalent_with_nolabels l1 l2) -> + (Tarrow ((l1,a1,r1), t1, u1, c1), Tarrow ((l2,a2,r2), t2, u2, c2)) -> + eq_labels Unify ~in_pattern_mode:(in_pattern_mode uenv) l1 l2; unify_alloc_mode_for Unify a1 a2; unify_alloc_mode_for Unify r1 r2; - unify uenv t1 t2; unify uenv u1 u2; + 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 @@ -4793,7 +4877,7 @@ and unify3 uenv t1 t1' t2 t2' = | (Tunboxed_tuple labeled_tl1, Tunboxed_tuple labeled_tl2) -> unify_labeled_list uenv labeled_tl1 labeled_tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> - if not (can_generate_equations uenv) then + if not (in_pattern_mode 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) @@ -4809,22 +4893,17 @@ and unify3 uenv t1 t1' t2 t2' = 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) + if i then unify uenv t1 t2 else begin + 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 ~for_jkind_eqn:false path - && is_instantiable env ~for_jkind_eqn:false path' - && can_generate_equations uenv -> + when in_pattern_mode uenv && + let env = get_env uenv in + is_instantiable env ~for_jkind_eqn:false path + && is_instantiable env ~for_jkind_eqn:false path' -> let source, destination = if Path.scope path > Path.scope path' then path , t2' @@ -4833,14 +4912,14 @@ and unify3 uenv t1 t1' t2 t2' = record_equation uenv t1' t2'; add_gadt_equation uenv source destination | (Tconstr (path,[],_), _) - when is_instantiable (get_env uenv) ~for_jkind_eqn:false path - && can_generate_equations uenv -> + when in_pattern_mode uenv + && is_instantiable (get_env uenv) ~for_jkind_eqn:false path -> reify uenv t2'; record_equation uenv t1' t2'; add_gadt_equation uenv path t2' | (_, Tconstr (path,[],_)) - when is_instantiable (get_env uenv) ~for_jkind_eqn:false path - && can_generate_equations uenv -> + when in_pattern_mode uenv + && is_instantiable (get_env uenv) ~for_jkind_eqn:false path -> reify uenv t1'; record_equation uenv t1' t2'; add_gadt_equation uenv path t1' @@ -4879,10 +4958,8 @@ and unify3 uenv t1 t1' t2 t2' = && (is_equatable_ty t1 || is_equatable_ty t2) -> 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' - ) + 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] *) @@ -4904,10 +4981,8 @@ and unify3 uenv t1 t1' t2 t2' = 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' - ) + 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 @@ -4928,7 +5003,7 @@ 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) | (Trepr (t1, sort_vars1), Trepr (t2, sort_vars2)) -> (* For layout-polymorphic types, establish correspondence between @@ -4938,15 +5013,8 @@ and unify3 uenv t1 t1' t2 t2' = Jkind_types.Sort.enter_repr pairs (fun () -> unify uenv t1 t2) with Invalid_argument _ -> raise_unexplained_for Unify) - | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try - unify_package (get_env uenv) (unify_list uenv) - (get_level t1) p1 fl1 (get_level t2) p2 fl2 - with 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 + | (Tpackage pack1, Tpackage pack2) -> + unify_package uenv (get_level t1) pack1 (get_level t2) pack2 | (Tnil, Tconstr _ ) -> raise_for Unify (Obj (Abstract_row Second)) | (Tconstr _, Tnil ) -> @@ -4975,15 +5043,33 @@ and unify_list env tl1 tl2 = List.iter2 (unify env) tl1 tl2 and unify_labeled_list env labeled_tl1 labeled_tl2 = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then raise_unexplained_for Unify; List.iter2 (fun (label1, ty1) (label2, ty2) -> - if not (Option.equal String.equal label1 label2) then - raise_unexplained_for Unify; + if not (Option.equal String.equal label1 label2) then begin + let diff = { Errortrace.got=label1; expected=label2} in + raise_for Unify (Errortrace.Tuple_label_mismatch diff) + end; unify env ty1 ty2) labeled_tl1 labeled_tl2 +and unify_package uenv lvl1 pack1 lvl2 pack2 = + match + compare_package (get_env uenv) (unify_list uenv) lvl1 pack1 lvl2 pack2 + 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) + (pack1.pack_cstrs @ pack2.pack_cstrs); + | exception Not_found -> + if not (in_pattern_mode uenv) then raise_unexplained_for Unify; + List.iter (fun (_n, ty) -> reify uenv ty) + (pack1.pack_cstrs @ pack2.pack_cstrs); + (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) + (* Build a fresh row variable for unification *) and make_rowvar level use1 rest1 use2 rest2 = let set_name ty name = @@ -5267,21 +5353,30 @@ let unify uenv ty1 ty2 = undo_compress snap; raise (Unify (expand_to_unification_error (get_env uenv) trace)) -let unify_gadt (penv : Pattern_env.t) ty1 ty2 = - Misc.protect_refs [R (univar_pairs, [])] begin fun () -> +let unify_gadt (penv : Pattern_env.t) ~pat:ty1 ~expected:ty2 = let equated_types = TypePairs.create 0 in - let equations_generation = - Allowed { equated_types; pattern_stage = Env.stage penv.env } - in - let uenv = Pattern - { penv; - equations_generation; - assume_injective = true; - unify_eq_set = TypePairs.create 11; } + let do_unify_gadt () = + let uenv = Pattern + { penv; + equated_types; + assume_injective = true; + unify_eq_set = TypePairs.create 11; } + in + unify uenv ty1 ty2; + equated_types in - unify uenv ty1 ty2; - equated_types - end + let no_leak = penv.in_counterexample || closed_type_expr ty2 in + if no_leak then with_univar_pairs [] do_unify_gadt else + let snap = Btype.snapshot () in + try + (* If there are free variables, first try normal unification *) + let uenv = Expression {env = penv.env; in_subst = false} in + with_univar_pairs [] (fun () -> unify uenv ty1 ty2); + equated_types + with Unify _ -> + (* If it fails, retry in pattern mode *) + Btype.backtrack snap; + with_univar_pairs [] do_unify_gadt let unify_var uenv t1 t2 = if eq_type t1 t2 then () else @@ -5314,10 +5409,8 @@ let unify_var env ty1 ty2 = unify_var (Expression {env; in_subst = false}) ty1 ty2 let unify_pairs env ty1 ty2 pairs = - Misc.protect_refs [R (univar_pairs, pairs)] begin fun () -> - univar_pairs := pairs; - unify (Expression {env; in_subst = false}) ty1 ty2 - end + with_univar_pairs pairs (fun () -> + unify (Expression {env; in_subst = false}) ty1 ty2) let unify env ty1 ty2 = unify_pairs env ty1 ty2 [] @@ -5806,26 +5899,19 @@ 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 (Jkind.Builtin.value ~why:Object)) 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. @@ -5835,7 +5921,7 @@ 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 is_Tvar ty && lv >= subject_level then raise Occur else if try_mark_node mark ty then iter_type_expr occur ty in try @@ -6016,7 +6102,7 @@ let moregen_alloc_mode env ~is_ret ty v a1 a2 = 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 variance type_pairs env t1 t2 = @@ -6052,9 +6138,8 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = check_type_jkind_exn env Moregen t2 (Jkind.disallow_left jkind); link_type t1' t2 | (Tarrow ((l1,a1,r1), t1, u1, _), - Tarrow ((l2,a2,r2), t2, u2, _)) when - (l1 = l2 - || !Clflags.classic && equivalent_with_nolabels l1 l2) -> + Tarrow ((l2,a2,r2), t2, u2, _)) -> + eq_labels Moregen ~in_pattern_mode:false l1 l2; moregen inst_nongen (neg_variance variance) type_pairs env t1 t2; moregen inst_nongen variance type_pairs env u1 u2; (* [t2] and [u2] is the user-written interface, which we deem as @@ -6083,12 +6168,9 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = | exception Not_found -> moregen_list inst_nongen Invariant type_pairs env tl1 tl2 end - | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try - unify_package env (moregen_list inst_nongen variance type_pairs env) - (get_level t1') p1 fl1 (get_level t2') p2 fl2 - with Not_found -> raise_unexplained_for Moregen - end + | (Tpackage pack1, Tpackage pack2) -> + moregen_package inst_nongen variance type_pairs env + (get_level t1') pack1 (get_level t2') pack2 | (Tnil, Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second)) | (Tconstr _, Tnil ) -> raise_for Moregen (Obj (Abstract_row First)) | (Tvariant row1, Tvariant row2) -> @@ -6103,7 +6185,7 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = | (Tpoly (t1, []), Tpoly (t2, [])) -> moregen inst_nongen variance 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 variance type_pairs env) | (Trepr (t1, sort_vars1), Trepr (t2, sort_vars2)) -> (* For layout-polymorphic types, establish correspondence @@ -6139,7 +6221,7 @@ and moregen_list inst_nongen variance type_pairs env tl1 tl2 = and moregen_labeled_list inst_nongen variance type_pairs env labeled_tl1 labeled_tl2 = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then raise_unexplained_for Moregen; List.iter2 (fun (label1, ty1) (label2, ty2) -> @@ -6157,6 +6239,15 @@ and moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 = moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 | _, _, _ -> raise_unexplained_for Moregen +and moregen_package inst_nongen variance type_pairs env lvl1 pack1 lvl2 pack2 = + match + compare_package env (moregen_list inst_nongen variance type_pairs env) + lvl1 pack1 lvl2 pack2 + with + | Ok () -> () + | Error fme -> raise_for Moregen (First_class_module fme) + | exception Not_found -> raise_unexplained_for Moregen + and moregen_fields inst_nongen variance type_pairs env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in @@ -6311,63 +6402,70 @@ and moregen_row inst_nongen variance type_pairs env row1 row2 = is unimportant. So, no need to propagate abbreviations. *) let moregeneral env inst_nongen pat_sort_vars subj_sort_vars pat_sch subj_sch = - let old_level = !current_level in - Misc.try_finally - (fun () -> - 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_sorts, subj_inst) = - Jkind_types.Sort.instance_with ~level:!current_level subj_sort_vars - (fun () -> instance subj_sch) - in - let subj = duplicate_type subj_inst in - current_level := generic_level; - (* Duplicate generic variables *) - let (pat_sorts, patt) = - Jkind_types.Sort.instance_with ~level:!current_level pat_sort_vars - (fun () -> instance pat_sch) - in - try - Misc.protect_refs [R (univar_pairs, [])] begin fun () -> - let type_pairs = fresh_moregen_pairs () in - moregen inst_nongen Covariant type_pairs env patt subj; - (* After [moregen], [pat_sorts] have been set to [subj_sorts]. - [subj_sorts] are ephemeral rigid vars created by - [instance_with] to stand for [subj_sort_vars] during moregen. - Replace them back with the originals so that the returned - [pat_sort_refs] refer to [subj_sort_vars], not to the - short-lived rigid instances. *) - let subj_sort_vars = + (* 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, + by regeneralizing the levels of the types on the error path. + *) + with_level ~level:(subject_level - 1) begin fun () -> + (* + 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_sorts, subj_inst, subj) = + with_level ~level:subject_level begin fun () -> + let (subj_sorts, subj_inst) = + Jkind_types.Sort.instance_with ~level:!current_level subj_sort_vars + (fun () -> instance subj_sch) + in + let subj = duplicate_type subj_inst in + (subj_sorts, subj_inst, subj) + end + in + (* Duplicate generic variables *) + let (pat_sorts, patt) = + Jkind_types.Sort.instance_with ~level:generic_level pat_sort_vars + (fun () -> generic_instance pat_sch) + in + try + with_univar_pairs [] begin fun () -> + let type_pairs = fresh_moregen_pairs () in + moregen inst_nongen Covariant type_pairs env patt subj; + (* After [moregen], [pat_sorts] have been set to [subj_sorts]. + [subj_sorts] are ephemeral rigid vars created by + [instance_with] to stand for [subj_sort_vars] during moregen. + Replace them back with the originals so that the returned + [pat_sort_refs] refer to [subj_sort_vars], not to the + short-lived rigid instances. *) + let subj_sort_vars = List.map (fun v -> Jkind_types.Sort.Var v) subj_sort_vars - in - let subst_map = List.combine subj_sorts subj_sort_vars in - List.map - (fun v -> - v - |> Jkind_types.Sort.get_representable_var - |> Option.map (Jkind_types.Sort.subst subst_map)) - pat_sorts - end - 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; - let (), _sub_sorts = - Jkind_types.Sort.generalize_with (fun () -> generalize subj_inst) - in - raise (Moregen (expand_to_moregen_error env trace))) - ~always:(fun () -> current_level := old_level) + in + let subst_map = List.combine subj_sorts subj_sort_vars in + List.map + (fun v -> + v + |> Jkind_types.Sort.get_representable_var + |> Option.map (Jkind_types.Sort.subst subst_map)) + pat_sorts + end + with Moregen_trace trace -> + (* 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 this error, we need to merge them back together, + by regeneralizing the levels of the types after they were + instantiated at [subject_level] 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. *) + let (), _sub_sorts = + Jkind_types.Sort.generalize_with (fun () -> generalize subj_inst) + in + 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 @@ -6529,13 +6627,12 @@ let rec eqtype rename type_pairs subst env ~do_jkind_check t1 t2 = let check_phys_eq t1 t2 = not rename && eq_type t1 t2 in - (* Checking for physical equality 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. + (* 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 phyiscal + 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 @@ -6559,9 +6656,8 @@ let rec eqtype rename type_pairs subst env ~do_jkind_check t1 t2 = (Tvar { jkind = k1 }, Tvar { jkind = k2 }) when rename -> eqtype_subst env type_pairs subst t1' k1 t2' k2 ~do_jkind_check | (Tarrow ((l1,a1,r1), t1, u1, _), - Tarrow ((l2,a2,r2), t2, u2, _)) when - (l1 = l2 - || !Clflags.classic && equivalent_with_nolabels l1 l2) -> + Tarrow ((l2,a2,r2), t2, u2, _)) -> + eq_labels Equality ~in_pattern_mode:false l1 l2; eqtype rename type_pairs subst env t1 t2 ~do_jkind_check:true; eqtype rename type_pairs subst env u1 u2 ~do_jkind_check:true; eqtype_alloc_mode a1 a2; @@ -6576,13 +6672,9 @@ let rec eqtype rename type_pairs subst env ~do_jkind_check t1 t2 = when Path.same p1 p2 -> eqtype_list_same_length rename type_pairs subst env tl1 tl2 ~do_jkind_check:true - | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try - unify_package env - (eqtype_list rename type_pairs subst env ~do_jkind_check:true) - (get_level t1') p1 fl1 (get_level t2') p2 fl2 - with Not_found -> raise_unexplained_for Equality - end + | (Tpackage pack1, Tpackage pack2) -> + eqtype_package rename type_pairs subst env + (get_level t1') pack1 (get_level t2') pack2 | (Tnil, Tconstr _ ) -> raise_for Equality (Obj (Abstract_row Second)) | (Tconstr _, Tnil ) -> @@ -6599,7 +6691,7 @@ let rec eqtype rename type_pairs subst env ~do_jkind_check t1 t2 = | (Tpoly (t1, []), Tpoly (t2, [])) -> eqtype rename type_pairs subst env t1 t2 ~do_jkind_check | (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 ~do_jkind_check) | (Trepr (t1, sort_vars1), Trepr (t2, sort_vars2)) -> (* For layout-polymorphic types, establish correspondence @@ -6637,7 +6729,7 @@ and eqtype_list rename type_pairs subst env tl1 tl2 ~do_jkind_check = eqtype_list_same_length rename type_pairs subst env tl1 tl2 ~do_jkind_check and eqtype_labeled_list rename type_pairs subst env labeled_tl1 labeled_tl2 = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then raise_unexplained_for Equality; List.iter2 (fun (label1, ty1) (label2, ty2) -> @@ -6646,6 +6738,16 @@ and eqtype_labeled_list rename type_pairs subst env labeled_tl1 labeled_tl2 = eqtype rename type_pairs subst env ty1 ty2 ~do_jkind_check:true) labeled_tl1 labeled_tl2 +and eqtype_package rename type_pairs subst env lvl1 pack1 lvl2 pack2 = + match + compare_package env + (eqtype_list rename type_pairs subst env ~do_jkind_check:true) + lvl1 pack1 lvl2 pack2 + with + | Ok () -> () + | Error fme -> raise_for Equality (First_class_module fme) + | exception Not_found -> raise_unexplained_for Equality + and eqtype_fields rename type_pairs subst env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 in let (fields2, rest2) = flatten_fields ty2 in @@ -6775,16 +6877,16 @@ and eqtype_alloc_mode m1 m2 = (* Must empty univar_pairs first *) let eqtype_list_same_length rename type_pairs subst env tl1 tl2 ~do_jkind_check = - Misc.protect_refs [R (univar_pairs, [])] begin 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 ~do_jkind_check) - end + 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 ~do_jkind_check)) let eqtype rename type_pairs subst env t1 t2 = - eqtype_list ~do_jkind_check:true rename type_pairs subst env [t1] [t2] + eqtype_list_same_length ~do_jkind_check:true rename type_pairs subst env [t1] + [t2] (* Two modes: with or without renaming of variables *) let equal ?(do_jkind_check = true) env rename tyl1 tyl2 = @@ -6958,48 +7060,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 = fresh_moregen_pairs () 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.invariant_pairs (self1, self2); - (* Always succeeds *) - moregen true Covariant 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 ~before_generalize:ignore 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 = fresh_moregen_pairs () 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.invariant_pairs (self1, self2); + (* Always succeeds *) + moregen true Covariant 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 @@ -7422,8 +7524,8 @@ let rec subtype_rec env trace t1 t2 cstrs = (Tvar _, _) | (_, Tvar _) -> (trace, t1, t2, !univar_pairs)::cstrs | (Tarrow((l1,a1,r1), t1, u1, _), - Tarrow((l2,a2,r2), t2, u2, _)) when l1 = l2 - || !Clflags.classic && equivalent_with_nolabels l1 l2 -> + Tarrow((l2,a2,r2), t2, u2, _)) + when compatible_labels ~in_pattern_mode:false l1 l2 -> let cstrs = subtype_rec env @@ -7462,7 +7564,8 @@ let rec subtype_rec env trace t1 t2 cstrs = if co then if cn then (trace, newty2 ~level:(get_level t1) (Ttuple[None, t1]), - newty2 ~level:(get_level t2) (Ttuple[None, t2]), !univar_pairs) + newty2 ~level:(get_level t2) (Ttuple[None, t2]), + !univar_pairs) :: cstrs else subtype_rec @@ -7507,7 +7610,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 @@ -7520,31 +7623,9 @@ let rec subtype_rec env trace t1 t2 cstrs = Jkind_types.Sort.enter_repr pairs (fun () -> subtype_rec env trace u1 u2 cstrs) with Invalid_argument _ -> (trace, t1, t2, !univar_pairs)::cstrs) - | (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 !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 + | (Tpackage pack1, Tpackage pack2) -> + subtype_package env trace (get_level t1) pack1 + (get_level t2) pack2 cstrs | (Tquote t1, Tquote t2) -> subtype_rec (incr_stage env) trace t1 t2 cstrs | (Tsplice t1, Tsplice t2) -> @@ -7556,7 +7637,7 @@ let rec subtype_rec env trace t1 t2 cstrs = end and subtype_labeled_list env trace labeled_tl1 labeled_tl2 cstrs = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then subtype_error ~env ~trace ~unification_trace:[]; List.fold_left2 (fun cstrs (label1, ty1) (label2, ty2) -> @@ -7569,6 +7650,31 @@ and subtype_labeled_list env trace labeled_tl1 labeled_tl2 cstrs = cstrs) cstrs labeled_tl1 labeled_tl2 +and subtype_package env trace lvl1 pack1 lvl2 pack2 cstrs = + try + let ntl1 = complete_type_list env pack2.pack_cstrs lvl1 pack1 + and ntl2 = + complete_type_list env pack1.pack_cstrs lvl2 pack2 + ~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 pack1.pack_path pack2.pack_path 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 pack1 pack2) -> + Btype.backtrack snap; cstrs' @ cstrs + | () | exception Unify _ -> + Btype.backtrack snap; raise Not_found + end + with Not_found -> + (trace, newty (Tpackage pack1), newty (Tpackage pack2), !univar_pairs) + ::cstrs + and subtype_fields env trace ty1 ty2 cstrs = (* Assume that either rest1 or rest2 is not Tvar *) let (fields1, rest1) = flatten_fields ty1 in @@ -7621,7 +7727,7 @@ and subtype_row env trace row1 row2 cstrs = | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) when row1_closed && r1 = [] -> List.fold_left - (fun cstrs (_,f1,f2) -> + (fun cstrs (l,f1,f2) -> match row_field_repr f1, row_field_repr f2 with (Rpresent None|Reither(true,_,_)), Rpresent None -> cstrs @@ -7638,7 +7744,12 @@ and subtype_row env trace row1 row2 cstrs = t1 t2 cstrs | Rabsent, _ -> cstrs - | _ -> raise Exit) + | Rpresent None, Rpresent (Some _) + | Rpresent (Some _), Rpresent None -> + subtype_error ~env ~trace + ~unification_trace:[Variant (Incompatible_types_for l)] + | _ -> + raise Exit) cstrs pairs | Tunivar _, Tunivar _ when row1_closed = row2_closed && r1 = [] && r2 = [] -> @@ -7670,20 +7781,22 @@ and subtype_row env trace row1 row2 cstrs = let subtype env ty1 ty2 = TypePairs.clear subtypes; - Misc.protect_refs [R (univar_pairs, [])] begin 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) - end + 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 *) @@ -7875,7 +7988,8 @@ let rec normalize_type_rec mark ty = begin match !nm with | None -> () | Some (n, v :: l) -> - if deep_occur_list ty l then + if deep_occur_list ty l + then (* The abbreviation may be hiding something, so remove it *) set_name nm None else @@ -7989,13 +8103,16 @@ let rec nondep_type_rec ?(expand_private=false) env ids ty = *) with Cannot_expand -> raise exn end - | Tpackage(p, fl) when Path.exists_free ids p -> - let p' = normalize_package_path env p in + | Tpackage pack when Path.exists_free ids pack.pack_path -> + let p' = normalize_package_path env pack.pack_path 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) + Tpackage { + pack_path = p'; + pack_cstrs = List.map nondep_field_rec pack.pack_cstrs + } end | Tobject (t1, name) -> Tobject (nondep_type_rec env ids t1, diff --git a/src/ocaml/typing/ctype.mli b/src/ocaml/typing/ctype.mli index 4be698bf4..b8e68fd96 100644 --- a/src/ocaml/typing/ctype.mli +++ b/src/ocaml/typing/ctype.mli @@ -34,6 +34,16 @@ 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: + before_generalize:('a -> unit) -> (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. @@ -148,7 +158,7 @@ val iter_type_expr_with_stages: (Env.t -> type_expr -> unit) -> Env.t -> type_expr -> unit val generalize: type_expr -> unit - (* Generalize in-place the given type *) +(* 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 *) @@ -156,23 +166,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 @@ -201,13 +204,13 @@ module Pattern_env : sig { mutable env : Env.t; equations_scope : int; (* scope for local type declarations *) - allow_recursive_equations : bool; + in_counterexample : bool; (* true iff checking counter examples *) is_lpoly : bool; (* true iff the pattern is under let poly_ *) } - val make: ?is_lpoly:bool -> Env.t -> equations_scope:int - -> allow_recursive_equations:bool -> t + val make: ?is_lpoly:bool -> + Env.t -> equations_scope:int -> in_counterexample:bool -> t val copy: ?equations_scope:int -> t -> t val set_env: t -> Env.t -> unit end @@ -216,10 +219,12 @@ type existential_treatment = | Keep_existentials_flexible | Make_existentials_abstract of Pattern_env.t -val instance_constructor: existential_treatment -> - constructor_description -> - Types.constructor_argument list * type_expr * type_expr list - (* Same, for a constructor. Also returns existentials. *) +val instance_constructor: + existential_treatment -> + Data_types.constructor_description -> + Types.constructor_argument 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 @@ -240,10 +245,12 @@ val instance_poly_fixed: checking that an expression matches this scheme. *) val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool + val instance_label: - fixed:bool -> - _ gen_label_description -> type_expr list * type_expr * type_expr - (* Same, for a label *) + fixed:bool -> + _ Data_types.gen_label_description -> + type_expr list * type_expr * type_expr +(* Same, for a label *) val prim_mode : (Mode.allowed * 'r) Mode.Locality.t option -> (Primitive.mode * Primitive.native_repr) -> (Mode.allowed * 'r) Mode.Locality.t @@ -311,13 +318,19 @@ 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: - 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. *) + Pattern_env.t -> pat:type_expr -> expected:type_expr -> Btype.TypePairs.t + (* [unify_gadt penv ~pat:ty1 ~expected:ty2] unifies [ty1] and [ty2] + in [Pattern] mode, possible adding local constraints to the + environment in [penv]. Raises [Unify] if not possible. + Returns the pairs of types that have been equated. + Type variables in [ty1] are always assumed to be non-leaking + (safely reifiable); if [penv.in_counterexample = true] + then both [ty1] and [ty2] are assumed to be non-leaking. *) val unify_var: Env.t -> type_expr -> type_expr -> unit (* Same as [unify], but allow free univars when first type is a variable. *) @@ -353,11 +366,11 @@ 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 + (* Check whether a type occurs structurally within another. *) val deep_occur_list: type_expr -> type_expr list -> bool (* Check whether a type occurs structurally within any type from a list of types. *) -val deep_occur: type_expr -> type_expr -> bool - (* Check whether a type occurs structurally within another. *) val moregeneral: Env.t -> bool -> Jkind_types.Sort.var list -> Jkind_types.Sort.var list -> type_expr -> type_expr -> Jkind_types.Sort.t option list @@ -574,15 +587,15 @@ type closed_class_failure = { val free_variables: ?env:Env.t -> type_expr -> type_expr list (* If env present, then check for incomplete definitions too; returns both normal variables and row variables*) +val free_variables_list: ?env:Env.t -> type_expr list -> type_expr list + (* If env present, then check for incomplete definitions too *) val free_non_row_variables_of_list: type_expr list -> type_expr list (* gets only non-row variables *) val free_variable_set_of_list: Env.t -> type_expr list -> Btype.TypeSet.t (* post-condition: all elements in the set are Tvars *) - val exists_free_variable : (type_expr -> jkind_lr -> bool) -> type_expr -> bool (* Check if there exists a free variable that satisfies the given predicate. *) - val closed_type_expr: ?env:Env.t -> type_expr -> bool (* If env present, expand abbreviations to see if expansion eliminates the variable *) @@ -603,12 +616,12 @@ 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 wrap_trace_gadt_instances: ?force:bool -> Env.t -> ('a -> 'b) -> 'a -> 'b (* Stubs *) val package_subtype : - (Env.t -> Path.t -> (Longident.t * type_expr) list -> - Path.t -> (Longident.t * type_expr) list -> bool) ref + (Env.t -> package -> package -> + (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 bbeb1a6fa..cef6887da 100644 --- a/src/ocaml/typing/datarepr.ml +++ b/src/ocaml/typing/datarepr.ml @@ -18,6 +18,7 @@ open Asttypes open Types +open Data_types open Btype module Jkind = Btype.Jkind0 @@ -31,13 +32,13 @@ let free_vars ?(param=false) ty = | 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_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 @@ -283,7 +284,7 @@ let dummy_label (type rep) (record_form : rep record_form) { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; lbl_modalities = Mode.Modality.Const.id; lbl_sort = Jkind_types.Sort.Const.void; - lbl_pos = -1; lbl_all = [||]; + lbl_pos = (-1); lbl_all = [||]; lbl_repres = repres; lbl_private = Public; lbl_loc = Location.none; @@ -293,7 +294,7 @@ let dummy_label (type rep) (record_form : rep record_form) let label_descrs record_form ty_res lbls repres priv = let all_labels = Array.make (List.length lbls) (dummy_label record_form) in - let rec describe_labels pos = function + let rec describe_labels num = function [] -> [] | l :: rest -> let lbl = @@ -303,7 +304,7 @@ let label_descrs record_form ty_res lbls repres priv = lbl_mut = l.ld_mutable; lbl_modalities = l.ld_modalities; lbl_sort = l.ld_sort; - lbl_pos = pos; + lbl_pos = num; lbl_all = all_labels; lbl_repres = repres; lbl_private = priv; @@ -311,8 +312,8 @@ let label_descrs record_form ty_res lbls repres priv = lbl_attributes = l.ld_attributes; lbl_uid = l.ld_uid; } in - all_labels.(pos) <- lbl; - (l.ld_id, lbl) :: describe_labels (pos+1) rest in + all_labels.(num) <- lbl; + (l.ld_id, lbl) :: describe_labels (num+1) rest in describe_labels 0 lbls exception Constr_not_found diff --git a/src/ocaml/typing/datarepr.mli b/src/ocaml/typing/datarepr.mli index 6c8e7c24e..ab11e613a 100644 --- a/src/ocaml/typing/datarepr.mli +++ b/src/ocaml/typing/datarepr.mli @@ -17,9 +17,10 @@ determining their representation. *) open Types +open Data_types val extension_descr: - current_unit:Unit_info.t option -> Path.t -> extension_constructor -> + current_unit:(Unit_info.t option) -> Path.t -> extension_constructor -> constructor_description val labels_of_type: @@ -29,7 +30,7 @@ val unboxed_labels_of_type: Path.t -> type_declaration -> (Ident.t * unboxed_label_description) list val constructors_of_type: - current_unit:Unit_info.t option -> 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/envaux.ml b/src/ocaml/typing/envaux.ml index 48b3a8073..02a48a363 100644 --- a/src/ocaml/typing/envaux.ml +++ b/src/ocaml/typing/envaux.ml @@ -120,7 +120,7 @@ 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.path) p + (Style.as_inline_code Printtyp.Doc.path) p let () = Location.register_error_of_exn diff --git a/src/ocaml/typing/errortrace.ml b/src/ocaml/typing/errortrace.ml index aa06a15a4..31b51c37b 100644 --- a/src/ocaml/typing/errortrace.ml +++ b/src/ocaml/typing/errortrace.ml @@ -98,14 +98,22 @@ 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 arg_label diff + | Tuple_label_mismatch of string option 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 | Bad_jkind : type_expr * Jkind.Violation.t -> ('a, _) elt @@ -130,7 +138,9 @@ 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 _ | Tuple_label_mismatch _ + | Incompatible_fields _ + | Rec_occur (_, _) | First_class_module _ as x -> x | Bad_jkind _ as x -> x | Bad_jkind_sort _ as x -> x | Unequal_var_jkinds _ as x -> x diff --git a/src/ocaml/typing/errortrace.mli b/src/ocaml/typing/errortrace.mli index 81fe035d1..1d15bde91 100644 --- a/src/ocaml/typing/errortrace.mli +++ b/src/ocaml/typing/errortrace.mli @@ -84,13 +84,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 arg_label diff + | Tuple_label_mismatch of string option 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 | Bad_jkind : type_expr * Jkind.Violation.t -> ('a, _) elt diff --git a/src/ocaml/typing/ident.mli b/src/ocaml/typing/ident.mli index 4e4739c09..851493e3a 100644 --- a/src/ocaml/typing/ident.mli +++ b/src/ocaml/typing/ident.mli @@ -59,7 +59,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 is_global: t -> bool val is_global_or_predef: t -> bool diff --git a/src/ocaml/typing/includeclass.ml b/src/ocaml/typing/includeclass.ml index 8448339bf..5c560c156 100644 --- a/src/ocaml/typing/includeclass.ml +++ b/src/ocaml/typing/includeclass.ml @@ -42,6 +42,7 @@ let class_declarations env cty1 cty2 = open Format_doc open Ctype +module Printtyp=Printtyp.Doc (* let rec hide_params = function @@ -58,7 +59,7 @@ 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 + 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") @@ -70,16 +71,16 @@ 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 + 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) -> - Printtyp.report_comparison_error ppf mode 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) -> - Printtyp.report_comparison_error ppf mode 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 -> diff --git a/src/ocaml/typing/includeclass.mli b/src/ocaml/typing/includeclass.mli index 5ba26a888..a4d4d8588 100644 --- a/src/ocaml/typing/includeclass.mli +++ b/src/ocaml/typing/includeclass.mli @@ -29,6 +29,6 @@ val class_declarations: class_match_failure list val report_error : - Printtyp.type_or_scheme -> class_match_failure list Format_doc.format_printer + Out_type.type_or_scheme -> class_match_failure list Format_doc.format_printer val report_error_doc : - Printtyp.type_or_scheme -> class_match_failure list Format_doc.printer + 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 1c83bac5e..2370bbb69 100644 --- a/src/ocaml/typing/includecore.ml +++ b/src/ocaml/typing/includecore.ml @@ -18,6 +18,7 @@ open Asttypes open Path open Types +open Data_types open Mode open Typedtree @@ -64,7 +65,8 @@ type mmodes = let child_close_over_coercion_opt id c = match c with | None -> None - | Some (locks, lid, loc) -> Some (locks, Longident.Ldot (lid, id), loc) + | Some (locks, lid, loc) -> + Some (locks, Longident.Ldot (Location.mkloc lid loc, Location.mknoloc id), loc) let child_modes id = function | All -> All @@ -150,6 +152,27 @@ let primitive_descriptions pd1 pd2 = else native_repr_args pd1.prim_native_repr_args pd2.prim_native_repr_args +(* 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 _, _) -> + (* Here we can not compute a valid coercion, because it may depend on the + local environment of the module, which is not made available in the + consistency check. But the coercion computed by the [*_consistency] + functions is never used, so it's fine. We return [Tcoerce_invalid] so + that if someone ever started using this, they'd get a loud error. *) + Tcoerce_invalid + | (_, Val_prim _) -> raise (Dont_match Not_a_primitive) + | (_, _) -> Tcoerce_none + let moregeneral_lpoly env pat_lpoly subj_lpoly ty1 ty2 = let pat_refs = Ctype.moregeneral env true pat_lpoly subj_lpoly ty1 ty2 @@ -245,13 +268,15 @@ let value_descriptions ~loc env name | Some err -> raise (Dont_match (Primitive_mismatch err)) end | _ -> - let ty1, mode_l1, _, sort1 = Ctype.instance_prim env p1 vd1.val_type in + let ty1, mode_l1, _, sort1 = + Ctype.instance_prim env p1 vd1.val_type + in (try moregeneral_lpoly env val_lpoly1 val_lpoly2 ty1 vd2.val_type with Ctype.Moregen err -> raise (Dont_match (Type err))); let pc = {pc_desc = p1; pc_type = vd2.Types.val_type; pc_poly_mode = Option.map Mode.Locality.disallow_right mode_l1; - pc_poly_sort=sort1; + pc_poly_sort = sort1; pc_env = env; pc_loc = vd1.Types.val_loc; } in Tcoerce_primitive pc end @@ -391,11 +416,13 @@ type jkind_mismatch = | Manifest_missing | Manifest_mismatch +module Printtyp = Printtyp.Doc + let report_modality_sub_error first second ppf e = let Modality.Error (ax, {left; right}) = e in let print_modality id ppf m = Printtyp.modality - ~id:(fun ppf -> Format_doc.pp_print_string ppf id) ax ppf m + ~id:(fun ppf () -> Format_doc.pp_print_string ppf id) ax ppf m in Format_doc.fprintf ppf "%s is %a and %s is %a." (String.capitalize_ascii second) @@ -466,7 +493,7 @@ let report_value_mismatch first second env ppf err = pr "The implementation is not a primitive." | Type trace -> let msg = Fmt.Doc.msg in - Printtyp.report_moregen_error ppf Type_scheme env trace + Errortrace_report.moregen ppf Type_scheme env trace (msg "The type") (msg "is not compatible with the type") | Zero_alloc e -> Zero_alloc.print_error ppf e @@ -505,7 +532,7 @@ let report_value_mismatch first second env ppf err = let report_type_inequality env ppf err = let msg = Fmt.Doc.msg in - Printtyp.report_equality_error ppf Type_scheme env err + Errortrace_report.equality ppf Type_scheme env err (msg "The type") (msg "is not equal to the type") @@ -745,7 +772,6 @@ let report_unsafe_mode_crossing_mismatch first second ppf e = 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." @@ -928,14 +954,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 = @@ -1120,13 +1169,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) @@ -1449,6 +1497,17 @@ let type_manifest env ty1 ty2 priv2 kind2 = their jkinds changed during unification. *) +(* 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 + (* See Note [Contravariance of type parameter jkinds]. *) let type_declarations ?(equality = false) ~loc env ~mark name decl1 path decl2 = @@ -1458,7 +1517,8 @@ 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 = type_declarations_consistency env decl1 decl2 in + if err <> None then err else (* Step 1 from the Note *) let err = match Ctype.equal ~do_jkind_check:false env true @@ -1488,20 +1548,13 @@ let type_declarations ?(equality = false) ~loc env ~mark name "Unification in type_declarations failed, \ but not with Bad_jkind:@;<1 2>%t" (fun ppf -> - Printtyp.report_unification_error ppf env err + Errortrace_report.unification ppf env err (Fmt.doc_printf "The type") (Fmt.doc_printf "does not unify with the type")) end | () -> None in if err <> None then err else - (* Step 5 from the Note *) - let err = - match privacy_mismatch env decl1 decl2 with - | Some err -> Some (Privacy err) - | None -> None - in - if err <> None then err else let err = match (decl1.type_manifest, decl2.type_manifest) with (_, None) -> None | (Some ty1, Some ty2) -> @@ -1606,10 +1659,21 @@ let type_declarations ?(equality = false) ~loc env ~mark name [])))) | All_good -> let abstr = Btype.type_kind_is_abstract decl2 && decl2.type_manifest = None in + (* We need to check coherence of internal and exported variance either + * when the export type is abstract, as there is no manifest to get + the minimal variance from + * when the export type is private, as the private manifest may be + result of expansions within Ctype.equal_private, forgetting + an explicit variance annotation in the internal type + * when the internal type is private, but this is already included + in the above two cases (a private type can only be exported as + abstract or private) + * when the internal type is open, as we do not allow changing the + variance in that case *) + let abstr' = abstr || decl2.type_private = Private in let need_variance = - abstr || decl1.type_private = Private || decl1.type_kind = Type_open in + 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 @@ -1617,10 +1681,13 @@ let type_declarations ?(equality = false) ~loc env ~mark name 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) + (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 + (* Only check the lower bound for abstract types. + For private types, the lower bound can be inferred, and + the internal one may be wrong in the result of functors. *) 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 diff --git a/src/ocaml/typing/includecore.mli b/src/ocaml/typing/includecore.mli index 9c4bdee2b..f98136915 100644 --- a/src/ocaml/typing/includecore.mli +++ b/src/ocaml/typing/includecore.mli @@ -207,6 +207,21 @@ val jkind_declarations: loc:Location.t -> Env.t -> string -> jkind_declaration -> jkind_declaration -> jkind_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 diff --git a/src/ocaml/typing/includemod.mli b/src/ocaml/typing/includemod.mli index ebaef7cd9..3e33b983a 100644 --- a/src/ocaml/typing/includemod.mli +++ b/src/ocaml/typing/includemod.mli @@ -97,13 +97,16 @@ module Error: sig (** One side is a functor but the other side is not *) and functor_params_diff = - (Types.functor_parameter list * Types.module_type, - functor_params_symptom) diff + (functor_params_info, functor_params_symptom) diff (** the return mode of the functor is intentionally omitted, since the diff is only about parameters. *) + and functor_params_info = + { params: functor_parameter list; res: module_type } + and signature_symptom = { env: Env.t; + subst: Subst.t; missings: Types.signature_item list; incompatibles: (Ident.t * sigitem_symptom) list; (** signature items that could not be compared due to type divergence *) @@ -179,11 +182,16 @@ val modtypes: loc:Location.t -> Env.t -> mark:bool -> modes:modes -> module_type -> module_type -> module_coercion +val modtypes_consistency: + loc:Location.t -> Env.t -> module_type -> module_type -> unit + (** [modtypes_constraint ~shape ~loc env ~mark exp_modtype constraint_modtype] checks that [exp_modtype] is a subtype of [constraint_modtype], and returns the module coercion and the shape of the constrained module. + It also marks as used paired items in positive position in [exp_modtype], and also paired items in negative position in [constraint_modtype]. + This marking in negative position allows to raise an [unused item] warning whenever an item in a functor parameter in [constraint_modtype] does not exist in [exp_modtypes]. This behaviour differs from the one in @@ -215,8 +223,8 @@ val signatures: Env.t -> mark:bool -> modes:modes -> val include_functor_signatures : Env.t -> mark:bool -> signature -> signature -> modes:modes -> (Ident.t * module_coercion) list -val check_implementation: Env.t -> modes:modes -> signature -> signature -> unit (** Check an implementation against an interface *) +val check_implementation: Env.t -> modes:modes -> signature -> signature -> unit val compunit: Env.t -> mark:bool -> string -> signature -> @@ -267,7 +275,8 @@ module Functor_inclusion_diff: sig type diff = (Types.functor_parameter, unit) Error.functor_param_symptom type state end - val diff: Env.t -> + type inclusion_env = { i_env:Env.t; i_subst:Subst.t } + val diff: inclusion_env -> Types.functor_parameter list * Types.module_type -> Types.functor_parameter list * Types.module_type -> Diffing.Define(Defs).patch diff --git a/src/ocaml/typing/includemod_errorprinter.ml b/src/ocaml/typing/includemod_errorprinter.ml index a695e8bda..f3969c622 100644 --- a/src/ocaml/typing/includemod_errorprinter.ml +++ b/src/ocaml/typing/includemod_errorprinter.ml @@ -15,6 +15,9 @@ module Style = Misc.Style module Fmt = Format_doc +module Printtyp = Printtyp.Doc +type inclusion_env = Includemod.Functor_inclusion_diff.inclusion_env = + { i_env:Env.t; i_subst:Subst.t } module Context = struct type pos = @@ -40,9 +43,9 @@ module Context = struct Fmt.fprintf ppf "@[<2>module type %a =@ %a@]" Printtyp.ident id context_mty rem | Body x :: rem -> - Fmt.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem + Fmt.fprintf ppf "(%s) ->@ %a" (argname x) context_mty rem | Arg x :: rem -> - Fmt.fprintf ppf "functor (%s : %a) -> ..." + Fmt.fprintf ppf "(%s : %a) -> ..." (argname x) context_mty rem | [] -> Fmt.fprintf ppf "" @@ -68,14 +71,14 @@ module Context = struct let alt_pp ppf cxt = if cxt = [] then () else if List.for_all (function Module _ -> true | _ -> false) cxt then - Fmt.fprintf ppf "in module %t," + Fmt.fprintf ppf ",@ in module %t" (fun ppf -> Fmt.deprecated_printer (fun fmt -> Format.fprintf fmt "%a" (Fmt.compat (Style.as_inline_code Printtyp.path)) (path_of_context cxt) ) ppf) else - Fmt.fprintf ppf "@[at position@ %a,@]" + Fmt.fprintf ppf ",@ @[at position@ %a@]" (Style.as_inline_code context) cxt let pp ppf cxt = @@ -92,9 +95,8 @@ module Context = struct (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}. *) @@ -107,43 +109,53 @@ 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 { pos_cc_list; _ } -> either - (not_fixpoint path 0) pos_cc_list + (first_item_transposition path 0) pos_cc_list (first_non_id path 0) pos_cc_list | 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 + | Tcoerce_invalid -> + Misc.fatal_error + "Includemod_errorprinter.first_change_under: invalid coercion" + (* 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 @@ -180,19 +192,60 @@ module Illegal_permutation = struct (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 + 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 *) 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 @@ -216,7 +269,7 @@ let show_locs ppf (loc1, loc2) = let dmodtype mty = - let tmty = Printtyp.tree_of_modtype ~abbrev:true mty in + let tmty = Out_type.tree_of_modtype ~abbrev:true mty in Fmt.dprintf "%a" !Oprint.out_module_type tmty let space ppf () = Fmt.fprintf ppf "@ " @@ -533,17 +586,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 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 - Printtyp.functor_parameters ~sep elt params + pp_params params let expected ~is_modal d = let extract: _ Diffing.change -> _ = function @@ -713,7 +787,7 @@ module Functor_suberror = struct Fmt.pp_open_tbox () Diffing.prefix (pos, Diffing.classify diff) Fmt.pp_set_tab () - (Printtyp.wrap_printing_env env ~error:true + (Printtyp.wrap_printing_env env.i_env ~error:true (fun () -> sub ~expansion_token env diff) ) Fmt.pp_close_tbox () @@ -721,7 +795,7 @@ module Functor_suberror = struct let onlycase sub ~expansion_token env (_, diff) = Location.msg "%a@[%t@]" Fmt.pp_print_tab () - (Printtyp.wrap_printing_env env ~error:true + (Printtyp.wrap_printing_env env.i_env ~error:true (fun () -> sub ~expansion_token env diff) ) @@ -792,84 +866,77 @@ let core env id x = let mode1, mode2 = maybe_print_modes ~in_structure:true ~is_modal diff.modes in - Fmt.dprintf "@[@[%s:@;<1 2>%a%t@ %s@;<1 2>%a%t@]%a%a%t@]" + Fmt.dprintf "@[@[%s:@;<1 2>%a%t@ %s@;<1 2>%a%t@]%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) mode1 "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) mode2 (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.Modalities e -> Fmt.dprintf "@[%s:@;%a@]" ("Modalities on " ^ (Ident.name id) ^ " do not match") (Includecore.report_modality_sub_error "the first" "the second") e | Err.Type_declarations diff -> - Fmt.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 -> - Fmt.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 -> 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) + (Out_type.tree_of_cltype_declaration id diff.expected Trec_first) (Includeclass.report_error_doc Type_scheme) diff.symptom - Printtyp.Conflicts.print_explanations | Err.Class_declarations {got;expected;symptom=Class_type reason} -> - let t1 = Printtyp.tree_of_class_declaration id got Trec_first in - let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in + 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_doc Type_scheme) reason - Printtyp.Conflicts.print_explanations | Err.Class_declarations {symptom=Class_mode e} -> Fmt.dprintf - "@[Class declarations %s do not match:@ @]@ %a%t" + "@[Class declarations %s do not match:@ @]@ %a" (Ident.name id) (Includecore.report_mode_sub_error "first is" "second is") e - Printtyp.Conflicts.print_explanations | Err.Jkind_declarations diff -> - Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" "Kind declarations do not match" !Oprint.out_sig_item - (Printtyp.tree_of_jkind_declaration id diff.got) + (Out_type.tree_of_jkind_declaration id diff.got) "is not included in" !Oprint.out_sig_item - (Printtyp.tree_of_jkind_declaration id diff.expected) + (Out_type.tree_of_jkind_declaration id diff.expected) (Includecore.report_jkind_mismatch "the first" "the second") diff.symptom show_locs (diff.got.jkind_loc, diff.expected.jkind_loc) - Printtyp.Conflicts.print_explanations let missing_field ppf item = let id, loc, kind = Includemod.item_ident_name item in @@ -885,9 +952,9 @@ let module_types ~env {Err.got=mty1; expected=mty2; modes; symptom}= Fmt.dprintf "@[Modules do not match:@ \ %a%t@;<1 -2>is not included in@ %a%t@]" - !Oprint.out_module_type (Printtyp.tree_of_modtype ~abbrev:true mty1) + !Oprint.out_module_type (Out_type.tree_of_modtype ~abbrev:true mty1) mode1 - !Oprint.out_module_type (Printtyp.tree_of_modtype ~abbrev:true mty2) + !Oprint.out_module_type (Out_type.tree_of_modtype ~abbrev:true mty2) mode2 let eq_module_types ~env ({Err.got=mty1; expected=mty2} : _ mdiff) = @@ -895,15 +962,15 @@ let eq_module_types ~env ({Err.got=mty1; expected=mty2} : _ mdiff) = Fmt.dprintf "@[Module types do not match:@ \ %a@;<1 -2>is not equal to@ %a@]" - !Oprint.out_module_type (Printtyp.tree_of_modtype ~abbrev:true mty1) - !Oprint.out_module_type (Printtyp.tree_of_modtype ~abbrev:true mty2) + !Oprint.out_module_type (Out_type.tree_of_modtype ~abbrev:true mty1) + !Oprint.out_module_type (Out_type.tree_of_modtype ~abbrev:true 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 (Printtyp.tree_of_modtype_declaration ~abbrev:true id d1) - !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration ~abbrev:true id d2) + !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration ~abbrev:true id d1) + !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration ~abbrev:true id d2) let interface_mismatch ppf (diff: _ Err.diff) = Fmt.fprintf ppf @@ -923,10 +990,7 @@ let compilation_unit_mismatch comparison ppf diff = 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(Fmt.dprintf "Unbound module %a" (Style.as_inline_code Printtyp.path) path @@ -934,8 +998,43 @@ let core_module_type_symptom (x:Err.core_module_type_symptom) = (* Construct a linearized error message from the error tree *) +let functor_expected ~before ~ctx = + let main = + (* The abstract module type case is detected by {!Includemod} *) + Fmt.dprintf + "@[This module should not be@ a@ structure,@ \ + a@ functor@ was expected.@]" + in + dwith_context ctx main :: before + +let unexpected_functor ~env ~before ~ctx diff = + let rmty = diff.got.res in + let intro = + match diff.expected.res with + | Mty_ident _ -> + Fmt.dprintf + "@[This module should not be a functor,@ a@ module with an@ \ + abstract@ module@ type@ was@ expected.@]" + | Mty_signature _ | _ -> + Fmt.dprintf + "@[This module should not be a functor,@ a@ structure was expected.@]" + in + let main = + match Includemod.modtypes_consistency ~loc:Location.none env rmty + diff.expected.res with + | _ -> + Fmt.dprintf + "%t@ @{Hint@}: Did you forget to apply the functor?" + intro + | exception _ -> + Fmt.dprintf "%t@ @[Moreover,@ the type of the functor@ body@ is@ \ + incompatible@ with@ the@ expected@ module type.@]" + intro + in + dwith_context ctx main :: before + let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx - (diff : _ mdiff) = + (diff : _ mdiff) = match diff.symptom with | Invalid_module_alias _ (* the difference is non-informative here *) | After_alias_expansion _ (* we print only the expanded module types *) -> @@ -947,7 +1046,11 @@ let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx diff.symptom | _ -> - let inner = if eqmode then eq_module_types ~env else module_types ~env in + let inner = + if eqmode + then eq_module_types ~env:env.i_env + else module_types ~env:env.i_env + in let next = match diff.symptom with | Mt_core _ -> @@ -984,16 +1087,27 @@ and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function in dwith_context ctx printer :: before -and functor_params ~expansion_token ~env ~before ~ctx {got;expected;symptom} = +and functor_params ~expansion_token ~env ~before ~ctx diff = + match diff.got.params, diff.expected.params with + | [], _ -> functor_expected ~before ~ctx + | _, [] -> unexpected_functor ~env:env.i_env ~before ~ctx diff + | _ :: _, _ :: _ -> + compare_functor_params ~expansion_token ~env ~before ~ctx diff + +and compare_functor_params ~expansion_token ~env ~before ~ctx + {got;expected;symptom} = let is_modal = Is_modal.functor_params_symptom symptom in - let d = Functor_suberror.Inclusion.patch env got expected in + let d = Functor_suberror.Inclusion.patch env + (got.params, got.res) + (expected.params, expected.res) + in let actual = Functor_suberror.Inclusion.got ~is_modal d in let expected = Functor_suberror.expected ~is_modal d in let main = 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 @@ -1020,12 +1134,14 @@ and signature ~expansion_token ~env:_ ~before ~ctx sgs = :: before else before - | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a + | [], a :: _ -> + let env = {i_env=sgs.env; i_subst=sgs.subst } in + sigitem ~expansion_token ~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 + dwith_context ctx (core env.i_env name c) :: before | Module_type diff -> module_type ~expansion_token ~eqmode:false ~env ~before ~ctx:(Context.Module name :: ctx) diff @@ -1057,7 +1173,8 @@ 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.i_env) + (mty,c) :: before end @@ -1106,10 +1223,10 @@ let module_type_subst ~env id diff = ~ctx:[Modtype id] mts.less_than | Illegal_permutation c -> let mty = diff.got in - let main = - with_context [Modtype id] - (Illegal_permutation.pp Context.alt_pp env) (mty,c) in - [main] + [with_context [Modtype id] + (Runtime_coercion.illegal_permutation Context.alt_pp env.i_env) + (mty,c) + ] let all env = function | In_Compilation_unit (comparison, diff) -> @@ -1118,9 +1235,9 @@ let all env = function in signature ~expansion_token:true ~env ~before:[first] ~ctx:[] diff.symptom | In_Type_declaration (id,reason) -> - [Location.msg "%t" (core env id reason)] + [Location.msg "%t" (core env.i_env id reason)] | In_Jkind_declaration (id,reason) -> - [Location.msg "%t" (core env id reason)] + [Location.msg "%t" (core env.i_env id reason)] | In_Module_type diff -> module_type ~expansion_token:true ~eqmode:false ~before:[] ~env ~ctx:[] diff @@ -1138,28 +1255,32 @@ let all env = function (* General error reporting *) let err_msgs ppf (env, err) = - Printtyp.Conflicts.reset(); Printtyp.wrap_printing_env ~error:true env - (fun () -> (coalesce @@ all env err) ppf) + (fun () -> (coalesce @@ all {i_env=env; i_subst=Subst.identity} err) ppf) let report_error_doc err = - Location.errorf ~loc:Location.(in_file !input_name) "%a" err_msgs 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 "%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:[] + module_type_symptom ~eqmode:false ~expansion_token:true + ~env:{i_env=env; i_subst=Subst.identity} ~before:[] ~ctx:[] mty_diff.symptom in let is_modal = Is_modal.module_type_symptom mty_diff.symptom in - Location.errorf ~loc "%t" + Location.errorf ~loc ~footnote "%t" (Functor_suberror.App.single_diff ~is_modal g e more) | _ -> let not_functor = @@ -1196,16 +1317,21 @@ let report_apply_error_doc ~loc env (app_name, mty_f, args) = let actual = Functor_suberror.App.got ~is_modal:None d in let expected = Functor_suberror.expected ~is_modal:None d in let sub = + let env = {i_env=env; i_subst=Subst.identity} in 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 diff --git a/src/ocaml/typing/includemod_errorprinter.mli b/src/ocaml/typing/includemod_errorprinter.mli index 080ea1cb2..0c7dda4e5 100644 --- a/src/ocaml/typing/includemod_errorprinter.mli +++ b/src/ocaml/typing/includemod_errorprinter.mli @@ -14,4 +14,6 @@ (**************************************************************************) 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/jkind.ml b/src/ocaml/typing/jkind.ml index 4ce3bbeda..92e1252a2 100644 --- a/src/ocaml/typing/jkind.ml +++ b/src/ocaml/typing/jkind.ml @@ -2450,6 +2450,12 @@ let for_array_element_sort ~level = ( fresh_jkind jkind ~annotation:None ~why:(Concrete_creation Array_element), sort ) +let for_effect_arg ident = + let why : History.value_creation_reason = + Type_argument { parent_path = Path.Pident ident; position = 1; arity = 1 } + in + Builtin.value ~why + (******************************) (* elimination and defaulting *) diff --git a/src/ocaml/typing/jkind.mli b/src/ocaml/typing/jkind.mli index 520ca8eca..64fea361a 100644 --- a/src/ocaml/typing/jkind.mli +++ b/src/ocaml/typing/jkind.mli @@ -527,6 +527,9 @@ val for_abbreviation : (** The jkind for array elements, creating a new sort variable. *) val for_array_element_sort : level:int -> Types.jkind_lr * sort +(** The jkind of the parameter of the [effect] type. *) +val for_effect_arg : Ident.t -> 'd Types.jkind + (******************************) (* elimination and defaulting *) diff --git a/src/ocaml/typing/jkind_intf.ml b/src/ocaml/typing/jkind_intf.ml index f020f34ce..5122ac08e 100644 --- a/src/ocaml/typing/jkind_intf.ml +++ b/src/ocaml/typing/jkind_intf.ml @@ -159,6 +159,10 @@ module type Sort = sig val for_type_extension : t val for_class : t + + val for_effect : t + + val for_continuation : t end module Var : sig diff --git a/src/ocaml/typing/jkind_types.ml b/src/ocaml/typing/jkind_types.ml index ae398025c..f99d0d06c 100644 --- a/src/ocaml/typing/jkind_types.ml +++ b/src/ocaml/typing/jkind_types.ml @@ -308,6 +308,10 @@ module Sort = struct let for_type_extension = scannable let for_class = scannable + + let for_effect = scannable + + let for_continuation = scannable end module Var = struct diff --git a/src/ocaml/typing/oprint.ml b/src/ocaml/typing/oprint.ml index eade23015..d18a40d32 100644 --- a/src/ocaml/typing/oprint.ml +++ b/src/ocaml/typing/oprint.ml @@ -41,28 +41,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 @@ -145,16 +126,6 @@ let escape_string s = Bytes.to_string s' end -let rec 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 - let print_label_type ppf = function | Some s -> @@ -212,6 +183,9 @@ let print_constr ppf name = (* despite being keywords, these are constructor names and should not be escaped *) fprintf ppf "%s" c + | Oide_dot (id, ("true"|"false" as s)) -> + (* Similarly, M.true is invalid *) + fprintf ppf "%a.(%s)" print_ident id s | _ -> print_ident ppf name let print_out_value ppf tree = @@ -291,10 +265,19 @@ let print_out_value ppf tree = | Oval_ellipsis -> raise Ellipsis | Oval_printer f -> f ppf | Oval_tuple tree_list -> - fprintf ppf "@[<1>(%a)@]" (print_labeled_tree_list print_tree_1 ",") tree_list + let print_elem ppf (lbl, item) = + print_label ppf lbl; print_tree_1 ppf item + in + fprintf ppf "@[<1>(%a)@]" (print_tree_list print_elem ",") tree_list | Oval_unboxed_tuple tree_list -> - fprintf ppf "@[<1>#(%a)@]" (print_labeled_tree_list print_tree_1 ",") - tree_list + let print_elem ppf (lbl, item) = + print_label ppf lbl; print_tree_1 ppf item + in + fprintf ppf "@[<1>#(%a)@]" (print_tree_list print_elem ",") tree_list + | Oval_floatarray arr -> + fprintf ppf "@[<2>[|%a|]@]" + (pp_print_seq ~pp_sep:semicolon pp_print_float) + (Float.Array.to_seq arr) | Oval_code e -> deprecated_printer (fun fmt -> CamlinternalQuote.Code.print fmt e) ppf | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree @@ -306,7 +289,8 @@ let print_out_value ppf tree = 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 = + and print_tree_list : 'a . (_ -> 'a -> _) -> _ -> _ -> 'a list -> unit = + fun print_item sep ppf tree_list -> let rec print_list first ppf = function [] -> () @@ -316,17 +300,6 @@ let print_out_value ppf tree = print_list false ppf tree_list in cautious (print_list true) ppf tree_list - and print_labeled_tree_list print_item sep ppf labeled_tree_list = - let rec print_list first ppf = - function - [] -> () - | (label, tree) :: labeled_tree_list -> - if not first then fprintf ppf "%s@ " sep; - print_label ppf label; - print_item ppf tree; - print_list false ppf labeled_tree_list - in - cautious (print_list true) ppf labeled_tree_list in cautious print_tree_1 ppf tree @@ -367,12 +340,6 @@ let print_out_modes ppf l = | _ -> pp_print_string ppf " @ "); pp_print_list ~pp_sep:pp_print_space print_out_mode ppf l -(* Labeled tuples with the first element labeled sometimes require parens. *) -let is_initially_labeled_tuple ty = - match ty with - | Otyp_tuple ((Some _, _) :: _) -> true - | _ -> false - let print_out_modality = pp_print_string let print_out_modalities ppf l = @@ -418,19 +385,8 @@ let rec print_out_type_0 ppf = | ty -> print_out_type_1 ppf ty -(* We must parenthesize a labeled tuple with the first element labeled when: - - It is an argument to a function ([~arg]) - - Or, there is at least one mode to print. - *) and print_out_type_mode ~arg mode ppf ty = - let parens = - is_initially_labeled_tuple ty && arg - in - if parens then - pp_print_char ppf '('; - print_out_type_2 ppf ty; - if parens then - pp_print_char ppf ')'; + print_out_type_2 ~arg ppf ty; print_out_modes ppf mode and print_out_type_1 ppf = @@ -442,7 +398,7 @@ and print_out_type_1 ppf = pp_print_space ppf (); print_out_ret ppf ty2; pp_close_box ppf () - | ty -> print_out_type_2 ppf ty + | ty -> print_out_type_2 ~arg:false ppf ty and print_out_arg am ppf ty = print_out_type_mode ~arg:true am ppf ty @@ -462,13 +418,27 @@ and print_out_ret ppf = | Otyp_ret (Orm_any rm, ty) -> print_out_type_mode ~arg:false rm ppf ty | _ -> assert false -and print_out_type_2 ppf = +and print_out_type_2 ~arg ppf = function - | Otyp_tuple tyl -> - fprintf - ppf "@[<0>%a@]" (print_labeled_typlist print_simple_out_type " *") tyl - | ty -> print_out_type_3 ppf ty -and print_out_type_3 ppf = + Otyp_tuple tyl -> + (* Tuples require parens in argument function argument position (~arg) + when the first element has a label. *) + let parens = + match tyl with + | (Some _, _) :: _ -> arg + | _ -> false + in + if parens then pp_print_char ppf '('; + let print_elem ppf (label, ty) = + pp_open_box ppf 0; + print_label_type ppf label; + print_simple_out_type ppf ty; + pp_close_box ppf () + in + fprintf ppf "@[<0>%a@]" (print_typlist print_elem " *") tyl; + if parens then pp_print_char ppf ')' + | 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 @@ -521,16 +491,8 @@ and print_out_type_3 ppf = | Otyp_sum _ | Otyp_manifest (_, _) -> () | Otyp_record lbls -> print_record_decl ~unboxed:false ppf lbls | Otyp_record_unboxed_product lbls -> print_record_decl ~unboxed:true 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_module pack -> + fprintf ppf "@[<1>(module %a)@]" print_package pack | Otyp_attribute (t, attr) -> fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type_0 t attr.oattr_name @@ -545,8 +507,15 @@ and print_out_type_3 ppf = | Otyp_splice t -> fprintf ppf "@[<1>$@,(%a)@]" print_out_type_0 t and print_out_type ppf typ = print_out_type_0 ppf typ -and print_simple_out_type ppf typ = - print_out_type_3 ppf typ +and print_package ppf pack = + fprintf ppf "%a" print_ident pack.opack_path; + 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 + ) + pack.opack_cstrs and print_record_decl ~unboxed ppf lbls = let hash = if unboxed then "#" else "" in fprintf ppf "%s{%a@;<1 -2>}" @@ -570,6 +539,16 @@ and print_row_field ppf (l, opt_amp, tyl) = fprintf ppf "@[`%a%t%a@]" print_lident l pr_of (print_typlist print_out_type " &") tyl +and print_typlist : 'a . (_ -> 'a -> _) -> _ -> _ -> 'a list -> _ = + fun print_elem sep ppf tyl -> + match tyl with + [] -> () + | [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 [] -> () @@ -581,23 +560,24 @@ and print_typargs ppf = pp_print_char ppf ')'; pp_close_box ppf (); pp_print_space ppf () -and print_out_label ppf (name, mut, arg, gbl) = +and print_out_label ppf + { olab_name; olab_mut; olab_type; olab_modalities } = (* See the notes [NON-LEGACY MODES] *) let mut, atomic = - match mut with + match olab_mut with | Om_immutable -> "", Nonatomic | Om_mutable (None, atomic) -> "mutable ", atomic | Om_mutable (Some s, atomic) -> "mutable(" ^ s ^ ") ", atomic in - let print_atomic ppf atomic = match atomic with + let print_atomic ppf = function | Nonatomic -> () | Atomic -> fprintf ppf " [@@atomic]" in fprintf ppf "@[<2>%s%a :@ %a%a%a@];" mut - print_lident name - print_out_type arg - print_out_modalities gbl + print_lident olab_name + print_out_type olab_type + print_out_modalities olab_modalities print_atomic atomic and print_out_jkind_const ppf ojkind = @@ -736,7 +716,11 @@ let type_parameter ~in_parens ppf | _ -> format_string in fprintf ppf format_string - (match var with Covariant -> "+" | Contravariant -> "-" | NoVariance -> "") + (match var with + | Covariant -> "+" + | Contravariant -> "-" + | NoVariance -> "" + | Bivariant -> "+-") (match inj with Injective -> "!" | NoInjectivity -> "") (print_type_parameter ~non_gen) ty print_out_jkind_annot lay @@ -761,7 +745,7 @@ let rec print_out_class_type ppf = in fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id | Octy_arrow (lab, ty, cty) -> - let print_type = print_out_type_2 in + let print_type = print_out_type_2 ~arg:true in fprintf ppf "@[%t ->@ %a@]" (fun ppf -> print_arg_label_and_out_type ppf lab ty ~print_type) print_out_class_type cty diff --git a/src/ocaml/typing/oprint.mli b/src/ocaml/typing/oprint.mli index 85218e793..e6ac3dd35 100644 --- a/src/ocaml/typing/oprint.mli +++ b/src/ocaml/typing/oprint.mli @@ -20,7 +20,7 @@ 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 : (string * out_mutability * out_type * out_modality list) printer +val out_label : out_label printer val out_modality : out_modality printer val out_modes : out_mode list printer val out_jkind_const : out_jkind_const printer diff --git a/src/ocaml/typing/outcometree.mli b/src/ocaml/typing/outcometree.mli index 6c91a95bf..ed66ed2d2 100644 --- a/src/ocaml/typing/outcometree.mli +++ b/src/ocaml/typing/outcometree.mli @@ -63,6 +63,7 @@ type out_value = | Oval_variant of string * out_value option | Oval_lazy of out_value | Oval_code of CamlinternalQuote.Code.t + | Oval_floatarray of floatarray type out_modality = string @@ -74,8 +75,6 @@ type out_mutability = | Om_immutable | Om_mutable of string option * out_atomicity - - (** This definition avoids a cyclic dependency between Outcometree and Types. *) type arg_label = | Nolabel @@ -134,11 +133,8 @@ and 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 * out_mutability * out_type * out_modality list) list - | Otyp_record_unboxed_product of - (string * out_mutability * out_type * out_modality list) list - (* INVARIANT: [out_mutability] is included for uniformity with [Otyp_record], - but it is always [Omm_immutable] *) + | Otyp_record of out_label list + | Otyp_record_unboxed_product of out_label list | Otyp_stuff of string | Otyp_sum of out_constructor list | Otyp_tuple of (string option * out_type) list @@ -150,7 +146,7 @@ and out_type = | Otyp_poly of out_vars_jkinds * out_type | Otyp_repr of string list * out_type | Otyp_newlayout of out_sort_genvar list * out_type - | Otyp_module of out_ident * (string * out_type) list + | Otyp_module of out_package | Otyp_attribute of out_type * out_attribute | Otyp_jkind_annot of out_type * out_jkind (* Currently only introduced with very explicit code in [Printtyp] and not @@ -159,12 +155,24 @@ and out_type = | Otyp_ret of out_ret_mode * out_type (** INVARIANT: See [out_ret_mode]. *) +and out_label = { + olab_name: string; + olab_mut: out_mutability; + olab_type: out_type; + olab_modalities: out_modality list; +} + and out_constructor = { ocstr_name: string; ocstr_args: (out_type * out_modality list) list; ocstr_return_type: (out_vars_jkinds * out_type) option; } +and out_package = { + opack_path: out_ident; + opack_cstrs: (string * out_type) list; +} + and out_variant = | Ovar_fields of (string * bool * out_type list) list | Ovar_typ of out_type diff --git a/src/ocaml/typing/parmatch.ml b/src/ocaml/typing/parmatch.ml index 2a303ef87..e74b58e4d 100644 --- a/src/ocaml/typing/parmatch.ml +++ b/src/ocaml/typing/parmatch.ml @@ -18,6 +18,7 @@ open Misc open Asttypes open Types +open Data_types open Typedtree type error = Float32_match @@ -348,8 +349,8 @@ let records_args l1 l2 = module Compat (Constr:sig val equal : - Types.constructor_description -> - Types.constructor_description -> + Data_types.constructor_description -> + Data_types.constructor_description -> bool end) = struct @@ -412,12 +413,13 @@ module Compat Option.equal String.equal p_label q_label && compat p q && unboxed_tuple_compat labeled_ps labeled_qs | _,_ -> false + end module SyntacticCompat = Compat (struct - let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag + let equal = Data_types.equal_constr end) let compat = SyntacticCompat.compat @@ -452,7 +454,7 @@ 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 + Data_types.equal_constr c1 c2 | Variant { tag = t1; _ }, Variant { tag = t2 } -> t1 = t2 | Constant c1, Constant c2 -> const_compare c1 c2 = 0 @@ -613,13 +615,11 @@ 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 -| {pat_desc = Tpat_tuple omegas} -> - let args,rest = read_args (List.map snd omegas) r in - make_pat - (Tpat_tuple - (List.map2 (fun (lbl, _) arg -> lbl, arg) omegas args)) - q.pat_type q.pat_env::rest +let set_args q r = match q with +| {pat_desc = Tpat_tuple lbls_omegas} -> + let lbls, omegas = List.split lbls_omegas in + let args, rest = read_args omegas r in + make_pat (Tpat_tuple (List.combine lbls args)) q.pat_type q.pat_env :: rest | {pat_desc = Tpat_unboxed_tuple omegas} -> let args,rest = read_args (List.map (fun (_, pat, _) -> pat) omegas) r @@ -627,33 +627,18 @@ let do_set_args ~erase_mutable q r = match q with make_pat (Tpat_unboxed_tuple (List.map2 (fun (lbl, _, sort) arg -> lbl, arg, sort) omegas args)) - q.pat_type q.pat_env::rest + 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 && Types.is_mutable lbl.lbl_mut - 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_record_unboxed_product (omegas,closed)} -> let args,rest = read_args omegas r in - make_pat - (Tpat_record_unboxed_product - (List.map2 (fun (lid, lbl,_) arg -> - if Types.is_mutable lbl.lbl_mut then - fatal_error - "Parmatch.do_set_args: unboxed record labels are never mutable" - 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_unboxed_product (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 @@ -678,19 +663,14 @@ let do_set_args ~erase_mutable q r = match q with end | {pat_desc = Tpat_array (am, arg_sort, omegas)} -> let args,rest = read_args omegas r in - let args = if erase_mutable then omegas else args in make_pat - (Tpat_array (am, arg_sort, args)) q.pat_type q.pat_env:: - rest + (Tpat_array (am, arg_sort, args)) q.pat_type q.pat_env :: rest | {pat_desc=Tpat_constant _|Tpat_any|Tpat_unboxed_unit|Tpat_unboxed_bool _} -> q::r (* case any is used in matching.ml *) | {pat_desc = (Tpat_var _ | Tpat_fun_layout _ | 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... @@ -1501,8 +1481,8 @@ let print_pat pat = Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) | Tpat_variant (_, _, _) -> "variant" | Tpat_record (_, _) -> "record" - | Tpat_array _ -> "array" - | Tpat_immutable_array _ -> "immutable array" + | Tpat_array (Mutable, _) -> "array" + | Tpat_array (Immutable, _) -> "immutable array" in Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) *) @@ -1935,7 +1915,7 @@ let rec le_pat p q = | _, Tpat_alias { pattern = 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 + Data_types.equal_constr c1 c2 && 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,_) -> @@ -2009,7 +1989,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with 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 -> + when Data_types.equal_constr c1 c2 -> let rs = lubs ps1 ps2 in make_pat (Tpat_construct (lid, c1, rs, None)) p.pat_type p.pat_env @@ -2022,8 +2002,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with 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 + make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env | Tpat_array (am1, arg_sort, ps), Tpat_array (am2, _, qs) when am1 = am2 && List.length ps = List.length qs -> let rs = lubs ps qs in @@ -2161,27 +2140,27 @@ let do_check_partial ~pred loc casel pss = match pss with match counter_examples () with | Seq.Nil -> Total | 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.Compat.pretty_pat v; + if Warnings.is_active (Warnings.Partial_match Format_doc.Doc.empty) then + begin + let errmsg = + let doc = ref Format_doc.Doc.empty in + let fmt = Format_doc.formatter doc in + Format_doc.fprintf fmt "@[%a" + (Misc.Style.as_inline_code Printpat.top_pretty) v; if do_match (initial_only_guarded casel) [v] then - Buffer.add_string buf - "\n(However, some guarded clause may match this value.)"; + Format_doc.fprintf fmt + "@,(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." + 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.@]" ; - Buffer.contents buf - with _ -> - "" - in - Location.prerr_warning loc (Warnings.Partial_match errmsg) - end; + Format_doc.fprintf fmt "@]"; + !doc + in + Location.prerr_warning loc (Warnings.Partial_match errmsg) + end; Partial (*****************) diff --git a/src/ocaml/typing/parmatch.mli b/src/ocaml/typing/parmatch.mli index 868e20405..acb049c13 100644 --- a/src/ocaml/typing/parmatch.mli +++ b/src/ocaml/typing/parmatch.mli @@ -18,6 +18,7 @@ open Asttypes open Typedtree open Types +open Data_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 @@ -55,8 +56,8 @@ module Compat : functor (_ : sig val equal : - Types.constructor_description -> - Types.constructor_description -> + Data_types.constructor_description -> + Data_types.constructor_description -> bool end) -> sig val compat : pattern -> pattern -> bool @@ -75,13 +76,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 dda19ce59..96b71328b 100644 --- a/src/ocaml/typing/path.ml +++ b/src/ocaml/typing/path.ml @@ -160,6 +160,10 @@ let flatten = in fun t -> flatten [] t +let rec scrape_extra_ty = function + | Pextra_ty (t, _) -> scrape_extra_ty t + | t -> t + let heads p = let rec heads p acc = match p with | Pident id -> id :: acc diff --git a/src/ocaml/typing/path.mli b/src/ocaml/typing/path.mli index b62ae3f2e..e9a05d495 100644 --- a/src/ocaml/typing/path.mli +++ b/src/ocaml/typing/path.mli @@ -73,6 +73,9 @@ val exists_free: Ident.t list -> t -> bool val scope: t -> int val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ] +val scrape_extra_ty: t -> t +(** Removes surrounding `Pext_ty` constructors from a path *) + val name: ?paren:(string -> bool) -> t -> string (* [paren] tells whether a path suffix needs parentheses *) val head: t -> Ident.t diff --git a/src/ocaml/typing/patterns.ml b/src/ocaml/typing/patterns.ml index 05fdb413c..69de86d35 100644 --- a/src/ocaml/typing/patterns.ml +++ b/src/ocaml/typing/patterns.ml @@ -16,6 +16,7 @@ open Asttypes open Types +open Data_types open Typedtree (* useful pattern auxiliary functions *) diff --git a/src/ocaml/typing/patterns.mli b/src/ocaml/typing/patterns.mli index ffa0ce531..4090273eb 100644 --- a/src/ocaml/typing/patterns.mli +++ b/src/ocaml/typing/patterns.mli @@ -17,6 +17,7 @@ open Asttypes open Typedtree open Types +open Data_types val omega : pattern (** aka. "Tpat_any" or "_" *) diff --git a/src/ocaml/typing/predef.ml b/src/ocaml/typing/predef.ml index 955d1455c..a93ca3228 100644 --- a/src/ocaml/typing/predef.ml +++ b/src/ocaml/typing/predef.ml @@ -38,6 +38,143 @@ let wrap create s = in `lambda.ml`). *) let ident_create = wrap Ident.create_predef +type abstract_type_constr = [ + | `Int + | `Char + | `String + | `Bytes + | `Float + | `Continuation + | `Array + | `Nativeint + | `Int32 + | `Int64 + | `Lazy_t + | `Extension_constructor + | `Floatarray + | `Iarray + | `Atomic_loc + | `Lexing_position + | `Code + | `Float32 + | `Int8 + | `Int16 +] +type abstract_non_value_type_constr = [ + | `Idx_imm + | `Idx_mut + | `Int8x16 + | `Int16x8 + | `Int32x4 + | `Int64x2 + | `Float16x8 + | `Float32x4 + | `Float64x2 + | `Int8x32 + | `Int16x16 + | `Int32x8 + | `Int64x4 + | `Float16x16 + | `Float32x8 + | `Float64x4 + | `Int8x64 + | `Int16x32 + | `Int32x16 + | `Int64x8 + | `Float16x32 + | `Float32x16 + | `Float64x8 +] +type data_type_constr = [ + | `Bool + | `Unit + | `Exn + | `Eff + | `List + | `Option + | `Or_null +] +type type_constr = [ + | abstract_type_constr + | abstract_non_value_type_constr + | data_type_constr +] + +let base_type_constrs : type_constr list = [ + `Int; + `Char; + `String; + `Bytes; + `Float; + `Bool; + `Unit; + `Exn; + `Eff; + `Continuation; + `Array; + `List; + `Option; + `Nativeint; + `Int32; + `Int64; + `Lazy_t; + `Extension_constructor; + `Floatarray; + `Iarray; + `Atomic_loc; + `Lexing_position; + `Idx_imm; + `Idx_mut; +] + +let or_null_extension_type_constrs : type_constr list = [ + `Or_null; +] + +let simd_stable_extension_type_constrs : type_constr list = [ + `Int8x16; + `Int16x8; + `Int32x4; + `Int64x2; + `Float16x8; + `Float32x4; + `Float64x2; + `Int8x32; + `Int16x16; + `Int32x8; + `Int64x4; + `Float16x16; + `Float32x8; + `Float64x4; +] + +let simd_beta_extension_type_constrs : type_constr list = [] + +let simd_alpha_extension_type_constrs : type_constr list = [ + `Int8x64; + `Int16x32; + `Int32x16; + `Int64x8; + `Float16x32; + `Float32x16; + `Float64x8; +] + +let small_number_extension_type_constrs : type_constr list = [ + `Float32; + `Int8; + `Int16; +] + +let all_type_constrs = ( + base_type_constrs + @ or_null_extension_type_constrs + @ small_number_extension_type_constrs + @ simd_stable_extension_type_constrs + @ simd_beta_extension_type_constrs + @ simd_alpha_extension_type_constrs +) + let ident_int = ident_create "int" and ident_char = ident_create "char" and ident_bytes = ident_create "bytes" @@ -46,8 +183,9 @@ and ident_float32 = ident_create "float32" 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_iarray = ident_create "iarray" and ident_list = ident_create "list" and ident_option = ident_create "option" and ident_nativeint = ident_create "nativeint" @@ -59,8 +197,9 @@ 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" -and ident_lexing_position = ident_create "lexing_position" +and ident_iarray = ident_create "iarray" and ident_atomic_loc = ident_create "atomic_loc" +and ident_lexing_position = ident_create "lexing_position" (* CR metaprogramming aivaskovic: there is a question about naming; keep `expr` for now instead of `code` *) and ident_code = ident_create "expr" @@ -92,6 +231,58 @@ and ident_float16x32 = ident_create "float16x32" and ident_float32x16 = ident_create "float32x16" and ident_float64x8 = ident_create "float64x8" +let ident_of_type_constr : type_constr -> Ident.t = function + | `Int -> ident_int + | `Char -> ident_char + | `String -> ident_string + | `Bytes -> ident_bytes + | `Float -> ident_float + | `Bool -> ident_bool + | `Unit -> ident_unit + | `Exn -> ident_exn + | `Eff -> ident_eff + | `Continuation -> ident_continuation + | `Array -> ident_array + | `List -> ident_list + | `Option -> ident_option + | `Nativeint -> ident_nativeint + | `Int32 -> ident_int32 + | `Int64 -> ident_int64 + | `Lazy_t -> ident_lazy_t + | `Extension_constructor -> ident_extension_constructor + | `Floatarray -> ident_floatarray + | `Iarray -> ident_iarray + | `Atomic_loc -> ident_atomic_loc + | `Lexing_position -> ident_lexing_position + | `Code -> ident_code + | `Float32 -> ident_float32 + | `Int8 -> ident_int8 + | `Int16 -> ident_int16 + | `Idx_imm -> ident_idx_imm + | `Idx_mut -> ident_idx_mut + | `Int8x16 -> ident_int8x16 + | `Int16x8 -> ident_int16x8 + | `Int32x4 -> ident_int32x4 + | `Int64x2 -> ident_int64x2 + | `Float16x8 -> ident_float16x8 + | `Float32x4 -> ident_float32x4 + | `Float64x2 -> ident_float64x2 + | `Int8x32 -> ident_int8x32 + | `Int16x16 -> ident_int16x16 + | `Int32x8 -> ident_int32x8 + | `Int64x4 -> ident_int64x4 + | `Float16x16 -> ident_float16x16 + | `Float32x8 -> ident_float32x8 + | `Float64x4 -> ident_float64x4 + | `Int8x64 -> ident_int8x64 + | `Int16x32 -> ident_int16x32 + | `Int32x16 -> ident_int32x16 + | `Int64x8 -> ident_int64x8 + | `Float16x32 -> ident_float16x32 + | `Float32x16 -> ident_float32x16 + | `Float64x8 -> ident_float64x8 + | `Or_null -> ident_or_null + let path_int = Pident ident_int and path_char = Pident ident_char and path_bytes = Pident ident_bytes @@ -100,8 +291,9 @@ and path_float32 = Pident ident_float32 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_iarray = Pident ident_iarray and path_list = Pident ident_list and path_option = Pident ident_option and path_nativeint = Pident ident_nativeint @@ -113,10 +305,11 @@ 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 +and path_iarray = Pident ident_iarray +and path_atomic_loc = Pident ident_atomic_loc and path_lexing_position = Pident ident_lexing_position and path_idx_imm = Pident ident_idx_imm and path_idx_mut = Pident ident_idx_mut -and path_atomic_loc = Pident ident_atomic_loc and path_code = Pident ident_code and path_eval = Pident ident_eval @@ -178,113 +371,104 @@ and path_unboxed_float16x32 = Path.unboxed_version path_float16x32 and path_unboxed_float32x16 = Path.unboxed_version path_float32x16 and path_unboxed_float64x8 = Path.unboxed_version path_float64x8 -let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) -and type_int8 = newgenty (Tconstr(path_int8, [], ref Mnil)) -and type_int16 = newgenty (Tconstr(path_int16, [], 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_float32 = newgenty (Tconstr(path_float32, [], 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_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) -and type_iarray t = newgenty (Tconstr(path_iarray, [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)) -and type_lexing_position = newgenty (Tconstr(path_lexing_position, [], ref Mnil)) -and type_atomic_loc t = newgenty (Tconstr(path_atomic_loc, [t], ref Mnil)) -and type_code t = newgenty (Tconstr(path_code, [t], ref Mnil)) +let path_of_type_constr typ = + Pident (ident_of_type_constr typ) + +let tconstr p args = newgenty (Tconstr(p, args, ref Mnil)) +let type_int = tconstr path_int [] +and type_int8 = tconstr path_int8 [] +and type_int16 = tconstr path_int16 [] +and type_char = tconstr path_char [] +and type_bytes = tconstr path_bytes [] +and type_float = tconstr path_float [] +and type_float32 = tconstr path_float32 [] +and type_bool = tconstr path_bool [] +and type_unit = tconstr path_unit [] +and type_exn = tconstr path_exn [] +and type_eff t = tconstr path_eff [t] +and type_continuation t1 t2 = tconstr path_continuation [t1; t2] +and type_array t = tconstr path_array [t] +and type_list t = tconstr path_list [t] +and type_option t = tconstr path_option [t] +and type_nativeint = tconstr path_nativeint [] +and type_int32 = tconstr path_int32 [] +and type_int64 = tconstr path_int64 [] +and type_lazy_t t = tconstr path_lazy_t [t] +and type_string = tconstr path_string [] +and type_extension_constructor = tconstr path_extension_constructor [] +and type_floatarray = tconstr path_floatarray [] +and type_iarray t = tconstr path_iarray [t] +and type_atomic_loc t = tconstr path_atomic_loc [t] +and type_lexing_position = tconstr path_lexing_position [] +and type_code t = tconstr path_code [t] and type_eval t = newgenty (Tquote_eval (newgenty (Tsplice t))) -and type_unboxed_unit = newgenty (Tconstr(path_unboxed_unit, [], ref Mnil)) -and type_unboxed_bool = newgenty (Tconstr(path_unboxed_bool, [], ref Mnil)) -and type_unboxed_float = newgenty (Tconstr(path_unboxed_float, [], ref Mnil)) -and type_unboxed_float32 = newgenty (Tconstr(path_unboxed_float32, [], ref Mnil)) -and type_unboxed_nativeint = - newgenty (Tconstr(path_unboxed_nativeint, [], ref Mnil)) -and type_unboxed_int32 = newgenty (Tconstr(path_unboxed_int32, [], ref Mnil)) -and type_unboxed_int64 = newgenty (Tconstr(path_unboxed_int64, [], ref Mnil)) -and type_unboxed_char = newgenty (Tconstr(path_unboxed_char, [], ref Mnil)) -and type_unboxed_int = newgenty (Tconstr(path_unboxed_int, [], ref Mnil)) -and type_unboxed_int8 = newgenty (Tconstr(path_unboxed_int8, [], ref Mnil)) -and type_unboxed_int16 = newgenty (Tconstr(path_unboxed_int16, [], ref Mnil)) -and type_or_null t = newgenty (Tconstr(path_or_null, [t], ref Mnil)) -and type_idx_imm t1 t2 = newgenty (Tconstr(path_idx_imm, [t1; t2], ref Mnil)) -and type_idx_mut t1 t2 = newgenty (Tconstr(path_idx_mut, [t1; t2], ref Mnil)) - -and type_int8x16 = newgenty (Tconstr(path_int8x16, [], ref Mnil)) -and type_int16x8 = newgenty (Tconstr(path_int16x8, [], ref Mnil)) -and type_int32x4 = newgenty (Tconstr(path_int32x4, [], ref Mnil)) -and type_int64x2 = newgenty (Tconstr(path_int64x2, [], ref Mnil)) -and type_float16x8 = newgenty (Tconstr(path_float16x8, [], ref Mnil)) -and type_float32x4 = newgenty (Tconstr(path_float32x4, [], ref Mnil)) -and type_float64x2 = newgenty (Tconstr(path_float64x2, [], ref Mnil)) -and type_int8x32 = newgenty (Tconstr(path_int8x32, [], ref Mnil)) -and type_int16x16 = newgenty (Tconstr(path_int16x16, [], ref Mnil)) -and type_int32x8 = newgenty (Tconstr(path_int32x8, [], ref Mnil)) -and type_int64x4 = newgenty (Tconstr(path_int64x4, [], ref Mnil)) -and type_float16x16 = newgenty (Tconstr(path_float16x16, [], ref Mnil)) -and type_float32x8 = newgenty (Tconstr(path_float32x8, [], ref Mnil)) -and type_float64x4 = newgenty (Tconstr(path_float64x4, [], ref Mnil)) -and type_int8x64 = newgenty (Tconstr(path_int8x64, [], ref Mnil)) -and type_int16x32 = newgenty (Tconstr(path_int16x32, [], ref Mnil)) -and type_int32x16 = newgenty (Tconstr(path_int32x16, [], ref Mnil)) -and type_int64x8 = newgenty (Tconstr(path_int64x8, [], ref Mnil)) -and type_float16x32 = newgenty (Tconstr(path_float16x32, [], ref Mnil)) -and type_float32x16 = newgenty (Tconstr(path_float32x16, [], ref Mnil)) -and type_float64x8 = newgenty (Tconstr(path_float64x8, [], ref Mnil)) - -and type_unboxed_int8x16 = - newgenty (Tconstr(path_unboxed_int8x16, [], ref Mnil)) -and type_unboxed_int16x8 = - newgenty (Tconstr(path_unboxed_int16x8, [], ref Mnil)) -and type_unboxed_int32x4 = - newgenty (Tconstr(path_unboxed_int32x4, [], ref Mnil)) -and type_unboxed_int64x2 = - newgenty (Tconstr(path_unboxed_int64x2, [], ref Mnil)) -and type_unboxed_float16x8 = - newgenty (Tconstr(path_unboxed_float16x8, [], ref Mnil)) -and type_unboxed_float32x4 = - newgenty (Tconstr(path_unboxed_float32x4, [], ref Mnil)) -and type_unboxed_float64x2 = - newgenty (Tconstr(path_unboxed_float64x2, [], ref Mnil)) -and type_unboxed_int8x32 = - newgenty (Tconstr(path_unboxed_int8x32, [], ref Mnil)) -and type_unboxed_int16x16 = - newgenty (Tconstr(path_unboxed_int16x16, [], ref Mnil)) -and type_unboxed_int32x8 = - newgenty (Tconstr(path_unboxed_int32x8, [], ref Mnil)) -and type_unboxed_int64x4 = - newgenty (Tconstr(path_unboxed_int64x4, [], ref Mnil)) -and type_unboxed_float16x16 = - newgenty (Tconstr(path_unboxed_float16x16, [], ref Mnil)) -and type_unboxed_float32x8 = - newgenty (Tconstr(path_unboxed_float32x8, [], ref Mnil)) -and type_unboxed_float64x4 = - newgenty (Tconstr(path_unboxed_float64x4, [], ref Mnil)) -and type_unboxed_int8x64 = - newgenty (Tconstr(path_unboxed_int8x64, [], ref Mnil)) -and type_unboxed_int16x32 = - newgenty (Tconstr(path_unboxed_int16x32, [], ref Mnil)) -and type_unboxed_int32x16 = - newgenty (Tconstr(path_unboxed_int32x16, [], ref Mnil)) -and type_unboxed_int64x8 = - newgenty (Tconstr(path_unboxed_int64x8, [], ref Mnil)) -and type_unboxed_float16x32 = - newgenty (Tconstr(path_unboxed_float16x32, [], ref Mnil)) -and type_unboxed_float32x16 = - newgenty (Tconstr(path_unboxed_float32x16, [], ref Mnil)) -and type_unboxed_float64x8 = - newgenty (Tconstr(path_unboxed_float64x8, [], ref Mnil)) +and type_unboxed_unit = tconstr path_unboxed_unit [] +and type_unboxed_bool = tconstr path_unboxed_bool [] +and type_unboxed_float = tconstr path_unboxed_float [] +and type_unboxed_float32 = tconstr path_unboxed_float32 [] +and type_unboxed_nativeint = tconstr path_unboxed_nativeint [] +and type_unboxed_int32 = tconstr path_unboxed_int32 [] +and type_unboxed_int64 = tconstr path_unboxed_int64 [] +and type_unboxed_char = tconstr path_unboxed_char [] +and type_unboxed_int = tconstr path_unboxed_int [] +and type_unboxed_int8 = tconstr path_unboxed_int8 [] +and type_unboxed_int16 = tconstr path_unboxed_int16 [] +and type_or_null t = tconstr path_or_null [t] +and type_idx_imm t1 t2 = tconstr path_idx_imm [t1; t2] +and type_idx_mut t1 t2 = tconstr path_idx_mut [t1; t2] + +and type_int8x16 = tconstr path_int8x16 [] +and type_int16x8 = tconstr path_int16x8 [] +and type_int32x4 = tconstr path_int32x4 [] +and type_int64x2 = tconstr path_int64x2 [] +and type_float16x8 = tconstr path_float16x8 [] +and type_float32x4 = tconstr path_float32x4 [] +and type_float64x2 = tconstr path_float64x2 [] +and type_int8x32 = tconstr path_int8x32 [] +and type_int16x16 = tconstr path_int16x16 [] +and type_int32x8 = tconstr path_int32x8 [] +and type_int64x4 = tconstr path_int64x4 [] +and type_float16x16 = tconstr path_float16x16 [] +and type_float32x8 = tconstr path_float32x8 [] +and type_float64x4 = tconstr path_float64x4 [] +and type_int8x64 = tconstr path_int8x64 [] +and type_int16x32 = tconstr path_int16x32 [] +and type_int32x16 = tconstr path_int32x16 [] +and type_int64x8 = tconstr path_int64x8 [] +and type_float16x32 = tconstr path_float16x32 [] +and type_float32x16 = tconstr path_float32x16 [] +and type_float64x8 = tconstr path_float64x8 [] + +and type_unboxed_int8x16 = tconstr path_unboxed_int8x16 [] +and type_unboxed_int16x8 = tconstr path_unboxed_int16x8 [] +and type_unboxed_int32x4 = tconstr path_unboxed_int32x4 [] +and type_unboxed_int64x2 = tconstr path_unboxed_int64x2 [] +and type_unboxed_float16x8 = tconstr path_unboxed_float16x8 [] +and type_unboxed_float32x4 = tconstr path_unboxed_float32x4 [] +and type_unboxed_float64x2 = tconstr path_unboxed_float64x2 [] +and type_unboxed_int8x32 = tconstr path_unboxed_int8x32 [] +and type_unboxed_int16x16 = tconstr path_unboxed_int16x16 [] +and type_unboxed_int32x8 = tconstr path_unboxed_int32x8 [] +and type_unboxed_int64x4 = tconstr path_unboxed_int64x4 [] +and type_unboxed_float16x16 = tconstr path_unboxed_float16x16 [] +and type_unboxed_float32x8 = tconstr path_unboxed_float32x8 [] +and type_unboxed_float64x4 = tconstr path_unboxed_float64x4 [] +and type_unboxed_int8x64 = tconstr path_unboxed_int8x64 [] +and type_unboxed_int16x32 = tconstr path_unboxed_int16x32 [] +and type_unboxed_int32x16 = tconstr path_unboxed_int32x16 [] +and type_unboxed_int64x8 = tconstr path_unboxed_int64x8 [] +and type_unboxed_float16x32 = tconstr path_unboxed_float16x32 [] +and type_unboxed_float32x16 = tconstr path_unboxed_float32x16 [] +and type_unboxed_float64x8 = tconstr path_unboxed_float64x8 [] + +let find_type_constr = + let all_predef_paths = + all_type_constrs + |> List.map (fun tconstr -> path_of_type_constr tconstr, tconstr) + |> Path.Map.of_list + in + fun p -> Path.Map.find_opt p all_predef_paths let ident_match_failure = ident_create "Match_failure" and ident_out_of_memory = ident_create "Out_of_memory" @@ -300,6 +484,7 @@ 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; @@ -315,6 +500,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 @@ -322,16 +508,6 @@ and path_invalid_argument = Pident ident_invalid_argument 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 "()" @@ -347,6 +523,24 @@ let option_argument_sort = Jkind_types.Sort.Const.scannable let option_argument_jkind = Jkind.Builtin.value_or_null ~why:( Type_argument {parent_path = path_option; position = 1; arity = 1}) +let unrestricted tvar ca_sort = + { + ca_type=tvar; + ca_sort; + ca_modalities=Mode.Modality.Const.id; + ca_loc=Location.none + } + +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 list_jkind param = Jkind.Builtin.immutable_data ~why:Boxed_variant |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param |> @@ -379,14 +573,30 @@ let add_predef_jkinds add_jkind env = List.fold_left (fun env (id, jkind) -> add_jkind id jkind env) env predef_jkinds -let mk_add_type add_type = - let add_type_with_jkind - ?manifest type_ident - ?(kind=Type_abstract Definition) - ~jkind - ?unboxed_jkind - env = - let type_uid = Uid.of_predef_id type_ident in + +let or_null_argument_sort = Jkind_types.Sort.Const.scannable + +let or_null_jkind param = + Jkind.Const.Builtin.value_or_null_mod_everything + |> Jkind.of_builtin ~why:(Primitive ident_or_null) + |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param + |> Jkind.mark_best + +let or_null_kind tvar = + let cstrs = + [ cstr ident_null []; + cstr ident_this [unrestricted tvar or_null_argument_sort]] in + Type_variant (cstrs, Variant_with_null, None) + +let decl_of_type_constr tconstr = + let type_ident = ident_of_type_constr tconstr in + let type_uid = Uid.of_predef_id type_ident in + let decl0 + ?(kind = Type_abstract Definition) + ~(jkind : jkind_l) + ?(unboxed_jkind : Jkind.Const.Builtin.t option) + () + = let type_unboxed_version = match unboxed_jkind with | None -> None | Some unboxed_jkind -> @@ -399,12 +609,6 @@ let mk_add_type add_type = abstract, as they are special cased. Other unboxed versions are automatically derived. *) let type_kind = Type_abstract Definition in - let type_manifest = - match manifest with - | None -> None - | Some _ -> - Misc.fatal_error "Predef.mk_add_type: non-[None] unboxed manifest" - in Some { type_params = []; type_arity = 0; @@ -413,7 +617,7 @@ let mk_add_type add_type = type_ikind; type_loc = Location.none; type_private = Asttypes.Public; - type_manifest; + type_manifest = None; type_variance = []; type_separability = []; type_is_newtype = false; @@ -426,282 +630,244 @@ let mk_add_type add_type = in let type_jkind = Jkind.mark_best jkind in let type_ikind = ikind_of_jkind ~params:[] type_jkind in - let decl = - {type_params = []; - type_arity = 0; - type_kind = kind; - type_jkind; - type_ikind; - 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_unboxed_default = false; - type_uid; - type_unboxed_version; - } - in - add_type type_ident decl env - in - let add_type ?manifest type_ident ?kind ~jkind ?unboxed_jkind env = - let jkind = Jkind.of_builtin ~why:(Primitive type_ident) jkind in - add_type_with_jkind ?manifest type_ident ?kind ~jkind ?unboxed_jkind env + {type_params = []; + type_arity = 0; + type_kind = kind; + type_jkind; + type_ikind; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_unboxed_default = false; + type_uid; + type_unboxed_version; + } in - add_type_with_jkind, add_type - -let mk_add_type1 add_type type_ident - ?manifest - ?(kind=fun _ -> Type_abstract Definition) + let decl1 + ~variance + ~(param_jkind : jkind_lr) ~jkind - ?(param_jkind=Jkind.Builtin.value ~why:( - Type_argument { - parent_path = Path.Pident type_ident; - position = 1; - arity = 1} - )) - ~variance ~separability env = - let param = newgenvar param_jkind in - let type_jkind = Jkind.mark_best (jkind param) in - let type_ikind = ikind_of_jkind ~params:[param] type_jkind in - let decl = - {type_params = [param]; + ?(separability = Separability.Ind) + ?(kind = fun _ -> Type_abstract Definition) + () + = + let param = newgenvar param_jkind in + let base = decl0 ~jkind:(jkind param) ~kind:(kind param) () in + { base with + type_params = [param]; type_arity = 1; - type_kind = kind param; - type_jkind; - type_ikind; - type_loc = Location.none; - type_private = Asttypes.Public; - type_manifest = Option.map (fun f -> f param) manifest; + type_ikind = ikind_of_jkind ~params:[param] base.type_jkind; type_variance = [variance]; type_separability = [separability]; - type_is_newtype = false; - type_expansion_scope = lowest_level; - type_attributes = []; - type_unboxed_default = false; - type_uid = Uid.of_predef_id type_ident; - type_unboxed_version = None; } in - add_type type_ident decl env - -let mk_add_type2 add_type type_ident ~jkind ~param1_jkind ~param2_jkind - ~type_variance ~type_separability env = - let param1 = newgenvar param1_jkind in - let param2 = newgenvar param2_jkind in - let type_jkind = Jkind.mark_best jkind in - let type_ikind = ikind_of_jkind ~params:[param1; param2] type_jkind in - let decl = - { type_params = [param1; param2]; + let decl2 + ~variance:(var1, var2) + ~param_jkinds:(param_jkind1, param_jkind2) + ~jkind + ?separability:((sep1, sep2) = (Separability.Ind, Separability.Ind)) + ?(kind = fun _ _ -> Type_abstract Definition) + () + = + let param1, param2 = newgenvar param_jkind1, newgenvar param_jkind2 in + let base = + decl0 ~kind:(kind param1 param2) ~jkind:(jkind param1 param2) () + in + { base with + type_params = [param1; param2]; type_arity = 2; - type_kind = Type_abstract Definition; - type_jkind; - type_ikind; - type_loc = Location.none; - type_private = Asttypes.Public; - type_manifest = None; - type_variance; - type_separability; - type_is_newtype = false; - type_expansion_scope = lowest_level; - type_attributes = []; - type_unboxed_default = false; - type_uid = Uid.of_predef_id type_ident; - type_unboxed_version = None; + type_ikind = ikind_of_jkind ~params:[param1; param2] base.type_jkind; + type_variance = [var1; var2]; + type_separability = [sep1; sep2]; } in - add_type type_ident decl env - -let mk_add_extension add_extension id args = - List.iter (fun (_, sort) -> - let raise_error () = Misc.fatal_error - "sanity check failed: non-value jkind in predef extension \ - constructor; should this have Constructor_mixed shape?" in - match (sort : Jkind_types.Sort.Const.t) with - | Base Scannable -> () - | Base (Void | Untagged_immediate | Float32 | Float64 | Word | Bits8 | - Bits16 | Bits32 | Bits64 | Vec128 | Vec256 | Vec512) - | Univar _ | Genvar _ | Product _ -> raise_error ()) - args; - add_extension id - { ext_type_path = path_exn; - ext_type_params = []; - ext_args = - Cstr_tuple - (List.map - (fun (ca_type, ca_sort) -> - { - ca_type; - ca_sort; - ca_modalities=Mode.Modality.Const.id; - ca_loc=Location.none - }) - args); - ext_shape = Constructor_uniform_value; - ext_constant = args = []; - 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; - } - -let mk_add_jkind add_jkind = - let add_jkind id jkind env = - let decl = - { jkind_manifest = Some jkind; - jkind_attributes = []; - jkind_uid = Uid.of_predef_id id; - jkind_loc = Location.none } + let variant constrs = + let mk_elt { cd_args } = + let sorts = match cd_args with + | Cstr_tuple args -> + Misc.Stdlib.Array.of_list_map (fun { ca_sort } -> ca_sort) args + | Cstr_record lbls -> + Misc.Stdlib.Array.of_list_map (fun { ld_sort } -> ld_sort) lbls + in + Constructor_uniform_value, sorts in - add_jkind id decl env + Type_variant ( + constrs, + Variant_boxed (Misc.Stdlib.Array.of_list_map mk_elt constrs), + None) in - add_jkind - -let variant constrs = - let mk_elt { cd_args } = - let sorts = match cd_args with - | Cstr_tuple args -> - Misc.Stdlib.Array.of_list_map (fun { ca_sort } -> ca_sort) args - | Cstr_record lbls -> - Misc.Stdlib.Array.of_list_map (fun { ld_sort } -> ld_sort) lbls - in - Constructor_uniform_value, sorts + let builtin jkind = Jkind.of_builtin ~why:(Primitive type_ident) jkind in + let builtin1 jkind _param1 = builtin jkind in + let builtin2 jkind _param1 _param2 = builtin jkind in + let value_param_jkind = + Jkind.Builtin.value ~why:( + Type_argument { + parent_path = Path.Pident type_ident; + position = 1; + arity = 1}) in - Type_variant ( - constrs, - Variant_boxed (Misc.Stdlib.Array.of_list_map mk_elt constrs), - None) - -let unrestricted tvar ca_sort = - {ca_type=tvar; - ca_sort; - ca_modalities=Mode.Modality.Const.id; - ca_loc=Location.none} - -(* CR layouts: Changes will be needed here as we add support for the built-ins - to work with non-values, and as we relax the mixed block restriction. *) -let build_initial_env add_type add_extension add_jkind empty_env = - let add_type_with_jkind, add_type = mk_add_type add_type - and add_type1 = mk_add_type1 add_type - and add_type2 = mk_add_type2 add_type - and add_extension = mk_add_extension add_extension - and add_jkind = mk_add_jkind add_jkind + let value_params_jkind_2 = ( + Jkind.Builtin.value + ~why:(Type_argument {parent_path = Path.Pident type_ident; + position = 1; arity = 2}), + Jkind.Builtin.value + ~why:(Type_argument {parent_path = Path.Pident type_ident; + position = 2; arity = 2})) in - empty_env - (* Predefined types *) - |> add_type1 ident_array - ~variance:Variance.full - ~separability:Separability.Ind - ~param_jkind:Jkind.for_array_argument + match tconstr with + | `Int -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_untagged_int () + | `Char -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int8 () + | `String -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) () + | `Bytes -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.mutable_data) () + | `Float -> + decl0 + ~jkind:(Jkind.for_float ident_float) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_float + () + | `Floatarray -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.mutable_data) () + | `Nativeint -> + decl0 + ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_nativeint + () + | `Int32 -> + decl0 + ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int32 + () + | `Int64 -> + decl0 + ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int64 + () + | `Extension_constructor -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) () + | `Bool -> + let kind = variant [cstr ident_false []; + cstr ident_true []] in + decl0 ~kind + ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_bool + () + | `Unit -> + let kind = variant [cstr ident_void []] in + decl0 ~kind + ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_unit + () + | `Exn -> decl0 ~kind:Type_open ~jkind:(builtin Jkind.Const.Builtin.exn) () + | `Eff -> + let kind _ = Type_open in + decl1 ~variance:Variance.full ~kind + ~jkind:(builtin1 Jkind.Const.Builtin.value) + ~param_jkind:(Jkind.for_effect_arg ident_eff) + () + | `Continuation -> + let variance = Variance.(contravariant, covariant) in + decl2 ~variance ~param_jkinds:value_params_jkind_2 + ~jkind:(builtin2 Jkind.Const.Builtin.value) () + | `Array -> + decl1 ~variance:Variance.full ~param_jkind:Jkind.for_array_argument ~jkind:(fun param -> Jkind.Builtin.mutable_data ~why:(Primitive ident_array) |> + Jkind.add_with_bounds + ~modality:Mode.Modality.Const.id + ~type_expr:param) () + | `Atomic_loc + -> + decl1 ~variance:Variance.full + ~param_jkind:( + Jkind.Builtin.value_or_null ~why:(Primitive ident_atomic_loc)) + ~jkind:(fun param -> + Jkind.Builtin.sync_data ~why:(Primitive ident_atomic_loc) |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param) - |> add_type1 ident_iarray - ~variance:Variance.covariant - ~separability:Separability.Ind + () + | `Iarray -> + decl1 ~variance:Variance.covariant ~param_jkind:Jkind.for_array_argument ~jkind:(fun param -> Jkind.Builtin.immutable_data ~why:(Primitive ident_iarray) |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param) - |> add_type ident_bool - ~kind:(variant [ cstr ident_false []; cstr ident_true []]) - ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_bool - |> add_type ident_char ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int8 - |> add_type ident_exn ~kind:Type_open ~jkind:Jkind.Const.Builtin.exn - |> add_type ident_extension_constructor - ~jkind:Jkind.Const.Builtin.immutable_data - |> add_type_with_jkind ident_float ~jkind:(Jkind.for_float ident_float) - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_float - |> add_type ident_floatarray ~jkind:Jkind.Const.Builtin.mutable_data - |> add_type ident_int - ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_untagged_int - |> add_type ident_int32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int32 - |> add_type ident_int64 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int64 - |> add_type1 ident_lazy_t - ~variance:Variance.covariant - ~separability:Separability.Ind - (* CR layouts v2.8: Can [lazy_t] mode-cross at all? According to Zesen: - It can at least cross locality, because it's always heap-allocated. - It might also cross portability, linearity, uniqueness subject to its - parameter. But I'm also fine not doing that for now (and wait until - users complains). Internal ticket 5103. *) - ~jkind:(fun _ -> Jkind.for_non_float ~why:(Primitive ident_lazy_t)) - |> add_type1 ident_list - ~variance:Variance.covariant - ~separability:Separability.Ind - ~kind:(fun tvar -> - variant [cstr ident_nil []; - cstr ident_cons [unrestricted tvar list_argument_sort; - unrestricted (type_list tvar) list_sort]]) + () + | `List -> + let kind tvar = + variant [cstr ident_nil []; + cstr ident_cons [unrestricted tvar list_argument_sort; + unrestricted (type_list tvar) list_sort]] in + decl1 ~variance:Variance.covariant ~kind ~param_jkind:list_argument_jkind ~jkind:list_jkind - |> add_type ident_nativeint - ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_nativeint - |> add_type1 ident_option - ~variance:Variance.covariant - ~separability:Separability.Ind - ~kind:(fun tvar -> - variant [cstr ident_none []; - cstr ident_some [unrestricted tvar option_argument_sort]]) + () + | `Option -> + let kind tvar = + variant [cstr ident_none []; + cstr ident_some [unrestricted tvar option_argument_sort]] in + decl1 ~variance:Variance.covariant ~kind ~param_jkind:option_argument_jkind ~jkind:(fun param -> Jkind.Builtin.immutable_data ~why:Boxed_variant |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param) - |> add_type2 ident_idx_imm - ~param1_jkind:( + () + | `Lazy_t -> + decl1 ~variance:Variance.covariant + (* CR layouts v2.8: Can [lazy_t] mode-cross at all? According to Zesen: + It can at least cross locality, because it's always heap-allocated. + It might also cross portability, linearity, uniqueness subject to its + parameter. But I'm also fine not doing that for now (and wait until + users complains). Internal ticket 5103. *) + ~param_jkind:value_param_jkind + ~jkind:(fun _ -> Jkind.for_non_float ~why:(Primitive ident_lazy_t)) + () + | `Idx_imm -> + decl2 ~variance:(Variance.full, Variance.covariant) + ~param_jkinds:( Jkind.Builtin.value_or_null ~why:(Type_argument { parent_path = Path.Pident ident_idx_imm; position = 1; arity = 2; - })) - ~param2_jkind:( + }), Jkind.Builtin.any ~why:(Type_argument { parent_path = Path.Pident ident_idx_imm; position = 2; arity = 2; })) - ~jkind:( - Jkind.of_builtin ~why:(Primitive ident_idx_imm) - Jkind.Const.Builtin.kind_of_idx) - ~type_variance:[Variance.full; Variance.covariant] - ~type_separability:[Separability.Ind; Separability.Ind] - |> add_type2 ident_idx_mut - ~param1_jkind:( + ~jkind:(builtin2 Jkind.Const.Builtin.kind_of_idx) + () + | `Idx_mut -> + decl2 ~variance:(Variance.full, Variance.full) + ~param_jkinds:( Jkind.Builtin.value_or_null ~why:(Type_argument { parent_path = Path.Pident ident_idx_mut; position = 1; arity = 2; - })) - ~param2_jkind:( + }), Jkind.Builtin.any ~why:(Type_argument { parent_path = Path.Pident ident_idx_mut; position = 2; arity = 2; })) - ~jkind:( - Jkind.of_builtin ~why:(Primitive ident_idx_mut) - Jkind.Const.Builtin.kind_of_idx) - ~type_variance:[Variance.full; Variance.full] - ~type_separability:[Separability.Ind; Separability.Ind] - |> add_type_with_jkind ident_lexing_position + ~jkind:(builtin2 Jkind.Const.Builtin.kind_of_idx) + () + | `Lexing_position -> + decl0 ~kind:( let lbl (field, field_type) = let id = Ident.create_predef field in @@ -733,23 +899,169 @@ let build_initial_env add_type add_extension add_jkind empty_env = constructor lookups when deriving ikinds from jkinds. *) ~jkind:Jkind.( of_builtin Const.Builtin.immutable_data - ~why:(Primitive ident_lexing_position)) - |> add_type1 ident_atomic_loc - ~variance:Variance.full + ~why:(Primitive ident_lexing_position) |> + add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:type_int |> + add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:type_int |> + add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:type_int |> + add_with_bounds ~modality:Mode.Modality.Const.id + ~type_expr:type_string) + () + | `Code -> + decl1 + ~variance:Variance.covariant ~separability:Separability.Ind ~param_jkind:( - Jkind.Builtin.value_or_null ~why:(Primitive ident_atomic_loc)) + Jkind.Builtin.any ~why:(Type_argument { + parent_path = Path.Pident type_ident; + position = 1; + arity = 1; + })) ~jkind:(fun param -> - Jkind.Builtin.sync_data ~why:(Primitive ident_atomic_loc) |> - Jkind.add_with_bounds - ~modality:Mode.Modality.Const.id - ~type_expr:param) - |> add_type ident_string ~jkind:Jkind.Const.Builtin.immutable_data - |> add_type ident_bytes ~jkind:Jkind.Const.Builtin.mutable_data - |> add_type ident_unit - ~kind:(variant [cstr ident_void []]) - ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_unit + Jkind.for_expr |> + Jkind.add_with_bounds + ~modality:Mode.Modality.Const.id + ~type_expr:param) + () + | `Int8x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Int16x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Int32x4 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Int64x2 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Float16x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Float32x4 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Float64x2 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Int8x32 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Int16x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Int32x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Int64x4 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Float16x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Float32x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Float64x4 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Int8x64 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Int16x32 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Int32x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Int64x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Float16x32 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Float32x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Float64x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Float32 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_float32 () + | `Int8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int8 () + | `Int16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int16 () + | `Or_null -> + decl1 + ~variance:Variance.covariant + (* CR layouts v3: [or_null] is separable only if the argument type + is non-float. The current separability system can't track that. + We also want to allow [float or_null] despite it being non-separable. + + For now, we mark the type argument as [Separability.Ind] to permit + the most argument types, and forbid arrays from accepting [or_null]s. + In the future, we will track separability in the jkind system. *) + ~kind:or_null_kind + ~param_jkind:(Jkind.for_or_null_argument ident_or_null) + ~jkind:or_null_jkind + () + +let mk_add_jkind add_jkind = + let add_jkind id jkind env = + let decl = + { jkind_manifest = Some jkind; + jkind_attributes = []; + jkind_uid = Uid.of_predef_id id; + jkind_loc = Location.none } + in + add_jkind id decl env + in + add_jkind + +let build_initial_env add_type add_extension add_jkind empty_env = + let add_jkind = mk_add_jkind add_jkind in + let add_extension id l = + List.iter (fun (_, sort) -> + let raise_error () = Misc.fatal_error + "sanity check failed: non-value jkind in predef extension \ + constructor; should this have Constructor_mixed shape?" in + match (sort : Jkind_types.Sort.Const.t) with + | Base Scannable -> () + | Base (Void | Untagged_immediate | Float32 | Float64 | Word | Bits8 | + Bits16 | Bits32 | Bits64 | Vec128 | Vec256 | Vec512) + | Univar _ | Genvar _ | Product _ -> raise_error ()) + l; + add_extension id + { ext_type_path = path_exn; + ext_type_params = []; + ext_args = + Cstr_tuple + (List.map + (fun (ca_type, ca_sort) -> + { + ca_type; + ca_sort; + ca_modalities=Mode.Modality.Const.id; + ca_loc=Location.none + }) + l); + ext_shape = Constructor_uniform_value; + ext_constant = 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 + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) empty_env base_type_constrs (* Predefined exceptions - alphabetical order *) |> add_extension ident_assert_failure [newgenty (Ttuple[None, type_string; None, type_int; None, type_int]), @@ -773,138 +1085,65 @@ let build_initial_env add_type add_extension add_jkind empty_env = |> add_extension ident_undefined_recursive_module [newgenty (Ttuple[None, type_string; None, type_int; None, type_int]), Jkind_types.Sort.Const.scannable] + |> add_extension ident_continuation_already_taken [] (* Predefined jkinds *) |> add_predef_jkinds add_jkind +let add_or_null add_type env = + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) env or_null_extension_type_constrs + let add_simd_stable_extension_types add_type env = - let _, add_type = mk_add_type add_type in - env - |> add_type ident_int8x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_int16x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_int32x4 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_int64x2 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_float16x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_float32x4 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_float64x2 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_int8x32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_int16x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_int32x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_int64x4 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_float16x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_float32x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_float64x4 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) env simd_stable_extension_type_constrs let add_simd_beta_extension_types _add_type env = env let add_simd_alpha_extension_types add_type env = - let _, add_type = mk_add_type add_type in - env - |> add_type ident_int8x64 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_int16x32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_int32x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_int64x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_float16x32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_float32x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_float64x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) env simd_alpha_extension_type_constrs let add_small_number_extension_types add_type env = - let _, add_type = mk_add_type add_type in - env - |> add_type ident_float32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_float32 - |> add_type ident_int8 ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int8 - |> add_type ident_int16 ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int16 - -let add_small_number_beta_extension_types _add_type env = - env + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) env small_number_extension_type_constrs -let or_null_argument_sort = Jkind_types.Sort.Const.scannable - -let or_null_kind tvar = - let cstrs = - [ cstr ident_null []; - cstr ident_this [unrestricted tvar or_null_argument_sort]] - in - Type_variant (cstrs, Variant_with_null, None) - -let or_null_jkind param = - Jkind.Const.Builtin.value_or_null_mod_everything - |> Jkind.of_builtin ~why:(Primitive ident_or_null) - |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param - |> Jkind.mark_best - -let add_or_null add_type env = - let add_type1 = mk_add_type1 add_type in - env - |> add_type1 ident_or_null - ~variance:Variance.covariant - ~separability:Separability.Ind - (* CR layouts v3: [or_null] is separable only if the argument type - is non-float. The current separability system can't track that. - We also want to allow [float or_null] despite it being non-separable. - - For now, we mark the type argument as [Separability.Ind] to permit - the most argument types, and forbid arrays from accepting [or_null]s. - In the future, we will track separability in the jkind system. *) - ~kind:or_null_kind - ~param_jkind:(Jkind.for_or_null_argument ident_or_null) - ~jkind:or_null_jkind +let add_small_number_beta_extension_types _add_type env = env let add_runtime_metaprogramming_types add_type env = - let add_type1 = mk_add_type1 add_type in - env - |> add_type1 ident_code - ~variance:Variance.covariant - ~separability:Separability.Ind - ~jkind:(fun param -> - Jkind.for_expr |> - Jkind.add_with_bounds - ~modality:Mode.Modality.Const.id - ~type_expr:param) - ~param_jkind:( - Jkind.Builtin.any ~why:(Type_argument { - parent_path = Path.Pident ident_code; - position = 1; - arity = 1; - })) - |> add_type1 ident_eval - ~variance:Variance.covariant - ~separability:Separability.Ind - ~manifest:type_eval - ~jkind:(fun param -> - Jkind.Builtin.any ~why:Evaluated_quote |> - Jkind.add_with_bounds - ~modality:Mode.Modality.Const.id - ~type_expr:param) - ~param_jkind:( - Jkind.Builtin.any ~why:(Type_argument { - parent_path = Path.Pident ident_eval; - position = 1; - arity = 1; - })) + let env = add_type ident_code (decl_of_type_constr `Code) env in + let param = newgenvar ( + Jkind.Builtin.any ~why:(Type_argument { + parent_path = Path.Pident ident_eval; + position = 1; arity = 1 })) + in + let type_jkind = Jkind.mark_best ( + Jkind.Builtin.any ~why:Evaluated_quote |> + Jkind.add_with_bounds + ~modality:Mode.Modality.Const.id ~type_expr:param) + in + let type_ikind = ikind_of_jkind ~params:[param] type_jkind in + add_type ident_eval { + type_params = [param]; + type_arity = 1; + type_kind = Type_abstract Definition; + type_jkind; + type_ikind; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = Some (type_eval param); + type_variance = [Variance.covariant]; + type_separability = [Separability.Ind]; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_unboxed_default = false; + type_uid = Uid.of_predef_id ident_eval; + type_unboxed_version = None; + } env let builtin_values = List.map (fun id -> (Ident.name id, id)) all_predef_exns diff --git a/src/ocaml/typing/printpat.ml b/src/ocaml/typing/printpat.ml index a4a198f34..b409897f0 100644 --- a/src/ocaml/typing/printpat.ml +++ b/src/ocaml/typing/printpat.ml @@ -17,7 +17,7 @@ open Asttypes open Typedtree -open Types +open Data_types open Format_doc (* Merlin-specific: change some module paths to match the compiler *) diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml index acfa6a3e3..bf0b889a4 100644 --- a/src/ocaml/typing/shape.ml +++ b/src/ocaml/typing/shape.ml @@ -868,7 +868,6 @@ let rec print fmt t = | At_layout (shape, layout) -> Format.fprintf fmt "(%a : %a)" print_nested shape (Format_doc.compat Layout.format) layout - in if t.approximated then Format.fprintf fmt "@[(approx)@ %a@]@;" aux t @@ -1118,7 +1117,6 @@ let at_layout ?uid shape layout = hash = Hashtbl.hash (hash_at_layout, uid, shape.hash, layout); approximated = false } - let decompose_abs t = match t.desc with | Abs (x, t) -> Some (x, t) @@ -1129,36 +1127,29 @@ let dummy_mod = str Item.Map.empty let of_path ~find_shape ~namespace path = (* We need to handle the following cases: Path of constructor: - M.t.C + M.t.C [Pextra_ty("M.t", "C")] Path of label: - M.t.lbl + M.t.lbl [Pextra_ty("M.t", "lbl")] Path of label of inline record: - M.t.C.lbl + M.t.C.lbl [Pextra_ty(Pextra_ty("M.t", "C"), "lbl")] Path of label of implicit unboxed record: - M.t#.lbl - *) + M.t#.lbl [Pextra_ty(Pextra_ty("M.t", Punboxed_ty), "lbl")] *) let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function | Pident id -> find_shape ns id - | Pdot (Pextra_ty (path, Punboxed_ty), name) -> - (match ns with - Unboxed_label -> () - | _ -> Misc.fatal_error "Shape.of_path"); - proj (aux Type path) (name, Label) - | Pdot (path, name) -> - let namespace : Sig_component_kind.t = - match (ns : Sig_component_kind.t) with - | Constructor -> Type - | Label -> Type - | Unboxed_label -> Type - | _ -> Module - in - proj (aux namespace path) (name, ns) + | Pdot (path, name) -> proj (aux Module 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 - | Punboxed_ty -> aux ns path + match extra, ns, path with + | Pcstr_ty name, Label, Pextra_ty _ -> + (* Handle the M.t.C.lbl case *) + proj (aux Constructor path) (name, ns) + | Pcstr_ty name, Unboxed_label, Pextra_ty (path', Punboxed_ty) -> + (* Implicit-unboxed view of a boxed record: labels are stored in + the underlying boxed type's shape under the Label namespace. *) + proj (aux Type path') (name, Label) + | Pcstr_ty name, _, _ -> proj (aux Type path) (name, ns) + | Pext_ty, _, _ -> aux Extension_constructor path + | Punboxed_ty, _, _ -> aux ns path end in aux namespace path diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli index 223fed169..5700fdd6d 100644 --- a/src/ocaml/typing/shape.mli +++ b/src/ocaml/typing/shape.mli @@ -60,10 +60,7 @@ type base_layout = Jkind_types.Sort.base module Uid : sig type t = private | Compilation_unit of string - | Item of { - comp_unit: string; - id: int; - from: Unit_info.intf_or_impl } + | Item of { comp_unit: string; id: int; from: Unit_info.intf_or_impl } | Internal | Predef of string | Unboxed_version of t @@ -73,7 +70,7 @@ module Uid : sig val restore_stamp : int -> unit val stamp_of_uid : t -> int option - val mk : current_unit:Unit_info.t option -> t + val mk : current_unit:(Unit_info.t option) -> t val of_compilation_unit_id : Compilation_unit.t -> t val of_compilation_unit_name : Compilation_unit.Name.t -> t val of_predef_id : Ident.t -> t diff --git a/src/ocaml/typing/shape_reduce.ml b/src/ocaml/typing/shape_reduce.ml index c9676f996..d76a15383 100644 --- a/src/ocaml/typing/shape_reduce.ml +++ b/src/ocaml/typing/shape_reduce.ml @@ -35,18 +35,18 @@ type result = let rec print_result fmt result = match result with | Resolved uid -> - Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid + Format.fprintf fmt "@[Resolved:@ %a@]" Uid.print uid | Resolved_alias (uid, r) -> - Format.fprintf fmt "@[Alias: %a -> %a@]@;" + Format.fprintf fmt "@[Alias:@ %a@] ->@ %a" Uid.print uid print_result r | Unresolved shape -> - Format.fprintf fmt "@[Unresolved: %a@]@;" print shape + Format.fprintf fmt "@[Unresolved:@ %a@]" print shape | Approximated (Some uid) -> - Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid + Format.fprintf fmt "@[Approximated:@ %a@]" Uid.print uid | Approximated None -> - Format.fprintf fmt "@[Approximated: No uid@]@;" + Format.fprintf fmt "Approximated: No uid" | Internal_error_missing_uid -> - Format.fprintf fmt "@[Missing uid@]@;" + Format.fprintf fmt "Missing uid" module Diagnostics = struct type diagnostics = diff --git a/src/ocaml/typing/stypes.ml b/src/ocaml/typing/stypes.ml index bdc4b02fe..2e5d51af9 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; | _ -> () @@ -149,8 +149,7 @@ let print_info pp prev_loc ti = Format.pp_print_string Format.str_formatter " "; Printtyp.wrap_printing_env ~error:false env (fun () -> - Format_doc.compat Printtyp.shared_type_scheme Format.str_formatter - typ + Printtyp.shared_type_scheme Format.str_formatter typ ); Format.pp_print_newline Format.str_formatter (); let s = Format.flush_str_formatter () in diff --git a/src/ocaml/typing/subst.ml b/src/ocaml/typing/subst.ml index 9280c76f5..a83fde60a 100644 --- a/src/ocaml/typing/subst.ml +++ b/src/ocaml/typing/subst.ml @@ -594,9 +594,12 @@ let rec typexp copy_scope s ty = | 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) + | Tpackage {pack_path; pack_cstrs} -> + Tpackage { + pack_path = modtype_path s pack_path; + pack_cstrs = + List.map (fun (n, ty) -> (n, typexp copy_scope s ty)) pack_cstrs; + } | Tobject (t1, name) -> let t1' = typexp copy_scope s t1 in let name' = diff --git a/src/ocaml/typing/type_shape.ml b/src/ocaml/typing/type_shape.ml index f7931334a..39901be13 100644 --- a/src/ocaml/typing/type_shape.ml +++ b/src/ocaml/typing/type_shape.ml @@ -326,7 +326,7 @@ module Type_shape = struct | Tvariant _ | Tunivar _ | Tpoly (_, _) | Trepr (_, _) - | Tpackage (_, _) + | Tpackage _ | Tquote _ | Tsplice _ | Tquote_eval _ | Tof_kind _ -> assert false in diff --git a/src/ocaml/typing/typedecl.mli b/src/ocaml/typing/typedecl.mli index ed4fcee06..c997dfa82 100644 --- a/src/ocaml/typing/typedecl.mli +++ b/src/ocaml/typing/typedecl.mli @@ -226,5 +226,4 @@ type error = exception Error of Location.t * error -val report_error: error Format_doc.format_printer -val report_error_doc: error Format_doc.printer +val report_error: loc:Location.t -> error -> Location.report diff --git a/src/ocaml/typing/typedecl_separability.ml b/src/ocaml/typing/typedecl_separability.ml index aa30c375b..81490fa90 100644 --- a/src/ocaml/typing/typedecl_separability.ml +++ b/src/ocaml/typing/typedecl_separability.ml @@ -130,7 +130,7 @@ let rec immediate_subtypes : type_expr -> type_expr list = fun ty -> [ty1; ty2] | Ttuple(tys) -> List.map snd tys | Tunboxed_tuple(tys) -> List.map snd tys - | Tpackage(_, fl) -> (snd (List.split fl)) + | Tpackage pack -> (snd (List.split pack.pack_cstrs)) | Tobject(row,class_ty) -> let class_subtys = match !class_ty with @@ -427,7 +427,7 @@ let check_type | (Tquote(_) , Sep ) | (Tsplice(_) , Sep ) | (Tquote_eval(_) , Sep ) - | (Tpackage(_,_) , Sep ) + | (Tpackage _ , Sep ) | (Tof_kind(_) , Sep ) -> empty (* "Deeply separable" case for these same constructors. *) | (Tarrow _ , Deepsep) @@ -439,7 +439,7 @@ let check_type | (Tquote(_) , Deepsep) | (Tsplice(_) , Deepsep) | (Tquote_eval(_) , Deepsep) - | (Tpackage(_,_) , Deepsep) -> + | (Tpackage _ , Deepsep) -> let tys = immediate_subtypes ty in let on_subtype context ty = context ++ check_type (Hyps.guard hyps) ty Deepsep in diff --git a/src/ocaml/typing/typedecl_variance.ml b/src/ocaml/typing/typedecl_variance.ml index ae2bc01fe..630a8e04f 100644 --- a/src/ocaml/typing/typedecl_variance.ml +++ b/src/ocaml/typing/typedecl_variance.ml @@ -44,9 +44,13 @@ type variance_error = variable : type_expr } +type anonymous_variance_error = + | Variable_constrained of type_expr + | Variable_instantiated of type_expr + type error = | Bad_variance of variance_error * surface_variance * surface_variance - | Varying_anonymous + | Varying_anonymous of int * anonymous_variance_error exception Error of Location.t * error @@ -111,9 +115,10 @@ let compute_variance env visited vari ty = | Tpoly (ty, _) | Trepr (ty, _) -> compute_same ty | Tvar _ | Tnil | Tlink _ | Tunivar _ | Tof_kind _ -> () - | Tpackage (_, fl) -> + | Tpackage pack -> let v = Variance.(compose vari full) in - List.iter (fun (_, ty) -> compute_variance_rec env v ty) fl + List.iter + (fun (_, ty) -> compute_variance_rec env v ty) pack.pack_cstrs in compute_variance_rec env vari ty @@ -130,7 +135,10 @@ let compute_variance_type env ~check (required, loc) decl tyl = 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)) + (* c and n reflects respectively + and - in the syntax, + and maps respectively to `not May_neg` and `not May_pos` + in the {!Types.Variance.f} fields *) + not n, not c, i) required in (* Prepare *) @@ -186,8 +194,7 @@ let compute_variance_type env ~check (required, loc) decl tyl = (c,n,i))))) params required; (* Check propagation from constrained parameters *) - let args = Btype.newgenty (Ttuple (List.map (fun t -> None, t) params)) in - let fvl = Ctype.free_variables args in + let fvl = Ctype.free_variables_list params 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 *) @@ -263,8 +270,12 @@ let add_false = List.map (fun ty -> false, ty) 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 + | Tvar _ -> + begin match List.find_map (List.find_opt (eq_type ty)) vars with + | Some var -> Some (Variable_constrained var) + | None -> None + end + | _ -> Some (Variable_instantiated ty) let for_constr = function | Types.Cstr_tuple l -> List.map (fun {ca_type; _} -> false, ca_type) l @@ -274,8 +285,8 @@ let for_constr = function (Types.is_mutable ld_mutable, ld_type)) l -let compute_variance_gadt env ~check (required, loc as rloc) decl - (tl, ret_type_opt) = +let compute_variance_gadt env ~check (required, _ as rloc) decl + (cloc, tl, ret_type_opt) = match ret_type_opt with | None -> compute_variance_type env ~check rloc {decl with type_private = Private} @@ -287,14 +298,20 @@ let compute_variance_gadt env ~check (required, loc as rloc) decl let fvl = List.map (Ctype.free_variables ?env:None) tyl in let _ = List.fold_left2 - (fun (fv1,fv2) ty (c,n,_) -> + (fun (index, 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 + if (c || n) + then begin + match constrained (fv1 @ fv2) ty with + | None -> () + | Some reason -> + raise (Error(cloc, + Varying_anonymous (index, reason))) + end; + (succ index, fv :: fv1, fv2)) + (1, [], fvl) tyl required in compute_variance_type env ~check rloc {decl with type_params = tyl; type_private = Private} @@ -308,7 +325,7 @@ let compute_variance_extension env decl ext rloc = 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) + (ext.ext_loc, ext.ext_args, ext.ext_ret_type) let compute_variance_gadt_constructor env ~check rloc decl tl = let check = @@ -317,7 +334,7 @@ let compute_variance_gadt_constructor env ~check rloc decl tl = | None -> None in compute_variance_gadt env ~check rloc decl - (tl.Types.cd_args, tl.Types.cd_res) + (tl.Types.cd_loc, tl.Types.cd_args, tl.Types.cd_res) let compute_variance_decl env ~check decl (required, _ as rloc) = let check = @@ -327,11 +344,15 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = check in let abstract = Btype.type_kind_is_abstract decl in - if (abstract || decl.type_kind = Type_open) && decl.type_manifest = None then + match decl with + | {type_kind = Type_abstract _ | Type_open; type_manifest = None} -> List.map (fun (c, n, i) -> make (not n) (not c) (not abstract || i)) required - else begin + | { type_kind = _; type_manifest = Some _ } + | { type_kind = Type_record _ | Type_variant _ + | Type_record_unboxed_product _; + type_manifest = _ } -> let mn = match decl.type_manifest with None -> [] @@ -378,7 +399,6 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = if mn = [] || not abstract then List.map Variance.strengthen vari else vari - end let is_hash id = let s = Ident.name id in @@ -431,6 +451,7 @@ let transl_variance (v, i) = | Covariant -> (true, false) | Contravariant -> (false, true) | NoVariance -> (false, false) + | Bivariant -> (true, true) in (co, cn, match i with Injective -> true | NoInjectivity -> false) diff --git a/src/ocaml/typing/typedecl_variance.mli b/src/ocaml/typing/typedecl_variance.mli index 0b29e6205..e28f1808e 100644 --- a/src/ocaml/typing/typedecl_variance.mli +++ b/src/ocaml/typing/typedecl_variance.mli @@ -49,9 +49,13 @@ type variance_error = variable : type_expr } +type anonymous_variance_error = + | Variable_constrained of type_expr + | Variable_instantiated of type_expr + type error = | Bad_variance of variance_error * surface_variance * surface_variance - | Varying_anonymous + | Varying_anonymous of int * anonymous_variance_error exception Error of Location.t * error diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml index 65c197589..23562e35a 100644 --- a/src/ocaml/typing/typedtree.ml +++ b/src/ocaml/typing/typedtree.ml @@ -17,6 +17,7 @@ open Asttypes open Types +open Data_types open Mode type constant = @@ -209,7 +210,7 @@ and 'k pattern_desc = (string option * value general_pattern * Jkind.sort) list -> value pattern_desc | Tpat_construct : - Longident.t loc * Types.constructor_description * + Longident.t loc * constructor_description * value general_pattern list * ((Ident.t loc * Parsetree.jkind_annotation option) list * core_type) option -> @@ -288,8 +289,10 @@ and expression_desc = | Texp_apply of expression * (arg_label * apply_arg) list * apply_position * Mode.Locality.l * Zero_alloc.assume option - | Texp_match of expression * Jkind.sort * computation case list * partial - | Texp_try of expression * value case list + | Texp_match of + expression * Jkind.sort * computation case list * value case list + * partial + | Texp_try of expression * value case list * value case list | Texp_unboxed_unit | Texp_unboxed_bool of bool | Texp_tuple of (string option * expression) list * alloc_mode @@ -298,14 +301,14 @@ and expression_desc = Longident.t loc * constructor_description * expression list * alloc_mode option | Texp_variant of label * (expression * alloc_mode) option | Texp_record of { - fields : ( Types.label_description * record_label_definition ) array; + fields : ( Data_types.label_description * record_label_definition ) array; representation : Types.record_representation; extended_expression : (expression * Jkind.sort * Unique_barrier.t) option; alloc_mode : alloc_mode option } | Texp_record_unboxed_product of { fields : - ( Types.unboxed_label_description * record_label_definition ) array; + ( unboxed_label_description * record_label_definition ) array; representation : Types.record_unboxed_product_representation; extended_expression : (expression * Jkind.sort) option; } @@ -390,11 +393,11 @@ and meth = | Tmeth_ancestor of Ident.t * Path.t and block_access = - | Baccess_field of Longident.t loc * Types.label_description + | Baccess_field of Longident.t loc * label_description | Baccess_block of mutable_flag * expression and unboxed_access = - | Uaccess_unboxed_field of Longident.t loc * Types.unboxed_label_description + | Uaccess_unboxed_field of Longident.t loc * unboxed_label_description and comprehension = { @@ -427,6 +430,7 @@ and comprehension_iterator = and 'k case = { c_lhs: 'k general_pattern; + c_cont: Ident.t option; c_guard: expression option; c_rhs: expression; } @@ -657,6 +661,7 @@ and module_coercion = | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of primitive_coercion | Tcoerce_alias of Env.t * Path.t * module_coercion + | Tcoerce_invalid and module_type = { mty_desc: module_type_desc; @@ -833,10 +838,10 @@ and core_type_desc = | Ttyp_call_pos 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; + tpt_path : Path.t; + tpt_cstrs : (Longident.t loc * core_type) list; + tpt_type : Types.module_type; + tpt_txt : Longident.t loc; } and row_field = { @@ -1429,40 +1434,9 @@ let split_pattern pat = 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 nominal_exp_doc lid t = - let open Format_doc.Doc in - let longident l = Format_doc.doc_printer lid l.Location.txt in - let rec nominal_exp_doc doc exp = - match exp.exp_desc with - | _ when exp.exp_attributes <> [] -> None - | Texp_ident { lid; _ } -> - Some (longident lid doc) - | Texp_instvar (_,_,s) -> - Some (string s.Location.txt doc) - | Texp_constant _ -> assert false - | Texp_variant (lbl, None) -> - Some (printf "`%s" lbl doc) - | Texp_construct (l, _, [], _) -> Some (longident l doc) - | Texp_field (parent, _, lbl, _, _, _) -> - Option.map - (printf ".%t" (longident lbl)) - (nominal_exp_doc doc parent) - | Texp_send (parent, meth, _) -> - let name = match meth with - | Tmeth_name name -> name - | Tmeth_val id | Tmeth_ancestor (id,_) -> Ident.name id in - Option.map - (printf "#%s" name) - (nominal_exp_doc doc parent) - | _ -> None - in - nominal_exp_doc empty t +let map_apply_arg f = function + | Arg arg -> Arg (f arg) + | Omitted _ as arg -> arg let loc_of_decl ~uid = let of_option { txt; loc } = @@ -1518,12 +1492,14 @@ let rec fold_antiquote_exp f acc exp = | Texp_apply (exp, list, _, _, _) -> let acc = fold_antiquote_exp f acc exp in fold_antiquote_args f acc list - | Texp_match (exp, _, cases, _) -> + | Texp_match (exp, _, cases, eff_cases, _) -> let acc = fold_antiquote_exp f acc exp in - fold_antiquote_cases f acc cases - | Texp_try (exp, cases) -> + let acc = fold_antiquote_cases f acc cases in + fold_antiquote_cases f acc eff_cases + | Texp_try (exp, cases, eff_cases) -> let acc = fold_antiquote_exp f acc exp in - fold_antiquote_cases f acc cases + let acc = fold_antiquote_cases f acc cases in + fold_antiquote_cases f acc eff_cases | Texp_tuple (list, _) -> List.fold_left (fun acc (_, e) -> fold_antiquote_exp f acc e) acc list | Texp_unboxed_tuple list -> diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli index bb99cbd76..73ca372c2 100644 --- a/src/ocaml/typing/typedtree.mli +++ b/src/ocaml/typing/typedtree.mli @@ -246,7 +246,8 @@ and 'k pattern_desc = (** #() *) | Tpat_unboxed_bool : bool -> value pattern_desc (** #false, #true *) - | Tpat_tuple : (string option * value general_pattern) list -> value pattern_desc + | Tpat_tuple : + (string option * value general_pattern) list -> value pattern_desc (** (P1, ..., Pn) [(None,P1); ...; (None,Pn)]) (L1:P1, ... Ln:Pn) [(Some L1,P1); ...; (Some Ln,Pn)]) Any mix, e.g. (L1:P1, P2) [(Some L1,P1); ...; (None,P2)]) @@ -263,7 +264,7 @@ and 'k pattern_desc = Invariant: n >= 2 *) | Tpat_construct : - Longident.t loc * Types.constructor_description * + Longident.t loc * Data_types.constructor_description * value general_pattern list * ((Ident.t loc * Parsetree.jkind_annotation option) list * core_type) option -> @@ -287,17 +288,22 @@ and 'k pattern_desc = 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 + (Longident.t loc + * Data_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_record_unboxed_product : - (Longident.t loc * Types.unboxed_label_description * value general_pattern) list * - closed_flag -> + (Longident.t loc + * Data_types.unboxed_label_description + * value general_pattern) list + * closed_flag -> value pattern_desc (** #{ l1=P1; ...; ln=Pn } (flag = Closed) #{ l1=P1; ...; ln=Pn; _} (flag = Open) @@ -305,7 +311,8 @@ and 'k pattern_desc = Invariant: n > 0 *) | Tpat_array : - Types.mutability * Jkind.sort * value general_pattern list -> value pattern_desc + Types.mutability * Jkind.sort * value general_pattern list -> + value pattern_desc (** [| P1; ...; Pn |] (flag = Mutable) [: P1; ...; Pn :] (flag = Immutable) *) | Tpat_lazy : value general_pattern -> value pattern_desc @@ -454,7 +461,7 @@ and expression_desc = (** 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.Pexp_function}[Pexp_function]}. + {{!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 @@ -475,22 +482,29 @@ and expression_desc = The resulting typedtree for the application is: Texp_apply (Texp_ident "f/1037", [(Nolabel, Omitted _); - (Labelled "y", Some (Texp_constant Const_int 3)) + (Labelled "y", Arg (Texp_constant Const_int 3)) ]) The [Zero_alloc.assume option] records the optional [@zero_alloc assume] attribute that may appear on applications. *) - | Texp_match of expression * Jkind.sort * computation case list * partial + | Texp_match of + expression * Jkind.sort * 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, sort_of_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_unboxed_unit (** #() *) | Texp_unboxed_bool of bool @@ -514,7 +528,7 @@ and expression_desc = when [el] is [(Some L1, E1, s1); (None, E2, s2)] *) | Texp_construct of - Longident.t loc * Types.constructor_description * + Longident.t loc * Data_types.constructor_description * expression list * alloc_mode option (** C [] C E [E] @@ -530,7 +544,7 @@ and expression_desc = in which case it does not need allocation. *) | Texp_record of { - fields : ( Types.label_description * record_label_definition ) array; + fields : ( Data_types.label_description * record_label_definition ) array; representation : Types.record_representation; extended_expression : (expression * Jkind.sort * Unique_barrier.t) option; alloc_mode : alloc_mode option @@ -550,7 +564,9 @@ and expression_desc = in which case it does not need allocation. *) | Texp_record_unboxed_product of { - fields : ( Types.unboxed_label_description * record_label_definition ) array; + fields : + ( Data_types.unboxed_label_description + * record_label_definition ) array; representation : Types.record_unboxed_product_representation; extended_expression : (expression * Jkind.sort) option; } @@ -566,20 +582,20 @@ and expression_desc = extended_expression = Some E0 } *) | Texp_atomic_loc of - expression * Jkind.sort * Longident.t loc * Types.label_description * + expression * Jkind.sort * Longident.t loc * Data_types.label_description * alloc_mode | Texp_field of expression * Jkind.sort * Longident.t loc * - Types.label_description * texp_field_boxing * Unique_barrier.t + Data_types.label_description * texp_field_boxing * Unique_barrier.t (** - The sort is the sort of the whole record (which may be non-value if the record is @@unboxed). - [texp_field_boxing] provides extra information depending on if the projection requires boxing. *) | Texp_unboxed_field of - expression * Jkind.sort * Longident.t loc * Types.unboxed_label_description * - unique_use + expression * Jkind.sort * Longident.t loc * + Data_types.unboxed_label_description * unique_use | Texp_setfield of expression * Mode.Locality.l * Longident.t loc * - Types.label_description * expression + Data_types.label_description * expression (** [alloc_mode] translates to the [modify_mode] of the record *) | Texp_array of Types.mutability * Jkind.Sort.t * expression list * alloc_mode | Texp_idx of block_access * unboxed_access list @@ -648,10 +664,23 @@ and expression_desc = expressions *) | Texp_typed_hole +and meth = + Tmeth_name of string + | Tmeth_val of Ident.t + | Tmeth_ancestor of Ident.t * Path.t + and function_curry = | More_args of { partial_mode : Mode.Alloc.l } | Final_arg +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; @@ -725,17 +754,13 @@ and ident_kind = | Id_value | Id_prim of Mode.Locality.l option * Jkind.Sort.t option -and meth = - Tmeth_name of string - | Tmeth_val of Ident.t - | Tmeth_ancestor of Ident.t * Path.t - and block_access = - | Baccess_field of Longident.t loc * Types.label_description + | Baccess_field of Longident.t loc * Data_types.label_description | Baccess_block of mutable_flag * expression and unboxed_access = - | Uaccess_unboxed_field of Longident.t loc * Types.unboxed_label_description + | Uaccess_unboxed_field of + Longident.t loc * Data_types.unboxed_label_description and comprehension = { @@ -773,13 +798,6 @@ and comprehension_iterator = { pattern : pattern ; sequence : expression } -and 'k case = - { - c_lhs: 'k general_pattern; - c_guard: expression option; - c_rhs: expression; - } - and record_label_definition = | Kept of Types.type_expr * Types.mutability * unique_use | Overridden of Longident.t loc * expression @@ -803,6 +821,8 @@ and ('a, 'b) arg_or_omitted = | Arg of 'a (* an argument actually passed to a function *) | Omitted of 'b (* an argument not passed due to partial application *) +and apply_arg = (expression * Jkind.sort, omitted_parameter) arg_or_omitted + and omitted_parameter = { mode_closure : Mode.Alloc.r; mode_arg : Mode.Alloc.l; @@ -810,8 +830,6 @@ and omitted_parameter = sort_arg : Jkind.sort; sort_ret : Jkind.sort } -and apply_arg = (expression * Jkind.sort, omitted_parameter) arg_or_omitted - and apply_position = | Tail (* must be tail-call optimised *) | Nontail (* must not be tail-call optimised *) @@ -997,6 +1015,9 @@ and module_coercion = struct module Sub = Some_alias end ]} Only occurs inside a [Tcoerce_structure] coercion. *) + | Tcoerce_invalid + (** This coercion is only constructed by the recursive module consistency + check, whose result is discarded. It's a bug if it shows up anywhere. *) and module_type = { mty_desc: module_type_desc; @@ -1180,10 +1201,10 @@ and core_type_desc = argument ([lbl:[%call_pos] -> ...]). *) 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; + tpt_path : Path.t; + tpt_cstrs : (Longident.t loc * core_type) list; + tpt_type : Types.module_type; + tpt_txt : Longident.t loc; } and row_field = { @@ -1498,12 +1519,6 @@ val pat_bound_idents_full: val split_pattern: computation general_pattern -> pattern option * pattern option -(** Returns a format document if the expression reads nicely as the subject of a - sentence in a error message. *) -val nominal_exp_doc : - Longident.t Format_doc.printer -> expression - -> Format_doc.t option - (** Calculates the syntactic arity of a function based on its parameters and body. *) val function_arity : function_param list -> function_body -> int @@ -1522,3 +1537,6 @@ val mode_without_locks_exn : mode_with_locks -> Mode.Value.l (** Fold over the antiquotations in an expression. This function defines the evaluation order of antiquotations. *) val fold_antiquote_exp : ('a -> expression -> 'a) -> 'a -> expression -> 'a + +val map_apply_arg: + ('a -> ' b) -> ('a, 'omitted) arg_or_omitted -> ('b, 'omitted) arg_or_omitted diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli index fd02502f7..1007dbc79 100644 --- a/src/ocaml/typing/typemod.mli +++ b/src/ocaml/typing/typemod.mli @@ -60,8 +60,7 @@ val type_open_: 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 + Env.t -> Location.t -> package -> module_type val path_of_module : Typedtree.module_expr -> Path.t option @@ -156,6 +155,7 @@ type error = | Invalid_type_subst_rhs | Non_packable_local_modtype_subst of Path.t | With_cannot_remove_packed_modtype of Path.t * module_type + | Cannot_alias of Path.t | Strengthening_mismatch of Longident.t * Includemod.explanation | Cannot_pack_parameter | Compiling_as_parameterised_parameter diff --git a/src/ocaml/typing/typeopt.ml b/src/ocaml/typing/typeopt.ml index 8f1908fcf..0bee1ceb7 100644 --- a/src/ocaml/typing/typeopt.ml +++ b/src/ocaml/typing/typeopt.ml @@ -61,57 +61,60 @@ let scrape_ty env ty = match get_desc ty with | Tconstr _ | Tquote _ | Tsplice _ | Tquote_eval _ -> - let ty = Ctype.correct_levels ty in - let ty' = Ctype.expand_head_opt env ty in - begin match get_desc ty' with + let ty = Ctype.expand_head_opt env ty in + begin match get_desc ty with | Tconstr (p, _, _) -> begin match find_unboxed_type (Env.find_type p env) with | Some _ -> begin - match (Ctype.get_unboxed_type_approximation env ty') with + match (Ctype.get_unboxed_type_approximation env ty) with | { ty; or_null = None; modality = _ } -> - ty - | _ -> ty' end - | None -> ty' - | exception Not_found -> ty (* missing cmi file *) + Some ty + | _ -> Some ty end + | None -> Some ty + | exception Not_found -> None end | _ -> - ty' + Some ty end - | _ -> ty + | _ -> Some ty (* See [scrape_ty]; this returns the [type_desc] of a scraped [type_expr]. *) let scrape env ty = - get_desc (scrape_ty env ty) + Option.map 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 + Option.map (fun ty -> + match get_desc ty with + | Tpoly (ty, _) -> get_desc ty + | d -> d) + ty let is_function_type env ty = match scrape env ty with - | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs) + | Some (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 + | Some (Tconstr(p, _, _)) -> Path.same p base_ty_path | _ -> false let maybe_pointer_type env ty = - let ty = scrape_ty env ty in - let immediate_or_pointer = - match Ctype.is_always_gc_ignorable env ty with - | true -> Immediate - | false -> Pointer - in - let nullable = - match Ctype.check_type_nullability env ty Non_null with - | true -> Non_nullable - | false -> Nullable - in - immediate_or_pointer, nullable + match scrape_ty env ty with + | Some ty -> + let immediate_or_pointer = + match Ctype.is_always_gc_ignorable env ty with + | true -> Immediate + | false -> Pointer + in + let nullable = + match Ctype.check_type_nullability env ty Non_null with + | true -> Non_nullable + | false -> Nullable + in + immediate_or_pointer, nullable + | None -> Pointer, Nullable let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type @@ -148,9 +151,11 @@ type 'a classification = [scrape_ty]. Returning [Any] is safe, though may skip some optimizations. See comment on [classification] above to understand [classify_product]. *) let classify ~classify_product env ty sort : _ classification = - let ty = scrape_ty env ty in match (sort : Jkind.Sort.Const.t) with | Base Scannable -> begin + match scrape_ty env ty with + | None -> Any + | Some ty -> if Ctype.is_always_gc_ignorable env ty then if Ctype.check_type_nullability env ty Non_null @@ -159,39 +164,45 @@ let classify ~classify_product env ty sort : _ classification = | 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_iarray - || Path.same p Predef.path_nativeint - || Path.same p Predef.path_float32 - || Path.same p Predef.path_int32 - || Path.same p Predef.path_int64 - || Path.same p Predef.path_int8x16 - || Path.same p Predef.path_int16x8 - || Path.same p Predef.path_int32x4 - || Path.same p Predef.path_int64x2 - || Path.same p Predef.path_float16x8 - || Path.same p Predef.path_float32x4 - || Path.same p Predef.path_float64x2 - || Path.same p Predef.path_int8x32 - || Path.same p Predef.path_int16x16 - || Path.same p Predef.path_int32x8 - || Path.same p Predef.path_int64x4 - || Path.same p Predef.path_float16x16 - || Path.same p Predef.path_float32x8 - || Path.same p Predef.path_float64x4 - || Path.same p Predef.path_int8x64 - || Path.same p Predef.path_int16x32 - || Path.same p Predef.path_int32x16 - || Path.same p Predef.path_int64x8 - || Path.same p Predef.path_float16x32 - || Path.same p Predef.path_float32x16 - || Path.same p Predef.path_float64x8 - then Addr - else begin + begin match Predef.find_type_constr p with + | Some `Float -> Float + | Some `Lazy_t -> Lazy + | Some (`Int | `Char | `Int8 | `Int16) -> + (* This should be unreachable anyway because we check + [is_always_gc_ignorable] above *) + Immediate + | Some (`String | `Bytes + | `Int32 | `Int64 | `Nativeint + | `Extension_constructor | `Continuation + | `Array | `Floatarray | `Iarray + | `Atomic_loc + | `Float32 + | `Int8x16 + | `Int16x8 + | `Int32x4 + | `Int64x2 + | `Float16x8 + | `Float32x4 + | `Float64x2 + | `Int8x32 + | `Int16x16 + | `Int32x8 + | `Int64x4 + | `Float16x16 + | `Float32x8 + | `Float64x4 + | `Int8x64 + | `Int16x32 + | `Int32x16 + | `Int64x8 + | `Float16x32 + | `Float32x16 + | `Float64x8 + ) + -> Addr + | Some (`Lexing_position | `Code) + | Some (#Predef.data_type_constr | #Predef.abstract_non_value_type_constr) + | None -> try match (Env.find_type p env).type_kind with | Type_abstract _ -> @@ -336,10 +347,10 @@ let array_kind_of_elt ~elt_sort env loc ty = let array_type_kind ~elt_sort ~elt_ty env loc ty = match scrape_poly env ty with - | Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array - || Path.same p Predef.path_iarray -> + | Some (Tconstr(p, [elt_ty], _)) + when Path.same p Predef.path_array || Path.same p Predef.path_iarray -> array_kind_of_elt ~elt_sort env loc elt_ty - | Tconstr(p, [], _) when Path.same p Predef.path_floatarray -> + | Some (Tconstr(p, [], _)) when Path.same p Predef.path_floatarray -> Pfloatarray | _ -> begin match elt_ty with @@ -378,7 +389,7 @@ let array_type_kind ~elt_sort ~elt_ty env loc ty = (* let array_type_mut env ty = match scrape_poly env ty with - | Tconstr(p, [_], _) when Path.same p Predef.path_iarray -> Immutable + | Some (Tconstr(p, [_], _)) when Path.same p Predef.path_iarray -> Immutable | _ -> Mutable *) @@ -395,7 +406,7 @@ let array_pattern_kind pat elt_sort = let bigarray_decode_type env ty tbl dfl = match scrape env ty with - | Tconstr(Pdot(Pident mod_id, type_name), [], _) + | Some (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 | _ -> @@ -422,7 +433,7 @@ let layout_table = let bigarray_specialize_kind_and_layout env ~kind ~layout typ = match scrape env typ with - | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) -> + | Some (Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev)) -> let kind = match kind with | Pbigarray_unknown -> @@ -555,7 +566,9 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty || depth >= 2 || num_nodes_visited >= 30 in - let scty = scrape_ty env ty in + match scrape_ty env ty with + | None -> num_nodes_visited, non_nullable Pgenval + | Some scty -> begin (* CR layouts: We want to avoid correcting levels twice, and scrape_ty will correct levels for us. But it may be the case that we could do the @@ -579,8 +592,8 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty | Ok _ -> () | Error _ -> match - Ctype.(check_type_jkind env - (correct_levels ty) (Jkind.Builtin.value_or_null ~why:V1_safety_check)) + Ctype.check_type_jkind env ty + (Jkind.Builtin.value_or_null ~why:V1_safety_check) with | Ok _ -> () | Error violation -> @@ -771,7 +784,9 @@ and value_kind_mixed_block_field env ~loc ~visited ~depth ~num_nodes_visited match ty with | None -> unknown () | Some ty -> - let ty = scrape_ty env ty in + begin match scrape_ty env ty with + | None -> unknown () + | Some ty -> match get_desc ty with | Tunboxed_tuple fields -> Misc.Stdlib.Array.of_list_map (fun (_, field) -> Some field) fields @@ -781,9 +796,6 @@ and value_kind_mixed_block_field env ~loc ~visited ~depth ~num_nodes_visited | { type_kind = Type_record_unboxed_product (lbls, _, _); type_params; _ } -> let type_of_ld { Types.ld_type } = - let ld_type = Ctype.correct_levels ld_type in - let type_params = List.map Ctype.correct_levels type_params in - (* [args] is already corrected by [scrape_ty] *) try Some (Ctype.apply env type_params ld_type args) with Ctype.Cannot_apply -> None in @@ -799,6 +811,7 @@ and value_kind_mixed_block_field env ~loc ~visited ~depth ~num_nodes_visited | Tlink _ | Tsubst _ | Tvariant _ | Tunivar _ | Tpoly _ | Tpackage _ | Tquote _ | Tsplice _ | Tquote_eval _ | Tof_kind _ -> unknown () | Trepr _ -> Misc.fatal_error "value_kind_mixed_block_field: Trepr" + end in let (_, num_nodes_visited), kinds = Array.fold_left_map (fun (i, num_nodes_visited) field -> @@ -1238,18 +1251,18 @@ let report_error ppf = function the Jane Street compilers team."; begin match err with | None -> - fprintf ppf "@ Could not find cmi for: %a" Printtyp.type_expr ty + fprintf ppf "@ Could not find cmi for: %a" Printtyp.Doc.type_expr ty | Some err -> fprintf ppf "@ %a" (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> Printtyp.type_expr ppf ty) + ~offender:(fun ppf -> Printtyp.Doc.type_expr ppf ty) env) err end | Sort_without_extension (sort, maturity, ty) -> fprintf ppf "Non-value layout %a detected" Jkind.Sort.format sort; begin match ty with | None -> () - | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.type_expr ty + | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.Doc.type_expr ty end; fprintf ppf ",@ but this requires extension %s, which is not enabled.@ \ @@ -1261,7 +1274,7 @@ let report_error ppf = function fprintf ppf "Non-value layout %a detected" Jkind.Sort.format sort; begin match ty with | None -> () - | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.type_expr ty + | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.Doc.type_expr ty end; let extension, verb, flags = match Language_extension.(is_at_least Layouts Stable), @@ -1281,7 +1294,7 @@ let report_error ppf = function fprintf ppf "Non-value layout %a detected" Jkind.Sort.format sort; begin match ty with | None -> () - | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.type_expr ty + | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.Doc.type_expr ty end; let extension, verb, flags = match Language_extension.(is_at_least Layouts Stable), @@ -1300,7 +1313,7 @@ let report_error ppf = function | Not_a_sort (env, ty, err) -> fprintf ppf "A representable layout is required here.@ %a" (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> Printtyp.type_expr ppf ty) + ~offender:(fun ppf -> Printtyp.Doc.type_expr ppf ty) env) err | Unsupported_product_in_lazy const -> fprintf ppf @@ -1324,7 +1337,7 @@ let report_error ppf = function layout %a.@ \ @[Hint: if the array contents should not be scanned, annotating@ \ contained abstract types as [mod external] may resolve this error.@]" - Printtyp.type_expr elt_ty + Printtyp.Doc.type_expr elt_ty Jkind.Sort.Const.format const | Opaque_array_non_value { array_type; elt_kinding_failure } -> begin match elt_kinding_failure with @@ -1333,16 +1346,16 @@ let report_error ppf = function "This array operation cannot tell whether %a is an array type,@ \ possibly because it is abstract. In this case, the element type@ \ %a must be a value:@ @\n@[%a@]" - Printtyp.type_expr array_type - Printtyp.type_expr ty + Printtyp.Doc.type_expr array_type + Printtyp.Doc.type_expr ty (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> Printtyp.type_expr ppf ty) + ~offender:(fun ppf -> Printtyp.Doc.type_expr ppf ty) env) err | None -> fprintf ppf "This array operation expects an array type, but %a does not appear@ \ to be one.@ (Hint: it is abstract?)" - Printtyp.type_expr array_type; + Printtyp.Doc.type_expr array_type; end let () = diff --git a/src/ocaml/typing/types.mli b/src/ocaml/typing/types.mli index 4a032141e..eee9035aa 100644 --- a/src/ocaml/typing/types.mli +++ b/src/ocaml/typing/types.mli @@ -262,8 +262,7 @@ and type_desc = [Trepr (Tpoly ('a -> 'b, ['a; 'b]), [s1; s2])] where [s1] and [s2] are sort univars that appear in the jkinds of ['a] and ['b] respectively. *) - - | Tpackage of Path.t * (Longident.t * type_expr) list + | Tpackage of package (** Type of a first-class module (a.k.a package). *) | Tof_kind of jkind_lr @@ -287,7 +286,10 @@ and arg_label = and arrow_desc = arg_label * Mode.Alloc.lr * Mode.Alloc.lr - +(** [package] corresponds to the type of a first-class module *) +and package = + { pack_path : Path.t; + pack_cstrs : (string list * type_expr) list } (** See also documentation for [row_more], which enumerates how these constructors arise. *) @@ -554,12 +556,9 @@ 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 *) @@ -700,12 +699,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 @@ -761,6 +763,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 @@ -1234,40 +1237,12 @@ include Wrapped with type 'a wrapped = 'a 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: constructor_argument list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: tag; (* Tag for heap blocks *) - cstr_repr: variant_representation; (* Repr of the outer variant *) - cstr_shape: constructor_representation; (* Repr of the constructor itself *) - cstr_constant: bool; (* True if all args are void *) - 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; - (* [Some decl] here iff the cstr has an inline record (which is decl) *) - cstr_uid: Uid.t; - } - (* Constructors are the same *) val equal_tag : tag -> tag -> bool (* Comparison of tags to store them in sets. *) val compare_tag : tag -> tag -> int -(* Constructors may be the same, given potential rebinding *) -val may_equal_constr : - constructor_description -> constructor_description -> bool - (* Equality *) val equal_record_representation : @@ -1279,44 +1254,6 @@ val equal_record_unboxed_product_representation : val equal_variant_representation : variant_representation -> variant_representation -> bool -type 'a gen_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: mutability; (* Is this a mutable field? *) - lbl_modalities: Mode.Modality.Const.t; - (* Modalities on the field *) - lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) - lbl_pos: int; (* Position in type *) - lbl_all: 'a gen_label_description array; (* All the labels in this type *) - lbl_repres: 'a; (* Representation for outer record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - lbl_uid: Uid.t; - } - -type label_description = record_representation gen_label_description - -type unboxed_label_description = record_unboxed_product_representation gen_label_description - -(** This type tracks the distinction between legacy records ([{ field }]) and unboxed - records ([#{ field }]). Note that [Legacy] includes normal boxed records, as well as - inlined and [[@@unboxed]] records. - - As a GADT, it also lets us avoid duplicating functions that handle both record forms, - such as [Env.find_label_by_name], which has type - ['rep record_form -> Longident.t -> Env.t -> 'rep gen_label_description]. -*) -type _ record_form = - | Legacy : record_representation record_form - | Unboxed_product : record_unboxed_product_representation record_form - -type record_form_packed = - | P : _ record_form -> record_form_packed - -val record_form_to_string : _ record_form -> string - val mixed_block_element_of_const_sort : Jkind_types.Sort.Const.t -> mixed_block_element diff --git a/src/ocaml/typing/typetexp.mli b/src/ocaml/typing/typetexp.mli index bb6a3b788..943623d4f 100644 --- a/src/ocaml/typing/typetexp.mli +++ b/src/ocaml/typing/typetexp.mli @@ -179,6 +179,7 @@ type error = | Method_mismatch of string * type_expr * type_expr | Opened_object of Path.t option | Not_an_object of type_expr + | Repeated_tuple_label of string | Unsupported_extension : _ Language_extension.t -> error | Polymorphic_optional_param | Non_value of @@ -198,9 +199,6 @@ type error = 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 diff --git a/src/ocaml/typing/uniqueness_analysis.ml b/src/ocaml/typing/uniqueness_analysis.ml index 27db21500..cedab7bdf 100644 --- a/src/ocaml/typing/uniqueness_analysis.ml +++ b/src/ocaml/typing/uniqueness_analysis.ml @@ -81,7 +81,7 @@ *) open Asttypes -open Types +open Data_types open Mode open Typedtree module Uniqueness = Mode.Uniqueness @@ -2416,16 +2416,26 @@ let rec check_uniqueness_exp_desc ~borrows ~overwrite (ienv : Ienv.t) ~loc : args in UF.pars (uf_fn :: uf_args) - | Texp_match (arg, _, cases, _) -> + | Texp_match (arg, _, cases, eff_cases, _) -> let value, uf_arg = check_uniqueness_exp_for_match ienv arg in let uf_cases = check_uniqueness_comp_cases ienv value cases in - UF.seq uf_arg uf_cases - | Texp_try (body, cases) -> + let uf_eff_cases = check_uniqueness_cases ienv value eff_cases in + (* CR rtjoa for zqian: uncertain whether this is sound *) + (* Effects can be run multiple times - for uniqueness, this is equivalent to + twice - and can also be run when the non-effect case is run. *) + let uf_all_cases = UF.seqs [uf_eff_cases; uf_eff_cases; uf_cases] in + UF.seq uf_arg uf_all_cases + | Texp_try (body, cases, eff_cases) -> let uf_body = check_uniqueness_exp ~overwrite:None ienv body in let value = Match_single (Paths.fresh ()) in let uf_cases = check_uniqueness_cases ienv value cases in + let uf_eff_cases = check_uniqueness_cases ienv value eff_cases in + (* CR rtjoa for zqian: uncertain whether this is sound *) + (* Effects can be run multiple times - for uniqueness, this is equivalent to + twice - and can also be run when the non-effect case is run. *) + let uf_all_cases = UF.seqs [uf_eff_cases; uf_eff_cases; uf_cases] in (* we don't know how much of e will be run; safe to assume all of them *) - UF.seq uf_body uf_cases + UF.seq uf_body uf_all_cases | Texp_unboxed_unit -> UF.unused | Texp_unboxed_bool _ -> UF.unused | Texp_tuple (es, _) -> diff --git a/src/ocaml/typing/unit_info.mli b/src/ocaml/typing/unit_info.mli index e3220b304..09f9d5d68 100644 --- a/src/ocaml/typing/unit_info.mli +++ b/src/ocaml/typing/unit_info.mli @@ -28,20 +28,27 @@ type file_prefix = string (* CR lmaurer: These overlap with functionality in [Compilation_unit] **) +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 @@ -94,8 +101,8 @@ val kind: t -> intf_or_impl val check_unit_name : t -> unit (** [make ~check ~source_file ~for_pack_prefix kind prefix] associates both the - [source_file] and the module name {!modname_from_source}[ target_prefix] to - the prefix filesystem path [prefix]. + [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}. @@ -152,7 +159,7 @@ module Artifact: sig val modname: t -> Compilation_unit.t (** [from_filename ~for_pack_prefix filename] reconstructs the module name - [modname_from_source filename] associated to the artifact [filename], + [lax_modname_from_source filename] associated to the artifact [filename], assuming the pack prefix is [for_pack_prefix]. *) val from_filename: for_pack_prefix:Compilation_unit.Prefix.t -> filename -> t diff --git a/src/ocaml/typing/untypeast.ml b/src/ocaml/typing/untypeast.ml index 7dbf20cf9..693a2971a 100644 --- a/src/ocaml/typing/untypeast.ml +++ b/src/ocaml/typing/untypeast.ml @@ -89,16 +89,14 @@ Some notes: (** 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 +let rec lident_of_path = + let noloc_lident_of_path p = mknoloc (lident_of_path p) in + function | Path.Pident id -> Longident.Lident (Ident.name id) | Path.Papply (p1, p2) -> - Longident.Lapply (lident_of_path p1, lident_of_path p2) + Longident.Lapply (noloc_lident_of_path p1, noloc_lident_of_path p2) | Path.Pdot (p, s) | Path.Pextra_ty (p, Pcstr_ty s) -> - Longident.Ldot (lident_of_path p, s) + Longident.Ldot (noloc_lident_of_path p, mknoloc s) | Path.Pextra_ty (p, _) -> lident_of_path p let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} @@ -124,25 +122,31 @@ let rec extract_letop_patterns n pat = (** Mapping functions. *) let constant = function - | Const_char c -> Pconst_char c - | Const_untagged_char c -> Pconst_untagged_char c - | Const_string (s,loc,d) -> Pconst_string (s,loc,d) - | Const_int i -> Pconst_integer (Int.to_string i, None) - | Const_int8 i -> Pconst_integer (Int.to_string i, Some 's') - | Const_int16 i -> Pconst_integer (Int.to_string i, Some 'S') - | 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_float32 f -> Pconst_float (f, Some 's') - | Const_unboxed_float f -> Pconst_unboxed_float (f, None) - | Const_unboxed_float32 f -> Pconst_unboxed_float (f, Some 's') - | Const_untagged_int i -> Pconst_unboxed_integer (Int.to_string i, 'm') - | Const_untagged_int8 i -> Pconst_unboxed_integer (Int.to_string i, 's') - | Const_untagged_int16 i -> Pconst_unboxed_integer (Int.to_string i, 'S') - | Const_unboxed_int32 i -> Pconst_unboxed_integer (Int32.to_string i, 'l') - | Const_unboxed_int64 i -> Pconst_unboxed_integer (Int64.to_string i, 'L') - | Const_unboxed_nativeint i -> Pconst_unboxed_integer (Nativeint.to_string i, 'n') + | Const_char c -> Const.char c + | Const_untagged_char c -> Const.mk (Pconst_untagged_char c) + | Const_string (s,loc,d) -> Const.string ?quotation_delimiter:d ~loc s + | Const_int i -> Const.integer (Int.to_string i) + | Const_int8 i -> Const.integer ~suffix:'s' (Int.to_string i) + | Const_int16 i -> Const.integer ~suffix:'S' (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 + | Const_float32 f -> Const.float ~suffix:'s' f + | Const_unboxed_float f -> Const.mk (Pconst_unboxed_float (f, None)) + | Const_unboxed_float32 f -> Const.mk (Pconst_unboxed_float (f, Some 's')) + | Const_untagged_int i -> + Const.mk (Pconst_unboxed_integer (Int.to_string i, 'm')) + | Const_untagged_int8 i -> + Const.mk (Pconst_unboxed_integer (Int.to_string i, 's')) + | Const_untagged_int16 i -> + Const.mk (Pconst_unboxed_integer (Int.to_string i, 'S')) + | Const_unboxed_int32 i -> + Const.mk (Pconst_unboxed_integer (Int32.to_string i, 'l')) + | Const_unboxed_int64 i -> + Const.mk (Pconst_unboxed_integer (Int64.to_string i, 'L')) + | Const_unboxed_nativeint i -> + Const.mk (Pconst_unboxed_integer (Nativeint.to_string i, 'n')) let attribute sub a = { attr_name = map_loc sub a.attr_name; @@ -376,8 +380,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | Tpat_unboxed_bool b -> Ppat_unboxed_bool b | Tpat_tuple list -> Ppat_tuple - ( List.map (fun (label, p) -> label, sub.pat sub p) list - , Closed) + (List.map (fun (label, p) -> label, sub.pat sub p) list, Closed) | Tpat_unboxed_tuple list -> Ppat_unboxed_tuple (List.map (fun (label, p, _) -> label, sub.pat sub p) list, @@ -396,7 +399,10 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> match args with [] -> None | [arg] -> Some (sub.pat sub arg) - | args -> Some (Pat.tuple ~loc (List.map (fun p -> None, sub.pat sub p) args) Closed) + | args -> + Some (Pat.tuple ~loc + (List.map (fun p -> None, sub.pat sub p) args) + Closed) in Ppat_construct (map_loc sub lid, match tyo, arg with @@ -466,7 +472,9 @@ let value_binding sub vb = match pat.ppat_desc with | Ppat_constraint (pat, Some ({ ptyp_desc = Ptyp_poly _; _ } as cty), modes) -> - let constr = Pvc_constraint {locally_abstract_univars = []; typ = cty } in + let constr = + Pvc_constraint { locally_abstract_univars = []; typ = cty } + in pat, Some constr, modes | _ -> pat, None, [] in @@ -623,10 +631,32 @@ let expression sub exp = | Omitted _ -> list | Arg (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_unboxed_unit -> Pexp_unboxed_unit | Texp_unboxed_bool b -> Pexp_unboxed_bool b | Texp_tuple (list, _) -> @@ -730,7 +760,7 @@ let expression sub exp = | Texp_object (cl, _) -> Pexp_object (sub.class_structure sub cl) | Texp_pack (mexpr) -> - Pexp_pack (sub.module_expr sub mexpr) + Pexp_pack (sub.module_expr sub mexpr, None) | Texp_letop {let_; ands; body; _} -> let pat, and_pats = extract_letop_patterns (List.length ands) body.c_lhs @@ -756,7 +786,7 @@ let expression sub exp = Pstr_eval ( { pexp_desc=(Pexp_apply ( { pexp_desc=(Pexp_constant - (Pconst_string(name,loc,None))) + (Const.string ~loc name)) ; pexp_loc=loc ; pexp_loc_stack =[] ; pexp_attributes=[] @@ -776,7 +806,7 @@ let expression sub exp = { pstr_desc= Pstr_eval ( { pexp_desc=(Pexp_constant - (Pconst_string(name,loc,None))) + (Const.string ~loc name)) ; pexp_loc=loc ; pexp_loc_stack =[] ; pexp_attributes=[] @@ -813,9 +843,10 @@ let binding_op sub bop pat = {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) + { ppt_path = map_loc sub pack.tpt_txt; + ppt_cstrs = List.map (fun (s, ct) -> (s, sub.typ sub ct)) pack.tpt_cstrs; + ppt_attrs = []; + ppt_loc = sub.location sub pack.tpt_txt.loc } let module_type_declaration sub mtd = let loc = sub.location sub mtd.mtd_loc in @@ -1072,7 +1103,7 @@ 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_var (None, jkind) -> Ptyp_any jkind + Ttyp_var (None, jkind) -> Ptyp_any jkind | Ttyp_var (Some s, jkind) -> Ptyp_var (s, jkind) | Ttyp_arrow (arg_label, ct1, modes1, ct2, modes2) -> let modes1 = Typemode.untransl_mode modes1 in @@ -1080,10 +1111,10 @@ let core_type sub ct = Ptyp_arrow (label arg_label, sub.typ sub ct1, sub.typ sub ct2, modes1, modes2) | Ttyp_tuple list -> - Ptyp_tuple (List.map (fun (lbl, t) -> lbl, sub.typ sub t) list) + Ptyp_tuple (List.map (fun (l, typ) -> l, sub.typ sub typ) list) | Ttyp_unboxed_tuple list -> Ptyp_unboxed_tuple - (List.map (fun (lbl, t) -> lbl, sub.typ sub t) list) + (List.map (fun (l, typ) -> l, sub.typ sub typ) list) | Ttyp_constr (_path, lid, list) -> Ptyp_constr (map_loc sub lid, List.map (sub.typ sub) list) @@ -1119,7 +1150,7 @@ let core_type sub ct = let class_structure sub cs = let rec remove_self = function | { pat_desc = Tpat_alias { pattern = p; id; _ } } - when string_is_prefix "selfpat-" (Ident.name id) -> + when String.starts_with ~prefix:"selfpat-" (Ident.name id) -> remove_self p | p -> p in @@ -1149,7 +1180,7 @@ let object_field sub {of_loc; of_desc; of_attributes;} = and is_self_pat = function | { pat_desc = Tpat_alias { id; _ } } -> - string_is_prefix "self-" (Ident.name id) + String.starts_with ~prefix:"self-" (Ident.name id) | _ -> false (* [Typeclass] adds a [self] parameter to initializers and methods that isn't diff --git a/src/ocaml/typing/value_rec_check.ml b/src/ocaml/typing/value_rec_check.ml index 8daee3a82..e79da7445 100644 --- a/src/ocaml/typing/value_rec_check.ml +++ b/src/ocaml/typing/value_rec_check.ml @@ -158,7 +158,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 @@ -187,17 +187,29 @@ let classify_expression : Typedtree.expression -> sd = | Texp_record _ -> Static + | Texp_variant _ + | Texp_tuple _ + | Texp_atomic_loc _ + | Texp_extension_constructor _ + | Texp_constant _ -> + Static + + | Texp_for _ + | Texp_setfield _ + | Texp_while _ + | Texp_setinstvar _ -> + (* Unit-returning expressions *) + Static + + | Texp_unreachable -> + Static + | Texp_record_unboxed_product { representation = Record_unboxed_product; fields = [| _, Overridden (_,e) |] } -> classify_expression env e | Texp_record_unboxed_product _ -> Dynamic - | Texp_variant _ - | Texp_tuple _ - | Texp_atomic_loc _ - | Texp_extension_constructor _ - | Texp_constant _ | Texp_unboxed_unit | Texp_unboxed_bool _ | Texp_src_pos -> @@ -210,20 +222,10 @@ let classify_expression : Typedtree.expression -> sd = | Texp_hole _ -> Dynamic (* Disallowed for now *) - | Texp_for _ - | Texp_setfield _ - | Texp_while _ - | Texp_setinstvar _ -> - (* Unit-returning expressions *) - Static - | Texp_mutvar _ | Texp_setmutvar _ -> Static - | Texp_unreachable -> - Static - | Texp_probe _ | Texp_probe_is_enabled _ -> (* CR vlaviron: Dynamic would probably be a better choice *) @@ -357,6 +359,8 @@ let classify_expression : Typedtree.expression -> sd = Misc.fatal_error "letrec: primitive coercion on a module" | Tcoerce_alias _ -> Misc.fatal_error "letrec: alias coercion on a module" + | Tcoerce_invalid -> + Misc.fatal_error "letrec: invalid coercion on a module" end | Tmod_unpack (e, _) -> classify_expression env e @@ -666,8 +670,8 @@ let rec expression : Typedtree.expression -> term_judg = value_bindings Nonrecursive [binding] >> 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 ---------------------------------------------- @@ -677,7 +681,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 tf -> (* G1 |- low: m[Dereference] @@ -821,7 +829,7 @@ let rec expression : Typedtree.expression -> term_judg = | Void | Product _ -> Dereference) in - let field (label, field_def) = + let field ((label : Data_types.label_description), field_def) = let env = match field_def with | Kept _ -> empty @@ -964,7 +972,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 -------------------------------------------- @@ -978,6 +986,7 @@ let rec expression : Typedtree.expression -> term_judg = join [ expression e; list case_env cases; + list case_env eff_cases; ] | Texp_override (pth, fields) -> (* @@ -1205,6 +1214,8 @@ and modexp : Typedtree.module_expr -> term_judg = (* Alias coercions ignore their arguments, but they evaluate their alias module 'pth' under another coercion. *) coercion coe (fun m -> path pth << m) + | Tcoerce_invalid -> + Misc.fatal_error "Value_rec_check.modexp: invalid coercion" in coercion coe (fun m -> modexp mexp << m) | Tmod_unpack (e, _) -> diff --git a/src/ocaml/typing/vicuna_traverse_typed_tree.ml b/src/ocaml/typing/vicuna_traverse_typed_tree.ml index cfbb6b052..aa001589e 100644 --- a/src/ocaml/typing/vicuna_traverse_typed_tree.ml +++ b/src/ocaml/typing/vicuna_traverse_typed_tree.ml @@ -72,7 +72,6 @@ let scrape_ty env ty = let ty = match get_desc ty with Tpoly (ty, _) -> ty | _ -> ty in match get_desc ty with | Tconstr _ -> ( - let ty = Ctype.correct_levels ty in let ty' = Ctype.expand_head_opt env ty in match get_desc ty' with | Tconstr (p, _, _) -> ( diff --git a/src/ocaml/utils/diffing.ml b/src/ocaml/utils/diffing.ml index ca3a08d62..f2c336d9c 100644 --- a/src/ocaml/utils/diffing.ml +++ b/src/ocaml/utils/diffing.ml @@ -347,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/language_extension_kernel.ml b/src/ocaml/utils/language_extension_kernel.ml index 19cd32d55..530999742 100644 --- a/src/ocaml/utils/language_extension_kernel.ml +++ b/src/ocaml/utils/language_extension_kernel.ml @@ -15,7 +15,6 @@ type _ t = | Module_strengthening : unit t | Layouts : maturity t | SIMD : maturity t - | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : unit t | Let_mutable : unit t @@ -34,7 +33,6 @@ let to_string : type a. a t -> string = function | Module_strengthening -> "module_strengthening" | Layouts -> "layouts" | SIMD -> "simd" - | Labeled_tuples -> "labeled_tuples" | Small_numbers -> "small_numbers" | Instances -> "instances" | Let_mutable -> "let_mutable" diff --git a/src/ocaml/utils/language_extension_kernel.mli b/src/ocaml/utils/language_extension_kernel.mli index e0ac8fe7d..ab7d556ed 100644 --- a/src/ocaml/utils/language_extension_kernel.mli +++ b/src/ocaml/utils/language_extension_kernel.mli @@ -26,7 +26,6 @@ type _ t = | Module_strengthening : unit t | Layouts : maturity t | SIMD : maturity t - | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : unit t | Let_mutable : unit t diff --git a/src/ocaml/utils/load_path.ml b/src/ocaml/utils/load_path.ml index 1c4634824..fe2fb7493 100644 --- a/src/ocaml/utils/load_path.ml +++ b/src/ocaml/utils/load_path.ml @@ -298,12 +298,13 @@ end = struct None) t.files let find_normalized t fn = - let fn = Misc.normalized_unit_filename fn in + match Misc.normalized_unit_filename fn with + | Error _ -> None + | Ok fn -> let search { basename; path } = - if Misc.normalized_unit_filename basename = fn then - Some path - else - None + match Misc.normalized_unit_filename basename with + | Ok basename -> if String.equal basename fn then Some path else None + | Error _ -> None in List.find_map search t.files @@ -336,8 +337,12 @@ module Path_cache : sig val prepend_add_single : hidden:bool -> cmx_guaranteed:bool -> string -> string -> unit - (* Search for a basename in cache. Ignore case if [uncap] is true *) - val find : uncap:bool -> string -> string * visibility + (* Search for a basename in cache by exact name. *) + val find : string -> string * visibility + + (* Search in the uncapitalized tables. [fn_already_uncapped] should have + already been through [Misc.normalized_unit_filename]. *) + val find_uncap : fn_already_uncapped:string -> string * visibility end = struct module STbl = Misc.String.Tbl @@ -358,14 +363,17 @@ end = struct STbl.clear !visible_files_uncap let prepend_add_single ~hidden ~cmx_guaranteed base fn = - if hidden then begin - STbl.replace !hidden_files base fn; - STbl.replace !hidden_files_uncap (Misc.normalized_unit_filename base) fn - end else begin - STbl.replace !visible_files base { Clflags.path = fn; cmx_guaranteed }; - STbl.replace !visible_files_uncap (String.uncapitalize_ascii base) - { Clflags.path = fn; cmx_guaranteed } - end + Result.iter (fun ubase -> + if hidden then begin + STbl.replace !hidden_files base fn; + STbl.replace !hidden_files_uncap ubase fn + end else begin + STbl.replace !visible_files base + { Clflags.path = fn; cmx_guaranteed }; + STbl.replace !visible_files_uncap ubase + { Clflags.path = fn; cmx_guaranteed } + end) + (Misc.normalized_unit_filename base) let prepend_add dir = let hidden, cmx_guaranteed = @@ -390,23 +398,24 @@ end = struct in List.iter (fun ({ basename = base; path = fn } : Dir.entry) -> - 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 -> + update base fn visible_files hidden_files; + update ubase fn visible_files_uncap hidden_files_uncap) + (Misc.normalized_unit_filename base)) (Dir.files dir) - let find fn visible_files hidden_files = + let find_in fn visible_files hidden_files = try let { Clflags.path; cmx_guaranteed } = STbl.find !visible_files fn in (path, Visible { cmx_guaranteed }) with | Not_found -> (STbl.find !hidden_files fn, Hidden) - let find ~uncap fn = - if uncap then - find (String.uncapitalize_ascii fn) visible_files_uncap hidden_files_uncap - else - find fn visible_files hidden_files + let find fn = + find_in fn visible_files hidden_files + + let find_uncap ~fn_already_uncapped = + find_in fn_already_uncapped visible_files_uncap hidden_files_uncap end type auto_include_callback = @@ -605,7 +614,7 @@ let find fn = assert (not Config.merlin || Local_store.is_bound ()); try if is_basename fn && not !Sys.interactive then - fst (Path_cache.find ~uncap:false fn) + fst (Path_cache.find fn) else Misc.find_in_path (get_path_list ()) fn with Not_found -> @@ -621,9 +630,12 @@ let search_dirs dirs 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 - Path_cache.find ~uncap:true fn + Path_cache.find_uncap ~fn_already_uncapped:fn_uncap else match search_dirs (List.rev !visible_dirs) fn with | Some result -> result @@ -632,7 +644,6 @@ let find_normalized_with_visibility fn = | Some result -> result | None -> raise Not_found with Not_found -> - let fn_uncap = String.uncapitalize_ascii fn in (!auto_include_callback Dir.find_normalized fn_uncap, Visible { cmx_guaranteed = false }) 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.mli b/src/ocaml/utils/warnings.mli index 6e6c4954c..c25e2af90 100644 --- a/src/ocaml/utils/warnings.mli +++ b/src/ocaml/utils/warnings.mli @@ -50,6 +50,10 @@ type name_out_of_scope_warning = | Name of string | Fields of { record_form : string ; fields : string list } +type type_declaration_usage_warning = + | Declaration + | Alias + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -58,7 +62,7 @@ type t = | Ignored_partial_application (* 5 *) | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) - | Partial_match of string (* 8 *) + | Partial_match of Format_doc.t (* 8 *) | Missing_record_field_pattern of { form : string ; unbound : string } (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) @@ -89,7 +93,7 @@ type t = | 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_type_declaration of string * type_declaration_usage_warning (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * constructor_usage_warning (* 37 *) @@ -133,6 +137,8 @@ type t = | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) + | Unnecessarily_partial_tuple_pattern (* 75 *) (* Oxcaml specific warnings: numbers should go down from 199 *) | Redundant_kind_modifier of string (* 183 *) | Ignored_kind_modifier of string * string list (* 184 *) @@ -140,7 +146,7 @@ type t = | Unmutated_mutable of string (* 186 *) | Incompatible_with_upstream of upstream_compat_warning (* 187 *) | Unerasable_position_argument (* 188 *) - | Unnecessarily_partial_tuple_pattern (* 189 *) + (* 189 was [Unnecessarily_partial_tuple_pattern], now upstream as 75 *) | Probe_name_too_long of string (* 190 *) | Unused_kind_declaration of string (* 191 *) | Zero_alloc_all_hidden_arrow of string (* 198 *) @@ -178,9 +184,9 @@ val defaults_warn_error : string type reporting_information = { id : string - ; message : string + ; message : Format_doc.t ; is_error : bool - ; sub_locs : (loc * string) list; + ; sub_locs : (loc * Format_doc.t) list; } val report : t -> [ `Active of reporting_information | `Inactive ] diff --git a/src/utils/format_doc.ml b/src/utils/format_doc.ml index e2aaaf555..9b4875cdf 100644 --- a/src/utils/format_doc.ml +++ b/src/utils/format_doc.ml @@ -251,6 +251,82 @@ module Doc = struct let msg fmt = kmsg Fun.id fmt + + let ralign_tag = Format.String_tag "ralign" + + let rec split_on_open_tag tag rbefore = function + | [] -> rbefore, [] + | Open_tag t :: rest when t = tag -> + rbefore, rest + | elt :: rest -> + split_on_open_tag tag (elt::rbefore) rest + + let rec split_on_close opened rbefore = function + | [] -> rbefore, [] + | Open_tag _ as elt :: rest -> + split_on_close (opened+1) (elt::rbefore) rest + | Close_tag as elt :: rest -> + if opened = 0 then rbefore, rest + else split_on_close (opened-1) (elt::rbefore) rest + | elt :: rest -> + split_on_close opened (elt::rbefore) rest + + let rec approx_len acc = function + | [] -> Some acc + | Text x :: r-> + let len = Format.utf_8_scalar_width ~pos:0 ~len:(String.length x) x in + approx_len (acc + len) r + | With_size n :: Text _ :: r -> approx_len (acc + n) r + | (Open_box _ | Close_box | Open_tag _ | Close_tag + | Open_tbox | Close_tbox | Set_tab | With_size _ + ) :: r -> + approx_len acc r + | (Tab_break _ | Break _ | Simple_break _ | Flush _ | Newline | If_newline + | Deprecated _ ) :: _ -> + None + + type ralign_split = { + close_pos:int; + before: element list; + mid: element list; + after: element list; + } + + let split_ralign (doc, shift) = + let l = to_list doc in + let before, rest = + split_on_open_tag ralign_tag [] l in + let mid, after = split_on_close 0 [] rest in + let len = Option.bind (approx_len 0 before) (fun n -> approx_len n mid) in + match len with + | None -> Error doc + | Some len -> + Ok { close_pos= shift + len; before; mid; after } + + let align_doc max_pos r = + let aligned_before = + let before = Open_tag ralign_tag :: r.before in + if r.close_pos >= max_pos then before + else Text (String.make (max_pos - r.close_pos) ' ') :: before + in + let mid_to_start = Close_tag :: r.mid @ aligned_before in + { rev = List.rev_append r.after mid_to_start } + + let align_prefix l = + let l = List.map split_ralign l in + let max_pos = + List.fold_left (fun mx r -> + match r with + | Ok r -> max mx r.close_pos + | Error _ -> mx + ) 0 l + in + List.map (Result.fold ~ok:(align_doc max_pos) ~error:Fun.id) l + + let align_prefix2 x y = match align_prefix [x;y] with + | [x;y] -> x, y + | _ -> assert false + end (** Compatibility interface *) @@ -456,6 +532,7 @@ 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 semicolon ppf () = fprintf ppf ";@ " let pp_parens_if condition printer ppf arg = fprintf ppf "%s%a%s" diff --git a/src/utils/format_doc.mli b/src/utils/format_doc.mli index eceefcade..91142d31f 100644 --- a/src/utils/format_doc.mli +++ b/src/utils/format_doc.mli @@ -140,6 +140,14 @@ module Doc: sig 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 + (** {1 Alignment functions } *) + + (** Align the right side of one ["@{...@}"] tag box by inserting + spaces at the beginning of boxes. Those function do nothing if the tag box + appears after a break hint. *) + val align_prefix: (t * int) list -> t list + val align_prefix2: (t * int) -> (t * int) -> t * t + end (** {1 Compatibility API} *) @@ -269,6 +277,7 @@ val pp_print_newline: unit printer (** {2 Separators }*) val comma: unit printer +val semicolon: unit printer (** {2 List printing helpers} *) diff --git a/upstream/ocaml_flambda/base-rev.txt b/upstream/ocaml_flambda/base-rev.txt index 3278c28e3..cb5ecde99 100644 --- a/upstream/ocaml_flambda/base-rev.txt +++ b/upstream/ocaml_flambda/base-rev.txt @@ -1 +1 @@ -eb63e0e41869ede83ad3001e4facdff54383861d +02fe39378b978707317bd53e622d9ab6d6ba9751 diff --git a/upstream/ocaml_flambda/file_formats/cmt_format.ml b/upstream/ocaml_flambda/file_formats/cmt_format.ml index 0cbd688b7..8bbba5e47 100644 --- a/upstream/ocaml_flambda/file_formats/cmt_format.ml +++ b/upstream/ocaml_flambda/file_formats/cmt_format.ml @@ -154,28 +154,30 @@ let iter_on_occurrences let path_in_type typ name = match Types.get_desc typ with | Tconstr (type_path, _, _) -> - Some (Path.Pdot (type_path, name)) + Some (Path.Pextra_ty (type_path, Pcstr_ty name)) | _ -> None in let add_constructor_description env lid = function - | { Types.cstr_tag = Extension path; _ } -> + | { Data_types.cstr_tag = Extension path; _ } -> f ~namespace:Extension_constructor env path lid - | { Types.cstr_uid = Predef name; _} -> + | { Data_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; _ } -> + | { Data_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 ~namespace env lid { Types.lbl_name; lbl_res; _ } = + let add_label ~namespace env lid { Data_types.lbl_name; lbl_res; _ } = let path = path_in_type lbl_res lbl_name in Option.iter (fun path -> f ~namespace env path lid) path in let iter_field_exps ~namespace exp_env fields = Array.iter (fun (label_descr, record_label_definition) -> match record_label_definition with - | Overridden ({ Location.txt; loc}, {exp_loc; _}) + | 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 -> @@ -277,8 +279,8 @@ let iter_on_occurrences (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_package {tpt_path; tpt_txt} -> + f ~namespace:Module_type ctyp_env tpt_path tpt_txt | Ttyp_class (path, lid, _typs) -> (* Deprecated syntax to extend a polymorphic variant *) f ~namespace:Type ctyp_env path lid @@ -301,9 +303,9 @@ let iter_on_occurrences iter_field_pats ~namespace:Label pat_env fields | Tpat_record_unboxed_product (fields, _) -> iter_field_pats ~namespace:Unboxed_label pat_env fields - | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ + | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ | Tpat_fun_layout _ - | Tpat_unboxed_unit | Tpat_unboxed_bool _ | Tpat_tuple _ + | Tpat_unboxed_unit | Tpat_unboxed_bool _ | Tpat_unboxed_tuple _ | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ | Tpat_exception _ | Tpat_or _ -> ()); List.iter (fun (pat_extra, _, _) -> @@ -405,14 +407,35 @@ let index_occurrences binary_annots = let index : (Longident.t Location.loc * Shape_reduce.result) list ref = ref [] in - let f ~namespace env path (lid : _ Location.loc) = - if not (Location.is_none lid.loc) then + let f ~namespace env path lid = + (* Unlike upstream (which uses [not loc_ghost]), we only filter the [_none_] + sentinel location, to avoid filtering useful ghost locations; see #3137. *) + let not_none { Location.loc; _ } = not (Location.is_none loc) in + let reduce_and_store ~namespace lid path = if not_none 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 + (* Shape reduction can be expensive, but the persistent memoization tables + should make these successive reductions fast. *) + let rec index_components namespace lid path = + let module_ = Shape.Sig_component_kind.Module in + let scraped_path = Path.scrape_extra_ty path in + match lid.Location.txt, scraped_path with + | Longident.Ldot (lid', _), Path.Pdot (path', _) -> + reduce_and_store ~namespace lid path; + index_components module_ lid' path' + | Longident.Lapply (lid', lid''), Path.Papply (path', path'') -> + index_components module_ lid'' path''; + index_components module_ lid' path' + | Longident.Lident _, _ -> + reduce_and_store ~namespace lid path; + | _, _ -> () + in + index_components namespace lid path in iter_on_annots (iter_on_occurrences ~f) binary_annots; Array.of_list !index @@ -523,12 +546,16 @@ let save_cmt target cu binary_annots initial_env cmi shape = Array.sort compare_imports imports; imports in + let cmt_args = + let cmt_args = Array.copy Sys.argv in + cmt_args.(0) <- Location.rewrite_absolute_path Sys.argv.(0); + cmt_args in let cmt = { cmt_modname = cu; cmt_annots; cmt_declaration_dependencies = !uids_deps; cmt_comments = Lexer.comments (); - cmt_args = Sys.argv; + cmt_args; cmt_sourcefile = sourcefile; cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); cmt_loadpath = Load_path.get_paths (); diff --git a/upstream/ocaml_flambda/file_formats/cmt_format.mli b/upstream/ocaml_flambda/file_formats/cmt_format.mli index 06e4fbde1..437caf878 100644 --- a/upstream/ocaml_flambda/file_formats/cmt_format.mli +++ b/upstream/ocaml_flambda/file_formats/cmt_format.mli @@ -55,6 +55,8 @@ type cmt_infos = { cmt_declaration_dependencies : (dependency_kind * Uid.t * Uid.t) list; cmt_comments : (string * Location.t) list; cmt_args : string array; + (** {!Sys.argv} from the compiler invocation which created the file. + [Sys.argv.(0)] is rewritten using [BUILD_PATH_PREFIX_MAP]. *) cmt_sourcefile : string option; cmt_builddir : string; cmt_loadpath : Load_path.paths; diff --git a/upstream/ocaml_flambda/file_formats/linear_format.ml b/upstream/ocaml_flambda/file_formats/linear_format.ml index 85c3fe2ea..eb4b3aeb7 100644 --- a/upstream/ocaml_flambda/file_formats/linear_format.ml +++ b/upstream/ocaml_flambda/file_formats/linear_format.ml @@ -80,17 +80,17 @@ open Format_doc let report_error ppf = function | Wrong_format filename -> fprintf ppf "Expected Linear format. Incompatible file %a" - Location.Doc.filename filename + Location.Doc.quoted_filename filename | Wrong_version filename -> fprintf ppf "%a@ is not compatible with this version of OCaml" - Location.Doc.filename filename + Location.Doc.quoted_filename filename | Corrupted filename -> fprintf ppf "Corrupted format@ %a" - Location.Doc.filename filename + Location.Doc.quoted_filename filename | Marshal_failed filename -> fprintf ppf "Failed to marshal Linear to file@ %a" - Location.Doc.filename filename + Location.Doc.quoted_filename filename let () = Location.register_error_of_exn diff --git a/upstream/ocaml_flambda/parsing/ast_helper.ml b/upstream/ocaml_flambda/parsing/ast_helper.ml index bfb9f6189..8ab1b877f 100644 --- a/upstream/ocaml_flambda/parsing/ast_helper.ml +++ b/upstream/ocaml_flambda/parsing/ast_helper.ml @@ -33,15 +33,21 @@ 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 untagged_char ?loc c = mk ?loc (Pconst_untagged_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 @@ -71,7 +77,7 @@ module Typ = struct let alias ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_alias (a, b, c)) 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 package ?loc ?attrs a = mk ?loc ?attrs (Ptyp_package a) 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 quote ?loc ?attrs t = mk ?loc ?attrs (Ptyp_quote t) @@ -133,8 +139,8 @@ module Typ = struct v, jkind) var_lst in Ptyp_poly(var_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + | Ptyp_package ptyp -> + Ptyp_package (loop_package_type ptyp) | Ptyp_open (mod_ident, core_type) -> Ptyp_open (mod_ident, loop core_type) | Ptyp_quote core_type -> @@ -179,9 +185,17 @@ module Typ = struct Oinherit (loop t) in { field with pof_desc; } + and loop_package_type ptyp = + { ptyp with + ppt_cstrs = List.map (fun (n,typ) -> (n,loop typ) ) ptyp.ppt_cstrs } in loop t + let package_type ?(loc = !default_loc) ?(attrs = []) p c = + {ppt_loc = loc; + ppt_path = p; + ppt_cstrs = c; + ppt_attrs = attrs} end module Pat = struct @@ -214,6 +228,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 @@ -263,7 +278,7 @@ module Exp = struct 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 c = mk ?loc ?attrs (Pexp_newtype (a, b, c)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) + let pack ?loc ?attrs a b = mk ?loc ?attrs (Pexp_pack (a, b)) 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}) @@ -690,7 +705,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/upstream/ocaml_flambda/parsing/ast_helper.mli b/upstream/ocaml_flambda/parsing/ast_helper.mli index 79f368d81..535086f01 100644 --- a/upstream/ocaml_flambda/parsing/ast_helper.mli +++ b/upstream/ocaml_flambda/parsing/ast_helper.mli @@ -44,15 +44,17 @@ 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 untagged_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} *) @@ -73,7 +75,8 @@ module Typ : -> core_type val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> mode with_loc list -> mode with_loc list -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> (string option * core_type) list -> core_type + val tuple: ?loc:loc -> ?attrs:attrs -> (string option * core_type) list + -> core_type val unboxed_tuple: ?loc:loc -> ?attrs:attrs -> (string option * core_type) list -> core_type val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type @@ -87,8 +90,7 @@ module Typ : -> label list option -> core_type val poly: ?loc:loc -> ?attrs:attrs -> (str * jkind_annotation option) list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type + val package: ?loc:loc -> ?attrs:attrs -> package_type -> core_type val open_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type -> core_type val quote : ?loc:loc -> ?attrs:attrs -> core_type -> core_type val splice : ?loc:loc -> ?attrs:attrs -> core_type -> core_type @@ -109,6 +111,10 @@ module Typ : ['a. 'a -> 'a] during parsing. @since 4.05 *) + + val package_type: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list + -> package_type + (** @since 5.4 *) end (** Patterns *) @@ -124,11 +130,11 @@ module Pat: val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern val unboxed_unit: ?loc:loc -> ?attrs:attrs -> unit -> pattern val unboxed_bool: ?loc:loc -> ?attrs:attrs -> bool -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> (string option * pattern) list -> - closed_flag -> pattern val unboxed_tuple: ?loc:loc -> ?attrs:attrs -> (string option * pattern) list -> closed_flag -> pattern + val tuple: ?loc:loc -> ?attrs:attrs -> (string option * pattern) list + -> closed_flag -> pattern val construct: ?loc:loc -> ?attrs:attrs -> lid -> ((str * jkind_annotation option) list * pattern) option -> pattern val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern @@ -146,6 +152,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 @@ -169,9 +176,10 @@ module Exp: val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression val unboxed_unit: ?loc:loc -> ?attrs:attrs -> unit -> expression val unboxed_bool: ?loc:loc -> ?attrs:attrs -> bool -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> (string option * expression) list -> expression val unboxed_tuple: ?loc:loc -> ?attrs:attrs -> (string option * expression) list -> expression + val tuple: ?loc:loc -> ?attrs:attrs -> (string option * expression) list + -> expression val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option @@ -217,7 +225,8 @@ module Exp: val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression val newtype: ?loc:loc -> ?attrs:attrs -> str -> jkind_annotation option -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression + val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> package_type option + -> expression val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression -> expression val letop: ?loc:loc -> ?attrs:attrs -> binding_op diff --git a/upstream/ocaml_flambda/parsing/ast_invariants.ml b/upstream/ocaml_flambda/parsing/ast_invariants.ml index ba1dc9b1a..2f69d45d3 100644 --- a/upstream/ocaml_flambda/parsing/ast_invariants.ml +++ b/upstream/ocaml_flambda/parsing/ast_invariants.ml @@ -24,7 +24,7 @@ let invalid_alias loc = err loc "Alias types must have a name or a jkind." let empty_open_tuple_pat loc = err loc "Open tuple patterns must have at least one component." let short_closed_tuple_pat loc = - err loc "Closed tuple patterns must have at least 2 components." + err loc "Closed tuple patterns must have at least two components." let no_args loc = err loc "Function application with no argument." let empty_let loc = err loc "Let with no bindings." let mutable_rec_let loc = err loc "Mutable let binding cannot be recursive." @@ -32,6 +32,8 @@ let multiple_mutable_let loc = err loc "Mutable let must have only one binding." let mutable_let_bad_pat loc = err loc "Mutable let must have a variable on the left hand side." 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" @@ -46,7 +48,7 @@ let empty_constraint loc = let simple_longident id = let rec is_simple = function | Longident.Lident _ -> true - | Longident.Ldot (id, _) -> is_simple id + | Longident.Ldot (id, _) -> is_simple id.txt | Longident.Lapply _ -> false in if not (is_simple id.txt) then complex_id id.loc @@ -76,9 +78,10 @@ let iterator = 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_package ptyp -> + List.iter (fun (id, _) -> simple_longident id) ptyp.ppt_cstrs | Ptyp_alias (_, None, None) -> invalid_alias loc + | Ptyp_poly([],_) -> empty_poly_binder loc | _ -> () in let pat self pat = @@ -91,13 +94,8 @@ let iterator = end; let loc = pat.ppat_loc in match pat.ppat_desc with - | Ppat_tuple (lt, op) -> begin - match lt, op with - | ([], Open) -> empty_open_tuple_pat loc - | (([] | [_]), Closed) -> - short_closed_tuple_pat loc - | _ -> () - end + | Ppat_tuple (([] | [_]), Closed) -> short_closed_tuple_pat loc + | Ppat_tuple ([], Open) -> empty_open_tuple_pat loc | Ppat_record ([], _) -> empty_record loc | Ppat_construct (id, _) -> simple_longident id | Ppat_record (fields, _) -> @@ -263,3 +261,88 @@ let iterator = let structure st = iterator.structure iterator st let signature sg = iterator.signature iterator sg + +let check_loc_ghost meth v ~source_contents = + let equal_modulo_loc = + let no_locs = + { Ast_mapper.default_mapper + with location = (fun _ _ -> Location.none); + attributes = (fun _ _ -> []); + (* type z = (int [@foo]) create int at location "int" instead of + "int [@foo]". I'd rather loosen the check than worsen the location + for type errors. *) + } + in + fun meth node1 node2 -> + let norm1 = (meth no_locs) no_locs node1 in + let norm2 = (meth no_locs) no_locs node2 in + Stdlib.(=) norm1 norm2 + in + let super = Ast_iterator.default_iterator in + let depth = ref 0 in + let limit_quadratic_complexity meth f = + fun self v -> + if !depth < 1000 then ( + depth := !depth + 1; + (meth super) self v; + depth := !depth -1 ; + f v; + ) + in + let check ?print ?(wrap = Fun.id) meth parse ast1 (loc : Location.t) = + let source_fragment = + wrap ( + String.sub source_contents + loc.loc_start.pos_cnum + (loc.loc_end.pos_cnum - loc.loc_start.pos_cnum) + ) + in + let lexbuf = Lexing.from_string source_fragment in + let should_be_loc_ghost, error_if_not = + match parse lexbuf with + | exception Parsing.Parse_error | exception _ -> + true, "non-ghost location points to a non parsable range" + | ast2 -> + if equal_modulo_loc meth ast1 ast2 + then false, "ghost location should be non-ghost" + else true, "non-ghost location points to a range of source \ + code that contains the wrong ast" + in + if loc.loc_ghost <> should_be_loc_ghost + then ( + Format.eprintf "@[<2>%a: %s%t@]@." Location.print_loc loc error_if_not + (fun f -> + match print with + | None -> () + | Some print -> Format.fprintf f "@\n%a" print ast1) + ) + in + let self = + { super with + expr = + limit_quadratic_complexity (fun s -> s.expr) + (fun v -> + check (fun s -> s.expr) Parse.expression v v.pexp_loc + (* ~print:(fun f ty -> Printast.expression 0 f ty) *) + (* Add parens because in 1 + 2, + gets assigned a non-ghost + location, but + without parens is not a valid expression. *) + ~wrap:(fun s -> "( " ^ s ^ " )")) + ; pat = + limit_quadratic_complexity (fun s -> s.pat) + (fun v -> check (fun s -> s.pat) Parse.pattern v v.ppat_loc ) + ; typ = + limit_quadratic_complexity (fun s -> s.typ) + (fun v -> + check + (* ~print:(fun f ty -> Printast.payload 0 f (PTyp ty)) *) + (fun s -> s.typ) Parse.core_type v v.ptyp_loc ) + ; attribute = (fun self attr -> + (* Doc comments would probably need some special case to check they are + correctly placed. *) + if attr.attr_name.txt = "ocaml.doc" + || attr.attr_name.txt = "ocaml.text" + then () + else super.attribute self attr) + } + in + (meth self) self v diff --git a/upstream/ocaml_flambda/parsing/ast_invariants.mli b/upstream/ocaml_flambda/parsing/ast_invariants.mli index fdb56aa5e..deb098409 100644 --- a/upstream/ocaml_flambda/parsing/ast_invariants.mli +++ b/upstream/ocaml_flambda/parsing/ast_invariants.mli @@ -21,3 +21,13 @@ val structure : Parsetree.structure -> unit val signature : Parsetree.signature -> unit + +(** Checks the invariant of Location.t's loc_ghost field, that are stated in + location.mli. This can be run with -dparsetree-loc-ghost-invariants, which + is used slightly in the testsuite, but should be used more to find more + of the places where the invariant is broken. *) +val check_loc_ghost : + (Ast_iterator.iterator -> Ast_iterator.iterator -> 'a -> unit) + -> 'a + -> source_contents:string + -> unit diff --git a/upstream/ocaml_flambda/parsing/ast_iterator.ml b/upstream/ocaml_flambda/parsing/ast_iterator.ml index 2a7e8c353..cdee6c44b 100644 --- a/upstream/ocaml_flambda/parsing/ast_iterator.ml +++ b/upstream/ocaml_flambda/parsing/ast_iterator.ml @@ -60,6 +60,7 @@ type iterator = { module_type_declaration: iterator -> module_type_declaration -> unit; open_declaration: iterator -> open_declaration -> unit; open_description: iterator -> open_description -> unit; + package_type: iterator -> package_type -> unit; pat: iterator -> pattern -> unit; payload: iterator -> payload -> unit; signature: iterator -> signature -> unit; @@ -92,6 +93,20 @@ let iter_opt f = function None -> () | Some x -> f x let iter_loc sub {loc; txt = _} = sub.location sub loc +let rec iter_lid sub lid = + let open Longident in + match lid with + | Lident _ -> () + | Ldot (lid, id) -> + iter_loc sub lid; iter_lid sub lid.txt; iter_loc sub id + | Lapply (lid, lid') -> + iter_loc sub lid; iter_lid sub lid.txt; + iter_loc sub lid'; iter_lid sub lid'.txt + +let iter_loc_lid sub {loc; txt} = + iter_loc sub {loc; txt}; + iter_lid sub txt + module T = struct (* Type expressions for the core language *) @@ -123,8 +138,6 @@ module T = struct | None -> () | Some annot -> sub.jkind_annotation sub annot - let iter_labeled_tuple sub tl = List.iter (iter_snd (sub.typ sub)) tl - let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = sub.location sub loc; sub.attributes sub attrs; @@ -134,14 +147,14 @@ module T = struct | Ptyp_arrow (_lab, t1, t2, m1, m2) -> sub.typ sub t1; sub.typ sub t2; sub.modes sub m1; sub.modes sub m2 - | Ptyp_tuple tyl -> iter_labeled_tuple sub tyl - | Ptyp_unboxed_tuple tyl -> iter_labeled_tuple sub tyl + | Ptyp_tuple tyl -> List.iter (fun (_, e) -> sub.typ sub e) tyl + | Ptyp_unboxed_tuple tyl -> List.iter (fun (_, e) -> sub.typ sub e) tyl | Ptyp_constr (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl + iter_loc_lid 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 + iter_loc_lid sub lid; List.iter (sub.typ sub) tl | Ptyp_alias (t, _, jkind) -> sub.typ sub t; Option.iter (sub.jkind_annotation sub) jkind @@ -150,11 +163,10 @@ module T = struct | Ptyp_poly (bound_vars, t) -> List.iter (bound_var sub) bound_vars; sub.typ sub t; - | Ptyp_package (lid, l) -> - iter_loc sub lid; - List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l + | Ptyp_package ptyp -> + sub.package_type sub ptyp | Ptyp_open (mod_ident, t) -> - iter_loc sub mod_ident; + iter_loc_lid sub mod_ident; sub.typ sub t | Ptyp_quote t -> sub.typ sub t | Ptyp_splice t -> sub.typ sub t @@ -207,7 +219,7 @@ module T = struct ptyext_private = _; ptyext_loc; ptyext_attributes} = - iter_loc sub ptyext_path; + iter_loc_lid 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; @@ -225,7 +237,7 @@ module T = struct iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto | Pext_rebind li -> - iter_loc sub li + iter_loc_lid sub li let iter_extension_constructor sub {pext_name; @@ -237,6 +249,12 @@ module T = struct iter_extension_constructor_kind sub pext_kind; sub.attributes sub pext_attributes + let iter_package_type sub {ppt_path; ppt_cstrs; ppt_loc; ppt_attrs} = + sub.location sub ppt_loc; + iter_loc_lid sub ppt_path; + List.iter (iter_tuple (iter_loc_lid sub) (sub.typ sub)) ppt_cstrs; + sub.attributes sub ppt_attrs + end module CT = struct @@ -247,7 +265,7 @@ module CT = struct sub.attributes sub attrs; match desc with | Pcty_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys + iter_loc_lid 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 @@ -287,8 +305,8 @@ module MT = struct 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_ident s -> iter_loc_lid sub s + | Pmty_alias s -> iter_loc_lid sub s | Pmty_signature sg -> sub.signature sub sg | Pmty_functor (param, mt2, mm2) -> iter_functor_param sub param; @@ -305,19 +323,19 @@ module MT = struct let iter_with_constraint sub = function | Pwith_type (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d + iter_loc_lid sub lid; sub.type_declaration sub d | Pwith_module (lid, lid2) -> - iter_loc sub lid; iter_loc sub lid2 + iter_loc_lid sub lid; iter_loc_lid sub lid2 | Pwith_modtype (lid, mty) -> - iter_loc sub lid; sub.module_type sub mty + iter_loc_lid sub lid; sub.module_type sub mty | Pwith_jkind (lid, d) -> iter_loc sub lid; sub.jkind_declaration sub d | Pwith_typesubst (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d + iter_loc_lid sub lid; sub.type_declaration sub d | Pwith_modsubst (s, lid) -> - iter_loc sub s; iter_loc sub lid + iter_loc_lid sub s; iter_loc_lid sub lid | Pwith_modtypesubst (lid, mty) -> - iter_loc sub lid; sub.module_type sub mty + iter_loc_lid sub lid; sub.module_type sub mty | Pwith_jkindsubst (lid, d) -> iter_loc sub lid; sub.jkind_declaration sub d @@ -357,7 +375,7 @@ module M = struct sub.location sub loc; sub.attributes sub attrs; match desc with - | Pmod_ident x -> iter_loc sub x + | Pmod_ident x -> iter_loc_lid sub x | Pmod_structure str -> sub.structure sub str | Pmod_functor (param, body) -> iter_functor_param sub param; @@ -461,20 +479,18 @@ module E = struct sub.location sub loc; sub.attributes sub attrs - let iter_labeled_tuple sub el = List.iter (iter_snd (sub.expr sub)) el - let iter_block_access sub = function - | Baccess_field lid -> iter_loc sub lid + | Baccess_field lid -> iter_loc_lid sub lid | Baccess_block (_, idx) -> sub.expr sub idx let iter_unboxed_access sub = function - | Uaccess_unboxed_field lid -> iter_loc sub lid + | Uaccess_unboxed_field lid -> iter_loc_lid sub lid 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_ident x -> iter_loc_lid sub x | Pexp_constant _ -> () | Pexp_let (_m, _r, vbs, e) -> List.iter (sub.value_binding sub) vbs; @@ -490,21 +506,21 @@ module E = struct | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel | Pexp_unboxed_unit -> () | Pexp_unboxed_bool _ -> () - | Pexp_tuple el -> iter_labeled_tuple sub el - | Pexp_unboxed_tuple el -> iter_labeled_tuple sub el + | Pexp_tuple el -> List.iter (fun (_, e) -> sub.expr sub e) el + | Pexp_unboxed_tuple el -> List.iter (fun (_, e) -> sub.expr sub e) el | Pexp_construct (lid, arg) -> - iter_loc sub lid; iter_opt (sub.expr sub) arg + iter_loc_lid sub lid; iter_opt (sub.expr sub) arg | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo | Pexp_record (l, eo) | Pexp_record_unboxed_product (l, eo) -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; + List.iter (iter_tuple (iter_loc_lid sub) (sub.expr sub)) l; iter_opt (sub.expr sub) eo | Pexp_field (e, lid) | Pexp_unboxed_field (e, lid) -> - sub.expr sub e; iter_loc sub lid + sub.expr sub e; iter_loc_lid sub lid | Pexp_setfield (e1, lid, e2) -> - sub.expr sub e1; iter_loc sub lid; + sub.expr sub e1; iter_loc_lid sub lid; sub.expr sub e2 | Pexp_array (_mut, el) -> List.iter (sub.expr sub) el | Pexp_idx (ba, uas) -> @@ -528,7 +544,7 @@ module E = struct Option.iter (sub.typ sub) t; sub.modes sub m | Pexp_send (e, _s) -> sub.expr sub e - | Pexp_new lid -> iter_loc sub lid + | Pexp_new lid -> iter_loc_lid sub lid | Pexp_setvar (s, e) -> iter_loc sub s; sub.expr sub e | Pexp_override sel -> @@ -548,7 +564,9 @@ module E = struct iter_loc sub s; Option.iter (sub.jkind_annotation sub) jkind; sub.expr sub e - | Pexp_pack me -> sub.module_expr sub me + | Pexp_pack (me, optyp) -> + sub.module_expr sub me; + Option.iter (sub.package_type sub) optyp | Pexp_open (o, e) -> sub.open_declaration sub o; sub.expr sub e | Pexp_letop {let_; ands; body} -> @@ -576,8 +594,6 @@ end module P = struct (* Patterns *) - let iter_labeled_tuple sub pl = List.iter (iter_snd (sub.pat sub)) pl - let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = sub.location sub loc; sub.attributes sub attrs; @@ -589,10 +605,10 @@ module P = struct | Ppat_interval _ -> () | Ppat_unboxed_unit -> () | Ppat_unboxed_bool _ -> () - | Ppat_tuple (pl, _) -> iter_labeled_tuple sub pl - | Ppat_unboxed_tuple (pl, _) -> iter_labeled_tuple sub pl + | Ppat_tuple (pl, _) -> List.iter (fun (_, p) -> sub.pat sub p) pl + | Ppat_unboxed_tuple (pl, _) -> List.iter (fun (_, p) -> sub.pat sub p) pl | Ppat_construct (l, p) -> - iter_loc sub l; + iter_loc_lid sub l; iter_opt (fun (vl,p) -> List.iter @@ -605,18 +621,19 @@ module P = struct | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p | Ppat_record (lpl, _cf) | Ppat_record_unboxed_product (lpl, _cf) -> - List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl + List.iter (iter_tuple (iter_loc_lid sub) (sub.pat sub)) lpl | Ppat_array (_mut, pl) -> List.iter (sub.pat sub) pl | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 | Ppat_constraint (p, t, m) -> sub.pat sub p; Option.iter (sub.typ sub) t; sub.modes sub m; - | Ppat_type s -> iter_loc sub s + | Ppat_type s -> iter_loc_lid 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 + iter_loc_lid sub lid; sub.pat sub p end @@ -628,7 +645,7 @@ module CE = struct sub.attributes sub attrs; match desc with | Pcl_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys + iter_loc_lid sub lid; List.iter (sub.typ sub) tys | Pcl_structure s -> sub.class_structure sub s | Pcl_fun (_lab, e, p, ce) -> @@ -716,6 +733,7 @@ let default_iterator = type_extension = T.iter_type_extension; type_exception = T.iter_type_exception; extension_constructor = T.iter_extension_constructor; + package_type = T.iter_package_type; value_description = (fun this {pval_name; pval_type; pval_modalities; pval_prim = _; pval_poly=_; pval_loc; pval_attributes} -> @@ -741,7 +759,7 @@ let default_iterator = module_substitution = (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> iter_loc this pms_name; - iter_loc this pms_manifest; + iter_loc_lid this pms_manifest; this.location this pms_loc; this.attributes this pms_attributes; ); @@ -770,7 +788,7 @@ let default_iterator = open_description = (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> - iter_loc this popen_expr; + iter_loc_lid this popen_expr; this.location this popen_loc; this.attributes this popen_attributes ); @@ -893,7 +911,10 @@ let default_iterator = directive_argument = (fun this a -> - this.location this a.pdira_loc + this.location this a.pdira_loc; + match a.pdira_desc with + | Pdir_ident lid -> iter_lid this lid + | Pdir_int _ | Pdir_string _ | Pdir_bool _ -> () ); toplevel_directive = diff --git a/upstream/ocaml_flambda/parsing/ast_iterator.mli b/upstream/ocaml_flambda/parsing/ast_iterator.mli index 87544e63c..021eca6dd 100644 --- a/upstream/ocaml_flambda/parsing/ast_iterator.mli +++ b/upstream/ocaml_flambda/parsing/ast_iterator.mli @@ -63,6 +63,7 @@ type iterator = { module_type_declaration: iterator -> module_type_declaration -> unit; open_declaration: iterator -> open_declaration -> unit; open_description: iterator -> open_description -> unit; + package_type: iterator -> package_type -> unit; pat: iterator -> pattern -> unit; payload: iterator -> payload -> unit; signature: iterator -> signature -> unit; diff --git a/upstream/ocaml_flambda/parsing/ast_mapper.ml b/upstream/ocaml_flambda/parsing/ast_mapper.ml index aa714d9ce..316111f5f 100644 --- a/upstream/ocaml_flambda/parsing/ast_mapper.ml +++ b/upstream/ocaml_flambda/parsing/ast_mapper.ml @@ -70,6 +70,7 @@ type mapper = { -> module_type_declaration; open_declaration: mapper -> open_declaration -> open_declaration; open_description: mapper -> open_description -> open_description; + package_type: mapper -> package_type -> package_type; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; signature: mapper -> signature -> signature; @@ -96,20 +97,40 @@ let map_opt f = function None -> None | Some x -> Some (f x) let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} +let rec map_lid sub lid = + let open Longident in + match lid with + | Lident id -> Lident id + | Ldot (lid, id) -> + let lid = { lid with txt = map_lid sub lid.txt } in + Ldot (map_loc sub lid, map_loc sub id) + | Lapply (lid, lid') -> + let lid = { lid with txt = map_lid sub lid.txt } in + let lid' = { lid' with txt = map_lid sub lid'.txt } in + Lapply(map_loc sub lid, map_loc sub lid') + +let map_loc_lid sub {loc; txt} = + let txt = map_lid sub txt in + map_loc sub {loc; txt} + module C = struct (* Constants *) - let map sub c = match c with - | Pconst_integer _ - | Pconst_unboxed_integer _ - | Pconst_char _ - | Pconst_untagged_char _ - | Pconst_float _ - | Pconst_unboxed_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_unboxed_integer _ + | Pconst_char _ + | Pconst_untagged_char _ + | Pconst_float _ + | Pconst_unboxed_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 @@ -150,8 +171,6 @@ module T = struct let map_bound_vars sub bound_vars = List.map (var_jkind sub) bound_vars - let map_labeled_tuple sub tl = List.map (map_snd (sub.typ sub)) tl - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = let open Typ in let loc = sub.location sub loc in @@ -165,15 +184,17 @@ module T = struct var ~loc ~attrs s jkind | Ptyp_arrow (lab, t1, t2, m1, m2) -> arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) (sub.modes sub m1) (sub.modes sub m2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (map_labeled_tuple sub tyl) + | Ptyp_tuple tyl -> + tuple ~loc ~attrs (List.map (fun (l, t) -> l, sub.typ sub t) tyl) | Ptyp_unboxed_tuple tyl -> - unboxed_tuple ~loc ~attrs (map_labeled_tuple sub tyl) + unboxed_tuple ~loc ~attrs + (List.map (fun (l, t) -> l, sub.typ sub t) tyl) | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + constr ~loc ~attrs (map_loc_lid 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) + class_ ~loc ~attrs (map_loc_lid sub lid) (List.map (sub.typ sub) tl) | Ptyp_alias (t, s, jkind) -> let s = map_opt (map_loc sub) s in let jkind = map_opt (sub.jkind_annotation sub) jkind in @@ -189,11 +210,10 @@ module T = struct in let t = sub.typ sub t in poly ~loc ~attrs sl t - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_package ptyp -> + package ~loc ~attrs (sub.package_type sub ptyp) | Ptyp_open (mod_ident, t) -> - open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t) + open_ ~loc ~attrs (map_loc_lid sub mod_ident) (sub.typ sub t) | Ptyp_quote t -> quote ~loc ~attrs (sub.typ sub t) | Ptyp_splice t -> @@ -259,7 +279,7 @@ module T = struct 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) + (map_loc_lid sub ptyext_path) (List.map (sub.extension_constructor sub) ptyext_constructors) ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) ~priv:ptyext_private @@ -277,7 +297,7 @@ module T = struct map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) | Pext_rebind li -> - Pext_rebind (map_loc sub li) + Pext_rebind (map_loc_lid sub li) let map_extension_constructor sub {pext_name; @@ -291,6 +311,12 @@ module T = struct name (map_extension_constructor_kind sub pext_kind) + let map_package_type sub {ppt_loc; ppt_path; ppt_cstrs; ppt_attrs} = + let loc = sub.location sub ppt_loc in + let attrs = sub.attributes sub ppt_attrs in + Typ.package_type ~loc ~attrs (map_loc_lid sub ppt_path) + (List.map (map_tuple (map_loc_lid sub) (sub.typ sub)) ppt_cstrs) + end module CT = struct @@ -302,7 +328,7 @@ module CT = struct 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) + constr ~loc ~attrs (map_loc_lid 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) @@ -344,8 +370,8 @@ module MT = struct 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_ident s -> ident ~loc ~attrs (map_loc_lid sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc_lid sub s) | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) | Pmty_functor (param, mt, mm) -> functor_ ~loc ~attrs ~ret_mode:(sub.modes sub mm) @@ -363,21 +389,21 @@ module MT = struct let map_with_constraint sub = function | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) + Pwith_type (map_loc_lid sub lid, sub.type_declaration sub d) | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) + Pwith_module (map_loc_lid sub lid, map_loc_lid sub lid2) | Pwith_modtype (lid, mty) -> - Pwith_modtype (map_loc sub lid, sub.module_type sub mty) + Pwith_modtype (map_loc_lid sub lid, sub.module_type sub mty) | Pwith_jkind (lid, d) -> - Pwith_jkind (map_loc sub lid, sub.jkind_declaration sub d) + Pwith_jkind (map_loc_lid sub lid, sub.jkind_declaration sub d) | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) + Pwith_typesubst (map_loc_lid sub lid, sub.type_declaration sub d) | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) + Pwith_modsubst (map_loc_lid sub s, map_loc_lid sub lid) | Pwith_modtypesubst (lid, mty) -> - Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) + Pwith_modtypesubst (map_loc_lid sub lid, sub.module_type sub mty) | Pwith_jkindsubst (lid, d) -> - Pwith_jkindsubst (map_loc sub lid, sub.jkind_declaration sub d) + Pwith_jkindsubst (map_loc_lid sub lid, sub.jkind_declaration sub d) let map_signature_item sub {psig_desc = desc; psig_loc = loc} = let open Sig in @@ -418,7 +444,7 @@ module M = struct 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_ident x -> ident ~loc ~attrs (map_loc_lid sub x) | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) | Pmod_functor (param, body) -> functor_ ~loc ~attrs @@ -502,11 +528,11 @@ module E = struct } let map_block_access sub = function - | Baccess_field lid -> Baccess_field (map_loc sub lid) + | Baccess_field lid -> Baccess_field (map_loc_lid sub lid) | Baccess_block (mut, e) -> Baccess_block (mut, sub.expr sub e) let map_unboxed_access sub = function - | Uaccess_unboxed_field lid -> Uaccess_unboxed_field (map_loc sub lid) + | Uaccess_unboxed_field lid -> Uaccess_unboxed_field (map_loc_lid sub lid) let map_iterator sub = function | Pcomp_range { start; stop; direction } -> @@ -536,13 +562,12 @@ module E = struct | Pcomp_array_comprehension (mut, comp) -> Pcomp_array_comprehension (mut, map_comp sub comp) - let map_ltexp sub el = List.map (map_snd (sub.expr sub)) el 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_ident x -> ident ~loc ~attrs (map_loc_lid sub x) | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) | Pexp_let (m, r, vbs, e) -> let_ ~loc ~attrs m r (List.map (sub.value_binding sub) vbs) @@ -560,26 +585,28 @@ module E = struct | Pexp_unboxed_unit -> unboxed_unit ~loc ~attrs () | Pexp_unboxed_bool b -> unboxed_bool ~loc ~attrs b | Pexp_tuple el -> - tuple ~loc ~attrs (map_ltexp sub el) + tuple ~loc ~attrs (List.map (fun (l, e) -> l, sub.expr sub e) el) | Pexp_unboxed_tuple el -> - unboxed_tuple ~loc ~attrs (map_ltexp sub el) + unboxed_tuple ~loc ~attrs + (List.map (fun (l, e) -> l, sub.expr sub e) el) | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + construct ~loc ~attrs (map_loc_lid 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) + record ~loc ~attrs + (List.map (map_tuple (map_loc_lid sub) (sub.expr sub)) l) (map_opt (sub.expr sub) eo) | Pexp_record_unboxed_product (l, eo) -> record_unboxed_product ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (List.map (map_tuple (map_loc_lid 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) + field ~loc ~attrs (sub.expr sub e) (map_loc_lid sub lid) | Pexp_unboxed_field (e, lid) -> - unboxed_field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + unboxed_field ~loc ~attrs (sub.expr sub e) (map_loc_lid sub lid) | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) + setfield ~loc ~attrs (sub.expr sub e1) (map_loc_lid sub lid) (sub.expr sub e2) | Pexp_array (mut, el) -> array ~loc ~attrs mut (List.map (sub.expr sub) el) | Pexp_idx (ba, uas) -> @@ -602,7 +629,7 @@ module E = struct constraint_ ~loc ~attrs (sub.expr sub e) (Option.map (sub.typ sub) t) (sub.modes sub m) | 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_new lid -> new_ ~loc ~attrs (map_loc_lid sub lid) | Pexp_setvar (s, e) -> setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_override sel -> @@ -624,7 +651,9 @@ module E = struct newtype ~loc ~attrs (map_loc sub s) (map_opt (sub.jkind_annotation sub) jkind) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_pack (me, optyp) -> + let optyp = Option.map (sub.package_type sub) optyp in + pack ~loc ~attrs (sub.module_expr sub me) optyp | Pexp_open (o, e) -> open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) | Pexp_letop {let_; ands; body} -> @@ -653,8 +682,6 @@ end module P = struct (* Patterns *) - let map_ltpat sub pl = List.map (map_snd (sub.pat sub)) pl - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = let open Pat in let loc = sub.location sub loc in @@ -668,11 +695,13 @@ module P = struct interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) | Ppat_unboxed_unit -> unboxed_unit ~loc ~attrs () | Ppat_unboxed_bool b -> unboxed_bool ~loc ~attrs b - | Ppat_tuple (pl, c) -> tuple ~loc ~attrs (map_ltpat sub pl) c + | Ppat_tuple (pl,c) -> + tuple ~loc ~attrs (List.map (fun (l, p) -> l, sub.pat sub p) pl) c | Ppat_unboxed_tuple (pl, c) -> - unboxed_tuple ~loc ~attrs (map_ltpat sub pl) c + unboxed_tuple ~loc ~attrs + (List.map (fun (l, p) -> l, sub.pat sub p) pl) c | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) + construct ~loc ~attrs (map_loc_lid sub l) (map_opt (fun (vl, p) -> List.map @@ -684,7 +713,7 @@ module P = struct | 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 + (List.map (map_tuple (map_loc_lid sub) (sub.pat sub)) lpl) cf | Ppat_record_unboxed_product (lpl, cf) -> record_unboxed_product ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf @@ -692,11 +721,14 @@ module P = struct | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_constraint (p, t, m) -> constraint_ ~loc ~attrs (sub.pat sub p) (Option.map (sub.typ sub) t) (sub.modes sub m) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_type s -> type_ ~loc ~attrs (map_loc_lid 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_open (lid,p) -> + open_ ~loc ~attrs (map_loc_lid 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 @@ -709,7 +741,7 @@ module CE = struct 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) + constr ~loc ~attrs (map_loc_lid 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) -> @@ -805,6 +837,7 @@ let default_mapper = type_extension = T.map_type_extension; type_exception = T.map_type_exception; extension_constructor = T.map_extension_constructor; + package_type = T.map_package_type; value_description = (fun this {pval_name; pval_type; pval_modalities; pval_prim; pval_poly; pval_loc; pval_attributes} -> @@ -836,7 +869,7 @@ let default_mapper = (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> Ms.mk (map_loc this pms_name) - (map_loc this pms_manifest) + (map_loc_lid this pms_manifest) ~attrs:(this.attributes this pms_attributes) ~loc:(this.location this pms_loc) ); @@ -868,7 +901,7 @@ let default_mapper = open_description = (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) + Opn.mk (map_loc_lid this popen_expr) ~override:popen_override ~loc:(this.location this popen_loc) ~attrs:(this.attributes this popen_attributes) @@ -1011,7 +1044,10 @@ let default_mapper = directive_argument = (fun this a -> - { pdira_desc= a.pdira_desc + { pdira_desc= begin match a.pdira_desc with + | Pdir_ident lid -> Pdir_ident (map_lid this lid) + | Pdir_int _ | Pdir_bool _ | Pdir_string _ as x -> x + end ; pdira_loc= this.location this a.pdira_loc} ); toplevel_directive = @@ -1033,17 +1069,17 @@ let extension_of_error {kind; main; sub} = let extension_of_sub sub = { loc = sub.loc; txt = "ocaml.error" }, PStr ([Str.eval (Exp.constant - (Pconst_string (str_of_msg 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_msg 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 @@ -1064,7 +1100,7 @@ module PpxContext = struct open Asttypes open Ast_helper - let lid name = { txt = Lident name; loc = Location.none } + let lid name = mknoloc (Lident name) let make_string s = Exp.constant (Const.string s) @@ -1076,7 +1112,8 @@ module PpxContext = struct let rec make_list f lst = match lst with | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [None, f x; None, make_list f rest])) + Exp.construct (lid "::") + (Some (Exp.tuple [None, f x; None, make_list f rest])) | [] -> Exp.construct (lid "[]") None @@ -1129,7 +1166,7 @@ module PpxContext = struct 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 "no_alias_deps", make_bool !Clflags.no_alias_deps; lid "unboxed_types", make_bool !Clflags.unboxed_types; lid "unsafe_string", make_bool false; (* kept for compatibility *) get_cookies () @@ -1147,7 +1184,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 = @@ -1163,7 +1201,8 @@ module PpxContext = struct and get_list elem = function | {pexp_desc = Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [None, exp; None, rest]}) } -> + Some {pexp_desc = Pexp_tuple [None, exp; + None, rest]}) } -> elem exp :: get_list elem rest | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> @@ -1177,10 +1216,12 @@ module PpxContext = struct { %s }] pair syntax" name and get_option elem = function | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> + Pexp_construct ({ txt = Longident.Lident "Some" }, + Some exp) } -> Some (elem exp) | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> + Pexp_construct ({ txt = Longident.Lident "None" }, + None) } -> None | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ { %s }] option syntax" name @@ -1233,8 +1274,8 @@ module PpxContext = struct Clflags.recursive_types := get_bool payload | "principal" -> Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload + | "no_alias_deps" -> + Clflags.no_alias_deps := get_bool payload | "unboxed_types" -> Clflags.unboxed_types := get_bool payload | "cookies" -> diff --git a/upstream/ocaml_flambda/parsing/ast_mapper.mli b/upstream/ocaml_flambda/parsing/ast_mapper.mli index e2e8dbb54..8e6b1ca75 100644 --- a/upstream/ocaml_flambda/parsing/ast_mapper.mli +++ b/upstream/ocaml_flambda/parsing/ast_mapper.mli @@ -105,6 +105,7 @@ type mapper = { -> module_type_declaration; open_declaration: mapper -> open_declaration -> open_declaration; open_description: mapper -> open_description -> open_description; + package_type: mapper -> package_type -> package_type; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; signature: mapper -> signature -> signature; diff --git a/upstream/ocaml_flambda/parsing/asttypes.ml b/upstream/ocaml_flambda/parsing/asttypes.ml new file mode 100644 index 000000000..bf631bf38 --- /dev/null +++ b/upstream/ocaml_flambda/parsing/asttypes.ml @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* 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 atomic_flag = Nonatomic | Atomic + +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 + | Bivariant + +type injectivity = + | Injective + | NoInjectivity + +let string_of_label = function + Nolabel -> "" + | Labelled s -> s + | Optional s -> "?"^s diff --git a/upstream/ocaml_flambda/parsing/asttypes.mli b/upstream/ocaml_flambda/parsing/asttypes.mli index 11594108c..db001848d 100644 --- a/upstream/ocaml_flambda/parsing/asttypes.mli +++ b/upstream/ocaml_flambda/parsing/asttypes.mli @@ -40,6 +40,8 @@ type private_flag = Private | Public type mutable_flag = Immutable | Mutable +type atomic_flag = Nonatomic | Atomic + type virtual_flag = Virtual | Concrete type override_flag = Override | Fresh @@ -64,8 +66,10 @@ type variance = | Covariant | Contravariant | NoVariance + | Bivariant type injectivity = | Injective | NoInjectivity +val string_of_label: arg_label -> string diff --git a/upstream/ocaml_flambda/parsing/builtin_attributes.ml b/upstream/ocaml_flambda/parsing/builtin_attributes.ml index d646f0a34..3b813b802 100644 --- a/upstream/ocaml_flambda/parsing/builtin_attributes.ml +++ b/upstream/ocaml_flambda/parsing/builtin_attributes.ml @@ -32,14 +32,6 @@ let mark_used t = Attribute_table.remove unused_attrs t *) let attr_order a1 a2 = Location.compare a1.loc a2.loc -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 unchecked_zero_alloc_attributes = Attribute_table.create 1 let mark_zero_alloc_attribute_checked txt loc = Attribute_table.remove unchecked_zero_alloc_attributes { txt; loc } @@ -62,6 +54,14 @@ let warn_unchecked_zero_alloc_attribute () = keys; Warnings.restore w_old +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; @@ -160,11 +160,13 @@ let ident_of_payload = function Some id | _ -> None -let string_of_cst = function +let string_of_cst const = + match const.pconst_desc with | Pconst_string(s, _, _) -> Some s | _ -> None -let int_of_cst = function +let int_of_cst const = + match const.pconst_desc with | Pconst_integer(i, None) -> Some (int_of_string i) | _ -> None @@ -190,7 +192,8 @@ let error_of_extension ext = (({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.msg ~loc "%a" Format_doc.pp_print_text msg | _ -> @@ -210,7 +213,8 @@ let error_of_extension ext = 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_doc.pp_print_text msg @@ -263,7 +267,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[ @@ -377,7 +382,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 @@ -414,7 +419,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)) @@ -516,6 +521,7 @@ let explicit_arity attrs = has_attribute "explicit_arity" attrs let has_unboxed attrs = has_attribute "unboxed" attrs let has_boxed attrs = has_attribute "boxed" attrs +let has_atomic attrs = has_attribute "atomic" attrs let has_unsafe_allow_any_mode_crossing attrs = has_attribute "unsafe_allow_any_mode_crossing" attrs @@ -815,7 +821,9 @@ let get_optional_payload get_from_exp = let get_int_from_exp = let open Parsetree in function - | { pexp_desc = Pexp_constant (Pconst_integer(s, None)) } -> + | { pexp_desc = + Pexp_constant {pconst_desc=Pconst_integer(s, None); _} + } -> begin match Misc.Int_literal_converter.int s with | n -> Result.Ok n | exception (Failure _) -> Result.Error () @@ -855,8 +863,12 @@ let get_id_or_constant_from_exp = let open Parsetree in function | { pexp_desc = Pexp_ident { txt = Longident.Lident id } } -> Result.Ok (Ident, id) - | { pexp_desc = Pexp_constant (Pconst_integer (s,None)) } -> Result.Ok (Const_int, s) - | { pexp_desc = Pexp_constant (Pconst_string (s,_loc,_so)) } -> Result.Ok (Const_string, s) + | { pexp_desc = + Pexp_constant {pconst_desc=Pconst_integer (s,None); _} + } -> Result.Ok (Const_int, s) + | { pexp_desc = + Pexp_constant {pconst_desc=Pconst_string (s,_loc,_so); _} + } -> Result.Ok (Const_string, s) | _ -> Result.Error () let get_ids_and_constants_from_exp exp = @@ -1148,7 +1160,10 @@ let get_tracing_probe_payload (payload : Parsetree.payload) = ({ pexp_desc = (Pexp_apply ({ pexp_desc= - (Pexp_constant (Pconst_string(name,_,None))); + (Pexp_constant + {pconst_desc= + Pconst_string(name,_,None); + _}); pexp_loc = name_loc; _ } , args)) @@ -1174,5 +1189,3 @@ let get_tracing_probe_payload (payload : Parsetree.payload) = | _ -> Error () in Ok { name; name_loc; enabled_at_init; arg } - -let has_atomic attrs = has_attribute "atomic" attrs diff --git a/upstream/ocaml_flambda/parsing/builtin_attributes.mli b/upstream/ocaml_flambda/parsing/builtin_attributes.mli index 5e24f77e0..9ea04a92e 100644 --- a/upstream/ocaml_flambda/parsing/builtin_attributes.mli +++ b/upstream/ocaml_flambda/parsing/builtin_attributes.mli @@ -189,7 +189,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/upstream/ocaml_flambda/parsing/depend.ml b/upstream/ocaml_flambda/parsing/depend.ml index 60555c267..e4b25f239 100644 --- a/upstream/ocaml_flambda/parsing/depend.ml +++ b/upstream/ocaml_flambda/parsing/depend.ml @@ -49,7 +49,7 @@ let rec lookup_free p m = 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)) + | Ldot (l, s) -> String.Map.find s.txt (get_map (lookup_map l.txt m)) | Lapply _ -> raise Not_found let free_structure_names = ref String.Set.empty @@ -65,8 +65,8 @@ let rec add_path bv ?(p=[]) = function (*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 + | Ldot(l, s) -> add_path bv ~p:(s.txt::p) l.txt + | Lapply(l1, l2) -> add_path bv l1.txt; add_path bv l2.txt let open_module bv lid = match lookup_map lid bv with @@ -78,7 +78,7 @@ let open_module bv lid = let add_parent bv lid = match lid.txt with - Ldot(l, _s) -> add_path bv l + Ldot(l, _s) -> add_path bv l.txt | _ -> () let add = add_parent @@ -98,8 +98,8 @@ let rec add_type bv ty = Ptyp_any jkind | Ptyp_var (_, jkind) -> Option.iter (add_jkind bv) jkind | Ptyp_arrow(_, t1, t2, _, _) -> add_type bv t1; add_type bv t2 - | Ptyp_tuple tl -> add_type_labeled_tuple bv tl - | Ptyp_unboxed_tuple tl -> add_type_labeled_tuple bv tl + | Ptyp_tuple tl -> List.iter (fun (_, t) -> add_type bv t) tl + | Ptyp_unboxed_tuple tl -> List.iter (fun (_, t) -> add_type bv t) tl | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl | Ptyp_object (fl, _) -> List.iter @@ -130,12 +130,9 @@ let rec add_type bv ty = | Ptyp_newlayout(_, t) -> add_type bv t | Ptyp_extension e -> handle_extension e -and add_type_labeled_tuple bv tl = - List.iter (fun (_, ty) -> add_type bv ty) tl - -and add_package_type bv (lid, l) = - add bv lid; - List.iter (add_type bv) (List.map (fun (_, e) -> e) l) +and add_package_type bv ptyp = + add bv ptyp.ppt_path; + List.iter (fun (_, ty) -> add_type bv ty) ptyp.ppt_cstrs (* CR layouts: Remember to add this when jkinds can have module prefixes. *) @@ -215,8 +212,8 @@ let rec add_pattern bv pat = | Ppat_constant _ -> () | Ppat_unboxed_unit -> () | Ppat_unboxed_bool _ -> () - | Ppat_tuple (pl, _) -> add_pattern_labeled_tuple bv pl - | Ppat_unboxed_tuple (pl, _)-> add_pattern_labeled_tuple bv pl + | Ppat_tuple (pl, _) -> List.iter (fun (_, p) -> add_pattern bv p) pl + | Ppat_unboxed_tuple (pl, _) -> List.iter (fun (_, p) -> add_pattern bv p) pl | Ppat_construct(c, opt) -> add bv c; add_opt @@ -236,12 +233,10 @@ let rec add_pattern bv pat = 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 -and add_pattern_labeled_tuple bv labeled_pl = - List.iter (fun (_, p) -> add_pattern bv p) labeled_pl - let add_pattern bv pat = pattern_bv := bv; add_pattern bv pat; @@ -263,8 +258,8 @@ let rec add_expr bv exp = | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel | Pexp_unboxed_unit -> () | Pexp_unboxed_bool _ -> () - | Pexp_tuple el -> add_labeled_tuple_expr bv el - | Pexp_unboxed_tuple el -> add_labeled_tuple_expr bv el + | Pexp_tuple el -> List.iter (fun (_, e) -> add_expr bv e) el + | Pexp_unboxed_tuple el -> List.iter (fun (_, e) -> add_expr bv e) 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) @@ -311,7 +306,8 @@ let rec add_expr bv exp = | Pexp_newtype (_, jkind, e) -> Option.iter (add_jkind bv) jkind; add_expr bv e - | Pexp_pack m -> add_module_expr bv m + | Pexp_pack (m, opty) -> + add_module_expr bv m; add_opt add_package_type bv opty | Pexp_open (o, e) -> let bv = open_declaration bv o in add_expr bv e @@ -369,8 +365,6 @@ and add_comprehension_iterator bv = function | Pcomp_in expr -> add_expr bv expr -and add_labeled_tuple_expr bv el = List.iter (add_expr bv) (List.map snd el) - and add_block_access bv = function | Baccess_field fld -> add bv fld | Baccess_block (_, idx) -> @@ -470,7 +464,7 @@ and add_modtype bv mty = 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; + (if !Clflags.no_alias_deps then add_parent else add_module_path) bv l; try lookup_map l.txt bv with Not_found -> @@ -655,7 +649,7 @@ and add_structure_binding bv item_list = (* When we merge [include functor] upstream this can get re-inlined *) and add_include_declaration (bv, m) incl = let Node (s, m') as n = add_module_binding bv incl.pincl_mod in - if !Clflags.transparent_modules then + if !Clflags.no_alias_deps then add_names s else (* If we are not in the delayed dependency mode, we need to diff --git a/upstream/ocaml_flambda/parsing/docstrings.ml b/upstream/ocaml_flambda/parsing/docstrings.ml index a39f75d25..32b8e8c46 100644 --- a/upstream/ocaml_flambda/parsing/docstrings.ml +++ b/upstream/ocaml_flambda/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/upstream/ocaml_flambda/parsing/language_extension.ml b/upstream/ocaml_flambda/parsing/language_extension.ml index bf7cda614..196be4a4d 100644 --- a/upstream/ocaml_flambda/parsing/language_extension.ml +++ b/upstream/ocaml_flambda/parsing/language_extension.ml @@ -70,7 +70,6 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = | Module_strengthening -> (module Unit) | Layouts -> (module Maturity) | SIMD -> (module Maturity) - | Labeled_tuples -> (module Unit) | Small_numbers -> (module Maturity) | Instances -> (module Unit) | Let_mutable -> (module Unit) @@ -88,8 +87,8 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = let is_erasable : type a. a t -> bool = function | Mode | Unique | Overwriting | Layouts | Layout_poly -> true | Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays - | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances - | Let_mutable | Runtime_metaprogramming -> + | Module_strengthening | SIMD | Small_numbers | Instances | Let_mutable + | Runtime_metaprogramming -> false let maturity_of_unique_for_drf = Stable @@ -110,7 +109,6 @@ module Exist_pair = struct | Pair (Module_strengthening, ()) -> Stable | Pair (Layouts, m) -> m | Pair (SIMD, m) -> m - | Pair (Labeled_tuples, ()) -> Stable | Pair (Small_numbers, m) -> m | Pair (Instances, ()) -> Stable | Pair (Let_mutable, ()) -> Stable @@ -130,9 +128,8 @@ module Exist_pair = struct to_string Layout_poly ^ "_" ^ maturity_to_string m | Pair ( (( Comprehensions | Include_functor | Polymorphic_parameters - | Immutable_arrays | Module_strengthening | Labeled_tuples - | Instances | Overwriting | Let_mutable | Runtime_metaprogramming ) - as ext), + | Immutable_arrays | Module_strengthening | Instances | Overwriting + | Let_mutable | Runtime_metaprogramming ) as ext), _ ) -> to_string ext @@ -160,7 +157,6 @@ module Exist_pair = struct | "simd" -> Some (Pair (SIMD, Stable)) | "simd_beta" -> Some (Pair (SIMD, Beta)) | "simd_alpha" -> Some (Pair (SIMD, Alpha)) - | "labeled_tuples" -> Some (Pair (Labeled_tuples, ())) | "small_numbers" -> Some (Pair (Small_numbers, Stable)) | "small_numbers_beta" -> Some (Pair (Small_numbers, Beta)) | "instances" -> Some (Pair (Instances, ())) @@ -187,7 +183,6 @@ let all_extensions = Pack Module_strengthening; Pack Layouts; Pack SIMD; - Pack Labeled_tuples; Pack Small_numbers; Pack Instances; Pack Let_mutable; @@ -228,7 +223,6 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = | Module_strengthening, Module_strengthening -> Some Refl | Layouts, Layouts -> Some Refl | SIMD, SIMD -> Some Refl - | Labeled_tuples, Labeled_tuples -> Some Refl | Small_numbers, Small_numbers -> Some Refl | Instances, Instances -> Some Refl | Let_mutable, Let_mutable -> Some Refl @@ -236,8 +230,8 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = | Runtime_metaprogramming, Runtime_metaprogramming -> Some Refl | ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor | Polymorphic_parameters | Immutable_arrays | Module_strengthening - | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances - | Let_mutable | Layout_poly | Runtime_metaprogramming ), + | Layouts | SIMD | Small_numbers | Instances | Let_mutable | Layout_poly + | Runtime_metaprogramming ), _ ) -> None diff --git a/upstream/ocaml_flambda/parsing/language_extension.mli b/upstream/ocaml_flambda/parsing/language_extension.mli index 724b3feef..0ffebeec4 100644 --- a/upstream/ocaml_flambda/parsing/language_extension.mli +++ b/upstream/ocaml_flambda/parsing/language_extension.mli @@ -27,7 +27,6 @@ type 'a t = 'a Language_extension_kernel.t = | Module_strengthening : unit t | Layouts : maturity t | SIMD : maturity t - | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : unit t | Let_mutable : unit t diff --git a/upstream/ocaml_flambda/parsing/lexer.mli b/upstream/ocaml_flambda/parsing/lexer.mli index 67b7defa0..a7abbbc09 100644 --- a/upstream/ocaml_flambda/parsing/lexer.mli +++ b/upstream/ocaml_flambda/parsing/lexer.mli @@ -20,9 +20,9 @@ *) -val init : unit -> unit -val token : Lexing.lexbuf -> Parser.token -val skip_hash_bang : Lexing.lexbuf -> unit +val init : ?keyword_edition:((int*int) option * string list) -> unit -> unit +val token: Lexing.lexbuf -> Parser.token +val skip_hash_bang: Lexing.lexbuf -> unit type error = | Illegal_character of char @@ -33,8 +33,14 @@ 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 + | Unknown_keyword of string exception Error of error * Location.t diff --git a/upstream/ocaml_flambda/parsing/lexer.mll b/upstream/ocaml_flambda/parsing/lexer.mll index 95e7cab56..1bd424121 100644 --- a/upstream/ocaml_flambda/parsing/lexer.mll +++ b/upstream/ocaml_flambda/parsing/lexer.mll @@ -29,93 +29,122 @@ 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 + | Unknown_keyword 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; - "else", ELSE; - "end", END; - "exception", EXCEPTION; - "exclave_", EXCLAVE; - "external", EXTERNAL; - "false", FALSE; - "for", FOR; - "fun", FUN; - "function", FUNCTION; - "functor", FUNCTOR; - "global_", GLOBAL; - "if", IF; - "in", IN; - "include", INCLUDE; - "inherit", INHERIT; - "initializer", INITIALIZER; - "kind_", KIND; - "kind_of_", KIND_OF; - "layout_", LAYOUT; - "lazy", LAZY; - "let", LET; - "local_", LOCAL; - "match", MATCH; - "method", METHOD; - "mod", MOD; - "module", MODULE; - "mutable", MUTABLE; - "new", NEW; - "nonrec", NONREC; - "object", OBJECT; - "of", OF; - "once_", ONCE; - "open", OPEN; - "or", OR; - "overwrite_", OVERWRITE; +let all_keywords = + let v5_3 = Some (5,3) in + let v1_0 = Some (1,0) in + let v1_6 = Some (1,6) in + let v4_2 = Some (4,2) in + let always = None in + let oxcaml = None in + [ + "and", AND, always; + "as", AS, always; + "assert", ASSERT, v1_6; + "begin", BEGIN, always; + "borrow_", BORROW, oxcaml; + "class", CLASS, v1_0; + "constraint", CONSTRAINT, v1_0; + "do", DO, always; + "done", DONE, always; + "downto", DOWNTO, always; + "effect", EFFECT, v5_3; + "else", ELSE, always; + "end", END, always; + "exception", EXCEPTION, always; + "exclave_", EXCLAVE, oxcaml; + "external", EXTERNAL, always; + "false", FALSE, always; + "for", FOR, always; + "fun", FUN, always; + "function", FUNCTION, always; + "functor", FUNCTOR, always; + "global_", GLOBAL, oxcaml; + "if", IF, always; + "in", IN, always; + "include", INCLUDE, always; + "inherit", INHERIT, v1_0; + "initializer", INITIALIZER, v1_0; + "kind_", KIND, oxcaml; + "kind_of_", KIND_OF, oxcaml; + "layout_", LAYOUT, oxcaml; + "lazy", LAZY, v1_6; + "let", LET, always; + "local_", LOCAL, oxcaml; + "match", MATCH, always; + "method", METHOD, v1_0; + "mod", MOD, always; + "module", MODULE, always; + "mutable", MUTABLE, always; + "new", NEW, v1_0; + "nonrec", NONREC, v4_2; + "object", OBJECT, v1_0; + "of", OF, always; + "once_", ONCE, oxcaml; + "open", OPEN, always; + "or", OR, always; + "overwrite_", OVERWRITE, oxcaml; (* "parser", PARSER; *) - "poly_", POLY; - "private", PRIVATE; - "rec", REC; - "repr_", REPR; - "sig", SIG; - "stack_", STACK; - "borrow_", BORROW; - "struct", STRUCT; - "then", THEN; - "to", TO; - "true", TRUE; - "try", TRY; - "type", TYPE; - "unique_", UNIQUE; - "val", VAL; - "virtual", VIRTUAL; - "when", WHEN; - "while", WHILE; - "with", WITH; - - "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) - "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) - "land", INFIXOP3("land"); - "lsl", INFIXOP4("lsl"); - "lsr", INFIXOP4("lsr"); - "asr", INFIXOP4("asr") + "poly_", POLY, oxcaml; + "private", PRIVATE, v1_0; + "rec", REC, always; + "repr_", REPR, oxcaml; + "sig", SIG, always; + "stack_", STACK, oxcaml; + "struct", STRUCT, always; + "then", THEN, always; + "to", TO, always; + "true", TRUE, always; + "try", TRY, always; + "type", TYPE, always; + "unique_", UNIQUE, oxcaml; + "val", VAL, always; + "virtual", VIRTUAL, v1_0; + "when", WHEN, always; + "while", WHILE, always; + "with", WITH, always; + + "lor", INFIXOP3("lor"), always; (* Should be INFIXOP2 *) + "lxor", INFIXOP3("lxor"), always; (* Should be INFIXOP2 *) + "land", INFIXOP3("land"), always; + "lsl", INFIXOP4("lsl"), always; + "lsr", INFIXOP4("lsr"), always; + "asr", INFIXOP4("asr"), always ] -let lookup_keyword name = - match Hashtbl.find keyword_table name with - | kw -> kw - | exception Not_found -> - LIDENT name + +let keyword_table = Hashtbl.create 149 + +let populate_keywords (version,keywords) = + let greater (x:(int*int) option) (y:(int*int) option) = + match x, y with + | None, _ | _, None -> true + | Some x, Some y -> x >= y + in + let tbl = keyword_table in + Hashtbl.clear tbl; + let add_keyword (name, token, since) = + if greater version since then Hashtbl.replace tbl name (Some token) + in + List.iter add_keyword all_keywords; + List.iter (fun name -> + match List.find (fun (n,_,_) -> n = name) all_keywords with + | (_,tok,_) -> Hashtbl.replace tbl name (Some tok) + | exception Not_found -> Hashtbl.replace tbl name None + ) keywords + (* To buffer string literals *) @@ -405,13 +434,53 @@ let uchar_for_uchar_escape lexbuf = 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 = - match lookup_keyword name with - | LIDENT _ -> false - | _ -> true + Hashtbl.mem keyword_table name -let check_label_name lexbuf name = - if is_keyword name then error lexbuf (Keyword_as_label name) +let find_keyword lexbuf name = + match Hashtbl.find keyword_table name with + | Some x -> x + | None -> error lexbuf (Unknown_keyword name) + | exception Not_found -> LIDENT 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. *) @@ -431,13 +500,6 @@ let preprocessor = ref None 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 [] @@ -513,11 +575,18 @@ 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 %a or a type variable %a?" + Style.inline_code "' '" + Style.inline_code "'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) -> @@ -525,6 +594,25 @@ let prepare_error loc = function (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+%04X 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 + | Unknown_keyword name -> + Location.errorf ~loc + "%a has been defined as an additional keyword.@ \ + This version of OCaml does not support this keyword." + Style.inline_code name let () = Location.register_error_of_exn @@ -541,12 +629,15 @@ 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 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 delim_ext = (lowercase | uppercase | utf8)* +(* ascii uppercase letters in quoted string delimiters ({delim||delim}) are + rejected by the delimiter validation function, we accept them temporarily to + have the same error message for ascii and non-ascii uppercase letters *) let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] @@ -557,8 +648,8 @@ let symbolchar_or_hash = 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' '_']* @@ -601,59 +692,49 @@ rule token = parse | ".~" { 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? 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 identifiers are split into 3 cases, and the order matters (longest to shortest). *) | (lowercase identchar * as name) ('#' symbolchar_or_hash+ as hashop) (* See Note [Lexing hack for hash operators] *) { enqueue_hashop_from_end_of_lexbuf_window lexbuf ~hashop; - lookup_keyword name } + find_keyword lexbuf name } | (lowercase identchar * as name) '#' (* See Note [Lexing hack for float#] *) { enqueue_hash_suffix_from_end_of_lexbuf_window lexbuf; - lookup_keyword name } - | raw_ident_escape (lowercase identchar * as name) - { LIDENT name } + find_keyword lexbuf name } | lowercase identchar * as name - { lookup_keyword name } - (* Lowercase latin1 identifiers are split into 3 cases, and the order matters - (longest to shortest). - *) - | (lowercase_latin1 identchar_latin1 * as name) - ('#' symbolchar_or_hash+ as hashop) - (* See Note [Lexing hack for hash operators] *) - { warn_latin1 lexbuf; - enqueue_hashop_from_end_of_lexbuf_window lexbuf ~hashop; - LIDENT name } - | (lowercase_latin1 identchar_latin1 * as name) '#' - (* See Note [Lexing hack for float#] *) - { warn_latin1 lexbuf; - enqueue_hash_suffix_from_end_of_lexbuf_window lexbuf; - LIDENT name } - | lowercase_latin1 identchar_latin1 * as name - { warn_latin1 lexbuf; LIDENT name } + { find_keyword lexbuf 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 *) (* This matches either an integer literal or a directive. If the text "#2" appears at the beginning of a line that lexes as a directive, then it should be treated as a directive and not an unboxed int. This is acceptable @@ -680,26 +761,34 @@ rule token = parse | "\"" { 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) "|" + | "{" (delim_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+ (delim_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+ (delim_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) } @@ -967,8 +1056,10 @@ and comment = parse is_in_string := false; store_string_char '\"'; comment lexbuf } - | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|" - { + | "{" ('%' '%'? extattrident blank*)? (delim_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; @@ -1018,7 +1109,7 @@ and comment = parse store_normalized_newline nl; comment lexbuf } - | ident + | ident_ext { store_lexeme lexbuf; comment lexbuf } | _ { store_lexeme lexbuf; comment lexbuf } @@ -1082,8 +1173,9 @@ and quoted_string delim = parse | 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) } @@ -1201,7 +1293,8 @@ and skip_hash_bang = parse in loop NoLine Initial lexbuf - let init () = + let init ?(keyword_edition=None,[]) () = + populate_keywords keyword_edition; is_in_string := false; comment_start_loc := []; comment_list := []; diff --git a/upstream/ocaml_flambda/parsing/location.ml b/upstream/ocaml_flambda/parsing/location.ml index 9099969ae..dd475f243 100644 --- a/upstream/ocaml_flambda/parsing/location.ml +++ b/upstream/ocaml_flambda/parsing/location.ml @@ -342,7 +342,6 @@ module Doc = struct 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 %a" (capitalize "line") linenum startline @@ -785,6 +784,7 @@ type report = { kind : report_kind; main : msg; sub : msg list; + footnote: Fmt.t option; } type report_printer = { @@ -861,27 +861,47 @@ let batch_mode_printer : report_printer = | Misc.Error_style.Short -> () in - Format.fprintf ppf "@[%a:@ %a@]" print_loc 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 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@]@." + 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 error_format self ppf report = + 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 warning_format self ppf report = + Format.fprintf ppf "@[%a@[%a: %a@]%a%a@]@." + (self.pp_main_loc self report) report.main.loc + (self.pp_report_kind self report) report.kind + (self.pp_main_txt self report) report.main.txt + (self.pp_submsgs self report) report.sub + pp_footnote report.footnote + in + let pp self ppf report = + setup_tags (); + separate_new_message ppf; + let printer ppf () = match report.kind with + | Report_warning _ + | Report_warning_as_error _ + | Report_alert _ | Report_alert_as_error _ -> + warning_format self ppf report + | Report_error -> error_format self ppf report + in + (* 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 printer () in let pp_report_kind _self _ ppf = function | Report_error -> Format.fprintf ppf "@{Error@}" @@ -904,9 +924,12 @@ let batch_mode_printer : report_printer = ) 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 + if loc.loc_ghost then + Format.fprintf ppf "@[%a@]" (self.pp_submsg_txt self report) txt + else + 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 (is_dummy_loc loc) then @@ -961,21 +984,31 @@ 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 = - { 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 = []) = - Fmt.kdoc_printf (mkerror loc sub) +let errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = + Fmt.kdoc_printf (mkerror loc sub footnote) +let aligned_error_hint + ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) fmt = + Fmt.kdoc_printf (fun main hint -> + match hint with + | None -> mkerror loc sub footnote main + | Some hint -> + let main, hint = Misc.align_error_hint ~main ~hint in + mkerror loc (mknoloc hint :: sub) footnote main + ) fmt -let error ?(loc = none) ?(sub = []) msg_str = - mkerror loc sub (Fmt.Doc.string msg_str Fmt.Doc.empty) +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 (Fmt.doc_printf "%a" pp 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 @@ -988,13 +1021,12 @@ 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 main = { loc; txt = message } in let sub = List.map (fun (loc, sub_message) -> - { loc; txt = msg_of_str sub_message } + { loc; txt = sub_message } ) sub_locs in - Some { kind; main; sub } + Some { kind; main; sub; footnote=None } let default_warning_reporter = @@ -1129,8 +1161,8 @@ let () = | _ -> None ) -let raise_errorf ?(loc = none) ?(sub = []) = - Fmt.kdoc_printf (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))) let todo_overwrite_not_implemented ?(kind = "") t = alert ~kind t "Overwrite not implemented."; diff --git a/upstream/ocaml_flambda/parsing/location.mli b/upstream/ocaml_flambda/parsing/location.mli index c552a0553..a7bfd8952 100644 --- a/upstream/ocaml_flambda/parsing/location.mli +++ b/upstream/ocaml_flambda/parsing/location.mli @@ -43,7 +43,31 @@ type t = Warnings.loc = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool; -} + } +(** [t] represents a range of characters in the source code. + + loc_ghost=false whenever the AST described by the location can be parsed + from the location. In all other cases, loc_ghost must be true. Most + locations produced by the parser have loc_ghost=false. + When loc_ghost=true, the location is usually a best effort approximation. + + This info is used by tools like merlin that want to relate source code with + parsetrees or later asts. ocamlprof skips instrumentation of ghost nodes. + + Example: in `let f x = x`, we have: + - a structure item at location "let f x = x" + - a pattern "f" at location "f" + - an expression "fun x -> x" at location "x = x" with loc_ghost=true + - a pattern "x" at location "x" + - an expression "x" at location "x" + In this case, every node has loc_ghost=false, except the node "fun x -> x", + since [Parser.expression (Lexing.from_string "x = x")] would fail to parse. + By contrast, in `let f = fun x -> x`, every node has loc_ghost=false. + + Line directives can modify the filenames and line numbers arbitrarily, + which is orthogonal to loc_ghost, which describes the range of characters + from loc_start.pos_cnum to loc_end.pos_cnum in the parsed string. + *) (** Note on the use of Lexing.position in this module. If [pos_fname = ""], then use [!input_name] instead. @@ -245,6 +269,7 @@ type report = { kind : report_kind; main : msg; sub : msg list; + footnote: Format_doc.t option } type report_printer = { @@ -366,12 +391,21 @@ 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 -> 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 -> +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 -> +val aligned_error_hint: + ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> + ('a, Format_doc.formatter, unit, Format_doc.t option -> error) format4 -> 'a +(** [aligned_error_hint ?loc ?sub ?footnote fmt ... aligned_hint] produces an + error report where the potential [aligned_hint] message has been aligned + with the main error message before being added to the list of submessages.*) + +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 @@ -397,7 +431,7 @@ 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 -> +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 diff --git a/upstream/ocaml_flambda/parsing/longident.ml b/upstream/ocaml_flambda/parsing/longident.ml index eaafb02be..588e8e1fe 100644 --- a/upstream/ocaml_flambda/parsing/longident.ml +++ b/upstream/ocaml_flambda/parsing/longident.ml @@ -12,22 +12,41 @@ (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) +open Location type t = Lident of string - | Ldot of t * string - | Lapply of t * t + | Ldot of t loc * string loc + | Lapply of t loc * t loc + + +let rec same t t' = + t == t' + || match t, t' with + | Lident s, Lident s' -> + String.equal s s' + | Ldot ({ txt = t; _ }, { txt = s; _ }), + Ldot ({ txt = t'; _ }, { txt = s'; _ }) -> + if String.equal s s' then + same t t' + else + false + | Lapply ({ txt = tl; _ }, { txt = tr; _ }), + Lapply ({ txt = tl'; _ }, { txt = tr'; _ }) -> + same tl tl' && same tr tr' + | _, _ -> false + let rec flat accu = function Lident s -> s :: accu - | Ldot(lid, s) -> flat (s :: accu) lid + | Ldot({ txt = lid; _ }, { txt = 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 + | Ldot(_, s) -> s.txt | Lapply(_, _) -> Misc.fatal_error "Longident.last" @@ -41,7 +60,9 @@ let rec split_at_dots s pos = let unflatten l = match l with | [] -> None - | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) + | hd :: tl -> + Some (List.fold_left (fun p s -> Ldot(mknoloc p, mknoloc s)) + (Lident hd) tl) let parse s = match unflatten (split_at_dots s 0) with diff --git a/upstream/ocaml_flambda/parsing/longident.mli b/upstream/ocaml_flambda/parsing/longident.mli index 8704a7780..168d9000e 100644 --- a/upstream/ocaml_flambda/parsing/longident.mli +++ b/upstream/ocaml_flambda/parsing/longident.mli @@ -23,10 +23,16 @@ *) +open Location + type t = Lident of string - | Ldot of t * string - | Lapply of t * t + | Ldot of t loc * string loc + | Lapply of t loc * t loc + +(** [same t t'] compares the longidents [t] and [t'] without taking locations + into account. *) +val same: t -> t -> bool val flatten: t -> string list val unflatten: string list -> t option diff --git a/upstream/ocaml_flambda/parsing/parse.ml b/upstream/ocaml_flambda/parsing/parse.ml index 77c1a72c1..23d124f13 100644 --- a/upstream/ocaml_flambda/parsing/parse.ml +++ b/upstream/ocaml_flambda/parsing/parse.ml @@ -46,7 +46,10 @@ type 'a parser = let wrap (parser : 'a parser) lexbuf : 'a = try Docstrings.init (); - Lexer.init (); + let keyword_edition = + Clflags.(Option.map parse_keyword_edition !keyword_edition) + in + Lexer.init ?keyword_edition (); let ast = parser token lexbuf in Parsing.clear_parser(); Docstrings.warn_bad_docstrings (); @@ -116,11 +119,11 @@ let prepare_error err = | Unclosed(opening_loc, opening, closing_loc, closing) -> Location.errorf ~loc:closing_loc + "Syntax error: %a expected" Style.inline_code closing ~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." @@ -163,15 +166,20 @@ let prepare_error err = | Misplaced_attribute -> Format_doc.fprintf ppf "an attribute cannot go here" 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 \ - 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" + "Syntax error: strings are immutable,@ there@ is@ no@ assignment@ \ + syntax@ for@ them." + ~sub:[ + Location.msg + "@{Hint@}: Mutable sequences of bytes are available in \ + the %a module." + Style.inline_code "Bytes"; + Location.msg + "@{Hint@}: Did you mean to use %a?" + Style.inline_code "Bytes.set" + ] | Missing_unboxed_literal_suffix loc -> Location.errorf ~loc "Syntax error: Unboxed integer literals require width suffixes." diff --git a/upstream/ocaml_flambda/parsing/parser.mly b/upstream/ocaml_flambda/parsing/parser.mly index 231fe37c5..ae270477a 100644 --- a/upstream/ocaml_flambda/parsing/parser.mly +++ b/upstream/ocaml_flambda/parsing/parser.mly @@ -59,6 +59,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) @@ -91,6 +92,8 @@ let mkcf ~loc ?attrs ?docs d = let mkrhs rhs loc = mkloc rhs (make_loc loc) let ghrhs rhs loc = mkloc rhs (ghost_loc loc) +let ldot lid lid_loc name loc = Ldot (mkrhs lid lid_loc, mkrhs name loc) + let push_loc x acc = if x.Location.loc_ghost then acc @@ -102,7 +105,7 @@ let reloc_pat ~loc x = 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 = +let _reloc_typ ~loc x = { x with ptyp_loc = make_loc loc; ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack } @@ -115,9 +118,14 @@ let mkoperator = let mkpatvar ~loc name = mkpat ~loc (Ppat_var (mkrhs name loc)) -(* See commentary about ghost locations at the declaration of Location.t *) -let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d -let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d +(* + See ./location.mli for when to use a ghost location or not. + + Every grammar rule that generates an element with a location must + make at most one non-ghost element, the topmost one. +*) +let ghexp ~loc ?attrs d = Exp.mk ~loc:(ghost_loc loc) ?attrs d +let ghpat ~loc ?attrs d = Pat.mk ~loc:(ghost_loc loc) ?attrs d let ghtyp ~loc ?attrs d = Typ.mk ~loc:(ghost_loc loc) ?attrs d let ghloc ~loc d = { txt = d; loc = ghost_loc loc } let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d @@ -134,11 +142,14 @@ let neg_string f = then String.sub f 1 (String.length f - 1) else "-" ^ f -let mkuminus ~oploc name arg = +(* 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 = let result = match arg.pexp_desc with | Pexp_constant const -> begin - match name, const with + match name, const.pconst_desc with | "-", Pconst_integer (n, m) -> Some (Pconst_integer (neg_string n, m)) | "-", Pconst_unboxed_integer (n, m) -> @@ -152,16 +163,22 @@ let mkuminus ~oploc name arg = | _ -> None in match result with - | Some desc -> Pexp_constant desc, arg.pexp_attributes + | Some desc -> Pexp_constant (mkconst ~loc:sloc desc), arg.pexp_attributes | None -> 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 _ | Pconst_unboxed_integer _) - | ("+" | "+."), Pexp_constant (Pconst_float _ | Pconst_unboxed_float _) -> - desc, arg.pexp_attributes + | "+", + Pexp_constant + {pconst_desc = (Pconst_integer _ | Pconst_unboxed_integer _) as desc; + pconst_loc=_} + | ("+" | "+."), + Pexp_constant + {pconst_desc = (Pconst_float _ | Pconst_unboxed_float _) as desc; + pconst_loc=_} -> + Pexp_constant (mkconst ~loc:sloc desc), arg.pexp_attributes | _ -> Pexp_apply (mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]), [] @@ -264,7 +281,9 @@ let rec mktailexp nilloc = let open Location in function | 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 [None, e1; None, ghexp ~loc:el_loc exp_el]) in + let arg = + ghexp ~loc (Pexp_tuple [None, e1; None, ghexp ~loc:el_loc exp_el]) + in ghexp_cons_desc loc arg, loc let rec mktailpat nilloc = let open Location in function @@ -274,7 +293,10 @@ let rec mktailpat nilloc = let open Location in function | 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 ([None, p1; None, ghpat ~loc:el_loc pat_pl], Closed)) in + let arg = + ghpat ~loc + (Ppat_tuple ([None, p1; None, ghpat ~loc:el_loc pat_pl], Closed)) + in ghpat_cons_desc loc arg, loc let mkstrexp e attrs = @@ -381,7 +403,7 @@ let mkexp_type_constraint_with_modes ?(ghost=false) ~loc ~modes e t = | Pcoerce(t1, t2) -> match modes with | [] -> - let mk = if ghost then ghexp else mkexp ?attrs:None in + let mk = if ghost then ghexp ?attrs:None else mkexp ?attrs:None in mk ~loc (Pexp_coerce(e, t1, t2)) | _ :: _ -> not_expecting loc "mode annotations" @@ -444,9 +466,9 @@ type ('dot,'index) array_family = { let bigarray_untuplify exp = match exp.pexp_desc with - | Pexp_tuple explist when - List.for_all (function None, _ -> true | _ -> false) explist -> - List.map (fun (_, e) -> e) explist + | Pexp_tuple explist + when List.for_all (fun (l, _) -> Option.is_none l) explist -> + List.map snd explist | _ -> [exp] (* Immutable array indexing is a regular operator, so it doesn't need a special @@ -465,8 +487,8 @@ let builtin_arraylike_name loc _ ~assign paren_kind n = | Two -> "Array2" | Three -> "Array3" | Many -> "Genarray" in - Ldot(Lident "Bigarray", submodule_name) in - ghloc ~loc (Ldot(prefix,opname)) + Ldot(mknoloc (Lident "Bigarray"), mknoloc submodule_name) in + ghloc ~loc (Ldot(mknoloc prefix, mknoloc opname)) let builtin_arraylike_index loc paren_kind index = match paren_kind with | Paren | Bracket -> One, [Nolabel, index] @@ -496,7 +518,7 @@ let user_indexing_operator_name loc (prefix,ext) ~assign paren_kind n = String.concat "" ["."; ext; left; mid; right; assign] in let lid = match prefix with | None -> Lident name - | Some p -> Ldot(p,name) in + | Some p -> Ldot(mknoloc p,mknoloc name) in ghloc ~loc lid let user_index loc _ index = @@ -525,9 +547,9 @@ 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 = +let lapply ~loc p1 loc_p1 p2 loc_p2 = if !Clflags.applicative_functors - then Lapply(p1, p2) + then Lapply(mkrhs p1 loc_p1, mkrhs p2 loc_p2) else raise (Syntaxerr.Error( Syntaxerr.Applicative_path (make_loc loc))) @@ -570,33 +592,28 @@ let wrap_type_annotation ~loc ?(typloc=loc) ~modes newtypes core_type body = let inner_type = Typ.varify_constructors (List.map fst newtypes) core_type in (exp, ghtyp ~loc:typloc (Ptyp_poly (newtypes, inner_type))) -let wrap_exp_attrs ~loc body (ext, attrs) = - let ghexp = ghexp ~loc in +let pexp_extension ~id e = Pexp_extension (id, PStr [mkstrexp e []]) + +let mkexp_attrs ~loc desc (ext, attrs) = (* 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 ext_attrs = - wrap_exp_attrs ~loc (mkexp ~loc d) ext_attrs + | None -> mkexp ~loc ~attrs desc + | Some id -> + mkexp ~loc (pexp_extension ~id (ghexp ~loc ~attrs desc)) -let wrap_typ_attrs ~loc typ (ext, attrs) = +let mktyp_attrs ~loc desc (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)) + | None -> mktyp ~loc ~attrs desc + | Some id -> + mktyp ~loc (Ptyp_extension (id, PTyp (ghtyp ~loc ~attrs desc))) -let wrap_pat_attrs ~loc pat (ext, attrs) = +let mkpat_attrs ~loc desc (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 + | None -> mkpat ~loc ~attrs desc + | Some id -> + mkpat ~loc (Ppat_extension (id, PPat (ghpat ~loc ~attrs desc, None))) let wrap_class_attrs ~loc:_ body attrs = {body with pcl_attributes = attrs @ body.pcl_attributes} @@ -605,27 +622,24 @@ let wrap_mod_attrs ~loc:_ attrs body = 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 {psg_items=[body]; - psg_modalities=[]; psg_loc=make_loc loc}), [])) + | None -> mkstr ~loc item + | Some id -> mkstr ~loc (Pstr_extension ((id, PStr [ghstr ~loc item]), [])) let wrap_mksig_ext ~loc (item, ext) = - wrap_sig_ext ~loc (mksig ~loc item) ext + match ext with + | None -> mksig ~loc item + | Some id -> + let psig = + {psg_items=[ghsig ~loc item]; psg_modalities=[]; psg_loc=make_loc loc} + in + mksig ~loc (Psig_extension ((id, PSig psig), [])) 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) @@ -772,9 +786,9 @@ let all_params_as_newtypes = | Pparam_newtype _ -> true | Pparam_val _ -> false in - let as_newtype { pparam_desc; _ } = + let as_newtype { pparam_desc; pparam_loc } = match pparam_desc with - | Pparam_newtype (x, jkind) -> Some (x, jkind) + | Pparam_newtype (x, jkind) -> Some (x, jkind, pparam_loc) | Pparam_val _ -> None in fun params -> @@ -789,7 +803,7 @@ let empty_body_constraint = [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 ~loc = +let mkghost_newtype_function_body newtypes body_constraint body = let wrapped_body = let { ret_type_constraint; mode_annotations; ret_mode_annotations } = body_constraint @@ -799,24 +813,30 @@ let mkghost_newtype_function_body newtypes body_constraint body ~loc = let loc = loc_start, loc_end in mkexp_opt_type_constraint_with_modes ~ghost:true ~loc ~modes body ret_type_constraint in - mk_newtypes ~loc newtypes wrapped_body + let expr = + List.fold_right + (fun (newtype, jkind, 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, jkind, e)) ~loc) + newtypes + wrapped_body + in + expr.pexp_desc -let mkfunction ~loc ~attrs params body_constraint body = +let mkfunction params body_constraint body = match body with - | Pfunction_cases _ -> - mkexp_attrs (Pexp_function (params, body_constraint, body)) attrs ~loc + | Pfunction_cases _ -> Pexp_function (params, body_constraint, body) | Pfunction_body body_exp -> begin (* 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 -> - mkexp_attrs (Pexp_function (params, body_constraint, body)) attrs ~loc + | None -> Pexp_function (params, body_constraint, body) | Some newtypes -> - wrap_exp_attrs - ~loc - (mkghost_newtype_function_body newtypes body_constraint body_exp - ~loc) - attrs + mkghost_newtype_function_body newtypes body_constraint body_exp end let mk_functor_typ args mty_mm = @@ -1002,6 +1022,7 @@ let maybe_pmod_constraint mode expr = %token DOTDOT ".." %token DOTHASH ".#" %token DOWNTO "downto" +%token EFFECT "effect" %token ELSE "else" %token END "end" %token EOF "" @@ -1132,6 +1153,11 @@ let maybe_pmod_constraint mode expr = %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 @@ -1195,11 +1221,15 @@ The precedences must be listed from low to high. %nonassoc below_DOT %nonassoc DOT DOTHASH DOTOP /* Finally, the first tokens of simple_expr are above everything else. */ -%nonassoc BACKQUOTE BANG BEGIN CHAR HASH_CHAR FALSE FLOAT HASH_FLOAT - INT HASH_INT OBJECT - LBRACE LBRACELESS LBRACKET LBRACKETBAR LBRACKETCOLON LIDENT LPAREN - NEW PREFIXOP STRING TRUE UIDENT LESSLBRACKET DOLLAR - LBRACKETPERCENT QUOTED_STRING_EXPR HASHLBRACE HASHLPAREN UNDERSCORE +%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 + /* OxCaml additions: */ + HASH_CHAR HASH_FLOAT HASH_INT + LBRACKETCOLON LESSLBRACKET DOLLAR + HASHLBRACE HASHLPAREN UNDERSCORE HASHFALSE HASHTRUE /* Entry points */ @@ -1841,13 +1871,12 @@ structure_item: { 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) + { let incl, ext = $1 in + (Pstr_include incl, ext) + } ) { $1 } - | include_statement(module_expr) - { let incl, ext = $1 in - let item = mkstr ~loc:$sloc (Pstr_include incl) in - wrap_str_ext ~loc:$sloc item ext - } ; (* A single module binding. *) @@ -2138,13 +2167,12 @@ signature_item: { let (ext, l) = $1 in (Psig_class l, ext) } | class_type_declarations { let (ext, l) = $1 in (Psig_class_type l, ext) } + | include_statement(module_type) modalities = optional_atat_modalities_expr + { let incl, ext = $1 in + Psig_include (incl, modalities), ext + } ) { $1 } - | include_statement(module_type) modalities = optional_atat_modalities_expr - { let incl, ext = $1 in - let item = mksig ~loc:$sloc (Psig_include (incl, modalities)) in - wrap_sig_ext ~loc:$sloc item ext - } (* A module declaration. *) %inline module_declaration: @@ -2521,8 +2549,8 @@ class_signature: class_self_type: LPAREN core_type RPAREN { $2 } - | mktyp((* empty *) { Ptyp_any None }) - { $1 } + | (* empty *) + { ghtyp ~loc:$sloc (Ptyp_any None) } ; %inline class_sig_fields: flatten(text_csig(class_sig_field)*) @@ -2664,8 +2692,10 @@ class_type_declarations: typechecking. For standalone function cases, we want the compiler to respect, e.g., [@inline] attributes. *) - mkfunction [] empty_body_constraint (Pfunction_cases (cases, loc, [])) ~attrs:$2 - ~loc:$sloc + let desc = + mkfunction [] empty_body_constraint (Pfunction_cases (cases, loc, [])) + in + mkexp_attrs ~loc:$sloc desc $2 } ) { $1 } @@ -2686,9 +2716,7 @@ fun_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)) } + { mkexp_attrs ~loc:$sloc (Pexp_sequence ($1, $5)) (Some $4, []) } ; seq_expr: | or_function(fun_seq_expr) { $1 } @@ -2829,7 +2857,7 @@ fun_: | maybe_stack ( FUN ext_attributes fun_params body_constraint = optional_atomic_constraint_ MINUSGREATER fun_body - { mkfunction $3 body_constraint $6 ~loc:$sloc ~attrs:$2 } + { mkexp_attrs ~loc:$sloc (mkfunction $3 body_constraint $6) $2 } ) { $1 } fun_expr: @@ -2852,7 +2880,7 @@ fun_expr: mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) } | fun_expr COLONCOLON expr { mkexp_cons ~loc:$sloc $loc($2) - (ghexp ~loc:$sloc (Pexp_tuple[None, $1;None, $3])) } + (ghexp ~loc:$sloc (Pexp_tuple[None,$1;None,$3])) } | mkrhs(label) LESSMINUS expr { mkexp ~loc:$sloc (Pexp_setvar($1, $3)) } | simple_expr DOT mkrhs(label_longident) LESSMINUS expr @@ -2905,10 +2933,10 @@ fun_expr: | LAZY ext_attributes simple_expr %prec below_HASH { Pexp_lazy $3, $2 } | subtractive expr %prec prec_unary_minus - { let desc, attrs = mkuminus ~oploc:$loc($1) $1 $2 in + { let desc, attrs = mkuminus ~sloc:$sloc ~oploc:$loc($1) $1 $2 in desc, (None, attrs) } | additive expr %prec prec_unary_plus - { let desc, attrs = mkuplus ~oploc:$loc($1) $1 $2 in + { let desc, attrs = mkuplus ~sloc:$sloc ~oploc:$loc($1) $1 $2 in desc, (None, attrs) } ; %inline do_done_expr: @@ -2974,6 +3002,7 @@ simple_expr: { 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 } @@ -3002,9 +3031,9 @@ simple_expr: | 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), Some $6, []), $3 } + { Pexp_pack ($4, None), $3 } + | LPAREN MODULE ext_attributes module_expr COLON package_type_ RPAREN + { Pexp_pack ($4, Some $6), $3 } | LPAREN MODULE ext_attributes module_expr COLON error { unclosed "(" $loc($1) ")" $loc($6) } | OBJECT ext_attributes class_structure END @@ -3106,6 +3135,21 @@ block_access: } | DOT ident _p=LPAREN seq_expr _e=error { indexop_unclosed_error $loc(_p) Paren $loc(_e) } + +(* 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 + { mkexp ~loc:$sloc (pexp_extension ~id:(mknoloc "metaocaml.escape") e) } + | METAOCAML_BRACKET_OPEN e = seq_expr METAOCAML_BRACKET_CLOSE + { mkexp ~loc:$sloc (pexp_extension ~id:(mknoloc "metaocaml.bracket") e) } ; %inline simple_expr_: @@ -3192,10 +3236,10 @@ block_access: 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 + ptyp = package_type_ RPAREN { let modexp = mkexp_attrs ~loc:($startpos($3), $endpos) - (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), Some $8, [])) $5 in + (Pexp_pack ($6, Some ptyp)) $5 in Pexp_open(od, modexp) } | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON error @@ -3390,9 +3434,7 @@ strict_binding_modes: in {mode_annotations; ret_type_constraint ; ret_mode_annotations } in - let exp = mkfunction $1 constraint_ $4 ~loc:$sloc ~attrs:(None, []) in - { exp with pexp_loc = { exp.pexp_loc with loc_ghost = true } } - + ghexp ~loc:$sloc (mkfunction $1 constraint_ $4) } ; %inline strict_binding: @@ -3406,9 +3448,9 @@ fun_body: | 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 - let function_ = mkfunction [] empty_body_constraint cases ~loc:$sloc ~attrs:$2 in - Pfunction_body function_ + let cases = Pfunction_cases ($3, make_loc $sloc, []) in + let function_ = mkfunction [] empty_body_constraint cases in + Pfunction_body (mkexp_attrs ~loc:$sloc function_ $2) } | fun_seq_expr { Pfunction_body $1 } @@ -3460,7 +3502,7 @@ fun_params: | nonempty_concat(fun_param_as_list) { $1 } ; -(* Parsing labeled tuple expressions +(* Parsing labeled tuple expressions: The grammar we want to parse is something like: @@ -3502,8 +3544,8 @@ fun_params: Some label, mkexpvar ~loc label } | TILDE LPAREN label = LIDENT c = type_constraint RPAREN %prec below_HASH { Some label, - mkexp_type_constraint_with_modes - ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(label) label) c } + mkexp_type_constraint_with_modes ~loc:($startpos($2), $endpos) + ~modes:[] (mkexpvar ~loc:$loc(label) label) c } ; reversed_labeled_tuple_body: (* > 2 elements *) @@ -3529,8 +3571,8 @@ reversed_labeled_tuple_body: COMMA x2 = labeled_tuple_element { let x1 = - mkexp_type_constraint_with_modes - ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(l1) l1) c + mkexp_type_constraint_with_modes ~loc:($startpos($2), $endpos) + ~modes:[] (mkexpvar ~loc:$loc(l1) l1) c in [ x2; Some l1, x1] } ; @@ -3653,6 +3695,8 @@ 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: @@ -3663,8 +3707,7 @@ pattern_no_exn: %inline pattern_(self): | self COLONCOLON pattern { mkpat_cons ~loc:$sloc $loc($2) - (ghpat ~loc:$sloc (Ppat_tuple ([None, $1;None, $3], Closed))) - } + (ghpat ~loc:$sloc (Ppat_tuple ([None, $1; None, $3], Closed))) } | self attribute { Pat.attr $1 $2 } | pattern_gen @@ -3674,6 +3717,8 @@ pattern_no_exn: { Ppat_alias($1, $3) } | self AS error { expecting $loc($3) "identifier" } + | labeled_tuple_pattern(self) + { $1 } | self COLONCOLON error { expecting $loc($3) "pattern" } | self BAR pattern @@ -3681,69 +3726,8 @@ pattern_no_exn: | self BAR error { expecting $loc($3) "pattern" } ) { $1 } - | reversed_labeled_tuple_pattern(self) - { let closed, pats = $1 in - mkpat ~loc:$sloc (Ppat_tuple (List.rev pats, closed)) - } ; -(* Parsing labeled tuple patterns - - Here we play essentially the same game we did for expressions - see the - comment beginning "Parsing labeled tuple expressions". - - One difference is that we would need to manually inline the definition of - individual elements in two places: Once in the base case for lists 2 or more - elements, and once in the special case for open patterns with just one - element (e.g., [~x, ..]). Rather than manually inlining - [labeled_tuple_pat_element] twice, we simply define it twice: once with the - [%prec] annotations needed for its occurrences in tail position, and once - without them suitable for use in other locations. -*) -%inline labeled_tuple_pat_element(self): - | self { None, $1 } - | LABEL simple_pattern %prec COMMA - { Some $1, $2 } - | TILDE label = LIDENT - { let loc = $loc(label) in - Some label, mkpatvar ~loc label } - | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN %prec COMMA - { let lbl_loc = $loc(label) in - let pat_loc = $startpos($2), $endpos in - let pat = mkpatvar ~loc:lbl_loc label in - Some label, mkpat_with_modes ~loc:pat_loc ~modes:[] ~pat ~cty:(Some cty) } - -(* If changing this, don't forget to change its copy just above. *) -%inline labeled_tuple_pat_element_noprec(self): - | self { None, $1 } - | LABEL simple_pattern - { Some $1, $2 } - | TILDE label = LIDENT - { let loc = $loc(label) in - Some label, mkpatvar ~loc label } - | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN - { let lbl_loc = $loc(label) in - let pat_loc = $startpos($2), $endpos in - let pat = mkpatvar ~loc:lbl_loc label in - Some label, mkpat_with_modes ~loc:pat_loc ~modes:[] ~pat ~cty:(Some cty) } - -labeled_tuple_pat_element_list(self): - | labeled_tuple_pat_element_list(self) COMMA labeled_tuple_pat_element(self) - { $3 :: $1 } - | labeled_tuple_pat_element_noprec(self) COMMA labeled_tuple_pat_element(self) - { [ $3; $1 ] } - | self COMMA error - { expecting $loc($3) "pattern" } -; - -reversed_labeled_tuple_pattern(self): - | labeled_tuple_pat_element_list(self) %prec below_COMMA - { Closed, $1 } - | labeled_tuple_pat_element_list(self) COMMA DOTDOT - { Open, $1 } - | labeled_tuple_pat_element_noprec(self) COMMA DOTDOT - { Open, [ $1 ] } - pattern_gen: simple_pattern { $1 } @@ -3763,6 +3747,7 @@ pattern_gen: | 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) }) @@ -3862,6 +3847,68 @@ simple_delimited_pattern: Ppat_unboxed_tuple (List.rev fields, closed) } ) { $1 } +(* Parsing labeled tuple patterns: + + Here we play essentially the same game we did for expressions - see the + comment beginning "Parsing labeled tuple expressions". + + One difference is that we would need to manually inline the definition of + individual elements in two places: Once in the base case for lists 2 or more + elements, and once in the special case for open patterns with just one + element (e.g., [~x, ..]). Rather than manually inlining + [labeled_tuple_pat_element] twice, we simply define it twice: once with the + [%prec] annotations needed for its occurrences in tail position, and once + without them suitable for use in other locations. +*) +%inline labeled_tuple_pat_element(self): + | self { None, $1 } + | LABEL simple_pattern %prec COMMA + { Some $1, $2 } + | TILDE label = LIDENT + { let loc = $loc(label) in + Some label, mkpatvar ~loc label } + | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN %prec COMMA + { let lbl_loc = $loc(label) in + let pat_loc = $startpos($2), $endpos in + let pat = mkpatvar ~loc:lbl_loc label in + Some label, + mkpat_with_modes ~loc:pat_loc ~modes:[] ~pat ~cty:(Some cty) } +; +(* If changing this, don't forget to change its copy just above. *) +%inline labeled_tuple_pat_element_noprec(self): + | self { None, $1 } + | LABEL simple_pattern + { Some $1, $2 } + | TILDE label = LIDENT + { let loc = $loc(label) in + Some label, mkpatvar ~loc label } + | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN + { let lbl_loc = $loc(label) in + let pat_loc = $startpos($2), $endpos in + let pat = mkpatvar ~loc:lbl_loc label in + Some label, mkpat_with_modes ~loc:pat_loc ~modes:[] ~pat ~cty:(Some cty) } +; +labeled_tuple_pat_element_list(self): + | labeled_tuple_pat_element_list(self) COMMA labeled_tuple_pat_element(self) + { $3 :: $1 } + | labeled_tuple_pat_element_noprec(self) COMMA labeled_tuple_pat_element(self) + { [ $3; $1 ] } + | self COMMA error + { expecting $loc($3) "pattern" } +; +reversed_labeled_tuple_pattern(self): + | labeled_tuple_pat_element_list(self) %prec below_COMMA + { Closed, $1 } + | labeled_tuple_pat_element_list(self) COMMA DOTDOT + { Open, $1 } + | labeled_tuple_pat_element_noprec(self) COMMA DOTDOT + { Open, [ $1 ] } +; +labeled_tuple_pattern(self): + | reversed_labeled_tuple_pattern(self) + { let closed, pat = $1 in + Ppat_tuple(List.rev pat, closed) } +; %inline pattern_semi_list: ps = separated_or_terminated_nonempty_list(SEMI, pattern) { ps } @@ -4199,10 +4246,16 @@ type_variance: | INFIXOP2 { if $1 = "+!" then Covariant, Injective else if $1 = "-!" then Contravariant, Injective else + if $1 = "+-" then Bivariant, NoInjectivity else + if $1 = "-+" then Bivariant, NoInjectivity else + if $1 = "+-!" then Bivariant, Injective else + if $1 = "-+!" then Bivariant, Injective else expecting $loc($1) "type_variance" } | PREFIXOP { if $1 = "!+" then Covariant, Injective else if $1 = "!-" then Contravariant, Injective else + if $1 = "!+-" then Bivariant, Injective else + if $1 = "!-+" then Bivariant, Injective else expecting $loc($1) "type_variance" } ; @@ -4354,7 +4407,8 @@ label_declaration_semi: attrs2 = post_item_attributes { let docs = symbol_docs $sloc in let attrs = attrs1 @ attrs2 in - Te.mk tid cs ~params ~priv ~attrs ~docs, + let loc = make_loc $sloc in + Te.mk tid cs ~params ~priv ~attrs ~docs ~loc, ext } ; %inline extension_constructor(opening): @@ -4612,18 +4666,16 @@ strict_function_or_labeled_tuple_type: maybe_curry_typ codomain codomain_loc, arg_modes, ret_modes) } ) { $1 } - (* These next three cases are for labled tuples - see comment on [tuple_type] + (* The next three cases are for labled tuples - see comment on [tuple_type] below. - The first two cases are present just to resolve a shift reduce conflict - in a module type [S with t := x:t1 * t2 -> ...] which might be the - beginning of + The first two cases are present just to resolve a shift/reduce conflict in a + module type [S with t := x:t1 * t2 -> ...] which might be the beginning of [S with t := x:t1 * t2 -> S'] or [S with t := x:t1 * t2 -> t3] - They are the same as the previous two cases, but with [arg_label] replaced - with the more specific [LIDENT COLON] and [param_type] replaced with the - more specific [proper_tuple_type]. Apparently, this is sufficient for - menhir to be able to delay a decision about which of the above module type - cases we are in. *) + They are the same as the previous two cases, but with [arg_label] specialized + to [LIDENT COLON] and the domain type specialized to [proper_tuple_type]. + Apparently, this is sufficient for menhir to be able to delay a decision + about which of the above module type cases we are in. *) | mktyp( label = LIDENT COLON tuple_with_modes = with_optional_mode_expr(proper_tuple_type) @@ -4778,9 +4830,9 @@ optional_atat_modalities_expr: However, the special case of labeled tuples where the first element has a label is not parsed as a proper_tuple_type, but rather as a case of - strict_function_or_labled_tuple_type above. This helps in dealing with - ambiguities around [x:t1 * t2 -> t3] which must continue to parse as a - function with one labeled argument even in the presense of labled tuples. + strict_function_or_labeled_tuple_type above. This resolves ambiguities + around [x:t1 * t2 -> t3] which must continue to parse as a function with one + labeled argument even in the presence of labled tuples. *) tuple_type: | ty = atomic_type @@ -4788,16 +4840,14 @@ tuple_type: { ty } | proper_tuple_type %prec below_FUNCTOR { let ty, ltys = $1 in - mktyp ~loc:$sloc (Ptyp_tuple ((None, ty) :: ltys)) - } + mktyp ~loc:$sloc (Ptyp_tuple ((None, ty) :: ltys)) } ; - %inline proper_tuple_type: | ty = atomic_type STAR ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element) { ty, ltys } - +; (* In the case of an unboxed tuple, we don't need the nonsense above because the [#( ... )] disambiguates. However, we still must write out the first element explicitly because [labeled_tuple_typ_element] is @@ -4813,13 +4863,13 @@ tuple_type: STAR ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element) { (Some label, ty1) :: ltys } - +; %inline labeled_tuple_typ_element : | atomic_type %prec STAR { None, $1 } | label = LIDENT COLON ty = atomic_type %prec STAR { Some label, ty } - +; (* Atomic types are the most basic level in the syntax of types. Atomic types include: - types between parentheses: (int -> int) @@ -4855,8 +4905,8 @@ tuple_type: 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 } + | LPAREN MODULE ext_attrs = ext_attributes package_type = package_type_ RPAREN + { mktyp_attrs ~loc:$sloc (Ptyp_package package_type) ext_attrs } | mktyp( LBRACKET field = tag_field RBRACKET { Ptyp_variant([ field ], Closed, None) } @@ -4985,10 +5035,12 @@ atomic_type: | UNDERSCORE COLON jkind=jkind_annotation { mktyp ~loc:$sloc (Ptyp_any (Some jkind)) } -%inline package_type: module_type +%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 } + Typ.package_type ~loc:(make_loc $sloc) ~attrs lid cstrs } + +%inline package_type: package_type_ + { mktyp ~loc:$sloc (Ptyp_package $1) } ; %inline row_field_list: separated_nonempty_llist(BAR, row_field) @@ -5066,16 +5118,19 @@ meth_list: /* Constants */ value_constant: - | INT { let (n, m) = $1 in Pconst_integer (n, m) } - | CHAR { Pconst_char $1 } + | 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 - Pconst_string (s, strloc, d) } - | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } + mkconst ~loc:$sloc (Pconst_string (s, strloc, d)) } + | FLOAT { let (f, m) = $1 in + mkconst ~loc:$sloc (Pconst_float (f, m)) } ; unboxed_constant: - | HASH_INT { unboxed_int $sloc $sloc Positive $1 } - | HASH_FLOAT { unboxed_float Positive $1 } - | HASH_CHAR { Pconst_untagged_char $1 } + | HASH_INT { mkconst ~loc:$sloc + (unboxed_int $sloc $sloc Positive $1) } + | HASH_FLOAT { mkconst ~loc:$sloc (unboxed_float Positive $1) } + | HASH_CHAR { mkconst ~loc:$sloc (Pconst_untagged_char $1) } ; constant: value_constant { $1 } @@ -5083,18 +5138,24 @@ constant: ; signed_value_constant: value_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)) } ; signed_constant: signed_value_constant { $1 } | unboxed_constant { $1 } - | MINUS HASH_INT { unboxed_int $sloc $loc($2) Negative $2 } - | MINUS HASH_FLOAT { unboxed_float Negative $2 } - | PLUS HASH_INT { unboxed_int $sloc $loc($2) Positive $2 } - | PLUS HASH_FLOAT { unboxed_float Positive $2 } + | MINUS HASH_INT { mkconst ~loc:$sloc + (unboxed_int $sloc $loc($2) Negative $2) } + | MINUS HASH_FLOAT { mkconst ~loc:$sloc (unboxed_float Negative $2) } + | PLUS HASH_INT { mkconst ~loc:$sloc + (unboxed_int $sloc $loc($2) Positive $2) } + | PLUS HASH_FLOAT { mkconst ~loc:$sloc (unboxed_float Positive $2) } ; /* Identifiers and long identifiers */ @@ -5177,13 +5238,13 @@ constr_ident: ; constr_longident: mod_longident %prec below_DOT { $1 } /* A.B.x vs (A).B.x */ - | mod_longident DOT constr_extra_ident { Ldot($1,$3) } + | mod_longident DOT constr_extra_ident { ldot $1 $loc($1) $3 $loc($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) } + | prefix DOT final { ldot $1 $loc($1) $3 $loc($3) } ; val_longident: mk_longident(mod_longident, val_ident) { $1 } @@ -5210,7 +5271,7 @@ mod_longident: mod_ext_longident: mk_longident(mod_ext_longident, UIDENT) { $1 } | mod_ext_longident LPAREN mod_ext_longident RPAREN - { lapply ~loc:$sloc $1 $3 } + { lapply ~loc:$sloc $1 $loc($1) $3 $loc($3) } | mod_ext_longident LPAREN error { expecting $loc($3) "module path" } ; @@ -5386,6 +5447,7 @@ single_attr_id: | DO { "do" } | DONE { "done" } | DOWNTO { "downto" } + | EFFECT { "effect" } | ELSE { "else" } | END { "end" } | EXCEPTION { "exception" } diff --git a/upstream/ocaml_flambda/parsing/parsetree.mli b/upstream/ocaml_flambda/parsing/parsetree.mli index c15b3dd99..16c0cf397 100644 --- a/upstream/ocaml_flambda/parsing/parsetree.mli +++ b/upstream/ocaml_flambda/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]. @@ -121,9 +126,12 @@ and core_type_desc = *) | Ptyp_tuple of (string option * core_type) list (** [Ptyp_tuple(tl)] represents a product type: - - [T1 * ... * Tn] when [tl] is [(None,T1);...;(None,Tn)] - - [L1:T1 * ... * Ln:Tn] when [tl] is [(Some L1,T1);...;(Some Ln,Tn)] - - A mix, e.g. [L1:T1 * T2] when [tl] is [(Some L1,T1);(None,T2)] + - [T1 * ... * Tn] + when [tl] is [(None, T1); ...; (None, Tn)] + - [L1:T1 * ... * Ln:Tn] + when [tl] is [(Some L1, T1); ...; (Some Ln, Tn)] + - A mix, e.g., [L1:T1 * T2] + when [tl] is [(Some L1, T1); (None, T2)] Invariant: [n >= 2]. *) @@ -223,10 +231,16 @@ and arg_label = Asttypes.arg_label = | Labelled of string | Optional of string -and package_type = Longident.t loc * (Longident.t loc * core_type) list +and package_type = + { + ppt_path: Longident.t loc; + ppt_cstrs: (Longident.t loc * core_type) list; + ppt_loc: Location.t; + ppt_attrs: attributes; + } (** As {!package_type} typed values: - - [(S, [])] represents [(module S)], - - [(S, [(t1, T1) ; ... ; (tn, Tn)])] + - [{ppt_path: S; ppt_cstrs: []}] represents [(module S)], + - [{ppt_path: S; ppt_cstrs: [(t1, T1) ; ... ; (tn, Tn)]}] represents [(module S with type t1 = T1 and ... and tn = Tn)]. *) @@ -285,18 +299,6 @@ and pattern_desc = but rejected by the type-checker. *) | Ppat_unboxed_unit (** [#()] *) | Ppat_unboxed_bool of bool (** [#false] or [#true] *) - | Ppat_tuple of (string option * pattern) list * Asttypes.closed_flag - (** [Ppat_tuple(pl, Closed)] represents - - [(P1, ..., Pn)] when [pl] is [(None, P1);...;(None, Pn)] - - [(~L1:P1, ..., ~Ln:Pn)] when [pl] is - [(Some L1, P1);...;(Some Ln, Pn)] - - A mix, e.g. [(~L1:P1, P2)] when [pl] is [(Some L1, P1);(None, P2)] - - If pattern is open, then it also ends in a [..] - - Invariant: - - If Closed, [n >= 2]. - - If Open, [n >= 1]. - *) | Ppat_unboxed_tuple of (string option * pattern) list * Asttypes.closed_flag (** Unboxed tuple patterns: [#(l1:P1, ..., ln:Pn)] is [([(Some l1,P1);...;(Some l2,Pn)], Closed)], and the labels are optional. An @@ -306,6 +308,22 @@ and pattern_desc = - If Closed, [n >= 2] - If Open, [n >= 1] *) + | Ppat_tuple of (string option * pattern) list * Asttypes.closed_flag + (** [Ppat_tuple(pl, Closed)] represents + - [(P1, ..., Pn)] + when [pl] is [(None, P1); ...; (None, Pn)] + - [(~L1:P1, ..., ~Ln:Pn)] + when [pl] is [(Some L1, P1); ...; (Some Ln, Pn)] + - A mix, e.g. [(~L1:P1, P2)] + when [pl] is [(Some L1, P1); (None, P2)] + + [Ppat_tuple(pl, Open)] is similar, but indicates the pattern + additionally ends in a [..]. + + Invariant: + - If Closed, [n >= 2]. + - If Open, [n >= 1]. + *) | Ppat_construct of Longident.t loc * ((string loc * jkind_annotation option) list * pattern) option @@ -360,6 +378,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)] *) @@ -403,8 +422,9 @@ and expression_desc = [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. + A function must have parameters: in [Pexp_function (params, _, body)], + if [params] does not contain a [Pparam_val _], [body] must be + [Pfunction_cases _]. *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] @@ -426,11 +446,11 @@ and expression_desc = | Pexp_tuple of (string option * expression) list (** [Pexp_tuple(el)] represents - [(E1, ..., En)] - when [el] is [(None, E1);...;(None, En)] + when [el] is [(None, E1); ...; (None, En)] - [(~L1:E1, ..., ~Ln:En)] - when [el] is [(Some L1, E1);...;(Some Ln, En)] - - A mix, e.g.: - [(~L1:E1, E2)] when [el] is [(Some L1, E1); (None, E2)] + when [el] is [(Some L1, E1); ...; (Some Ln, En)] + - A mix, e.g., [(~L1:E1, E2)] + when [el] is [(Some L1, E1); (None, E2)] Invariant: [n >= 2] *) @@ -520,11 +540,8 @@ and expression_desc = | Pexp_object of class_structure (** [object ... end] *) | Pexp_newtype of string loc * jkind_annotation option * expression (** [fun (type t) -> E] or [fun (type t : k) -> E] *) - | Pexp_pack of module_expr - (** [(module ME)]. - - [(module ME : S)] is represented as - [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) + | Pexp_pack of module_expr * package_type option + (** [(module ME)] or [(module ME : S)]. *) | Pexp_open of open_declaration * expression (** - [M.(E)] - [let open M in E] diff --git a/upstream/ocaml_flambda/parsing/pprintast.ml b/upstream/ocaml_flambda/parsing/pprintast.ml index 601923f38..389e7e4c6 100644 --- a/upstream/ocaml_flambda/parsing/pprintast.ml +++ b/upstream/ocaml_flambda/parsing/pprintast.ml @@ -81,13 +81,46 @@ let last_is c str = let first_is_in cs str = str <> "" && List.mem str.[0] cs +(** The OCaml grammar generates [longident]s from five different rules: + - module longident (a sequence of uppercase identifiers [A.B.C]) + - constructor longident, either + - a module [longident] + - [[]], [()], [true], [false] + - an optional module [longident] followed by [(::)] ([A.B.(::)]) + - class longident, an optional module [longident] followed by a lowercase + identifier. + - value longident, an optional module [longident] followed by either: + - a lowercase identifier ([A.x]) + - an operator (and in particular the [mod] keyword), ([A.(+), B.(mod)]) + - type [longident]: a tree of applications and projections of + uppercase identifiers followed by a projection ending with + a lowercase identifier (for ordinary types), or any identifier + (for module types) (e.g [A.B(C.D(E.F).K)(G).X.Y.t]) +All these [longident]s share a common core and optionally add some extensions. +Unfortunately, these extensions intersect while having different escaping +and parentheses rules depending on the kind of [longident]: + - [true] or [false] can be either constructor [longident]s, + or value, type or class [longident]s using the raw identifier syntax. + - [mod] can be either an operator value [longident], or a class or type + [longident] using the raw identifier syntax. +Thus in order to print correctly [longident]s, we need to keep track of their +kind using the context in which they appear. +*) +type longindent_kind = + | Constr (** variant constructors *) + | Type (** core types, module types, class types, and classes *) + | Other (** values and modules *) + (* 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 +let needs_parens ~kind txt = + match kind with + | Type -> false + | Constr | Other -> + 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 *) @@ -110,38 +143,99 @@ let tyvar_of_name s = end of the file to include [jkind_annotation]. *) module Doc_internal = 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 = + in case it is a keyword, or parenthesis when it is an infix or prefix + operator. *) + let ident_of_name ~kind ppf txt = let format : (_, _, _) format = - if Lexer.is_keyword txt then "\\#%s" - else if not (needs_parens txt) then "%s" + if Lexer.is_keyword txt then begin + match kind, txt with + | Constr, ("true"|"false") -> "%s" + | _ -> "\\#%s" + end + else if not (needs_parens ~kind 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 + let protect_longident ~kind ppf print_longident longprefix txt = + if not (needs_parens ~kind txt) then Format_doc.fprintf ppf "%a.%a" print_longident longprefix - ident_of_name txt + (ident_of_name ~kind) 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 + let rec any_longident ~kind f = function + | Lident s -> ident_of_name ~kind f s + | Ldot(y,s) -> + protect_longident ~kind f (any_longident ~kind:Other) y.txt s.txt | Lapply (y,s) -> - Format_doc.fprintf f "%a(%a)" longident y longident s + Format_doc.fprintf f "%a(%a)" + (any_longident ~kind:Other) y.txt + (any_longident ~kind:Other) s.txt + + let value_longident ppf l = any_longident ~kind:Other ppf l + let longident = value_longident + let constr ppf l = any_longident ~kind:Constr ppf l + let type_longident ppf l = any_longident ~kind:Type ppf l 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 ?(is_constr=false) l = + let kind= if is_constr then Constr else Other in + Format_doc.doc_printer (any_longident ~kind) 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 ~is_constr:true 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_internal.longident ppf l -let ident_of_name ppf i = Format_doc.compat Doc_internal.ident_of_name ppf i +let value_longident ppf l = Format_doc.compat Doc_internal.value_longident ppf l +let type_longident ppf l = Format_doc.compat Doc_internal.type_longident ppf l + +let ident_of_name ppf i = + Format_doc.compat (Doc_internal.ident_of_name ~kind:Other) ppf i + +let constr ppf l = Format_doc.compat Doc_internal.constr ppf l let is_curry_attr attr = attr.attr_name.txt = Builtin_attributes.curry_attr_name @@ -166,6 +260,7 @@ let type_variance = function | NoVariance -> "" | Covariant -> "+" | Contravariant -> "-" + | Bivariant -> "+-" let type_injectivity = function | NoInjectivity -> "" @@ -183,10 +278,10 @@ type construct = 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 "()"; _},None) -> `tuple + | Pexp_construct ( {txt= Lident "true"; _},None) -> `btrue + | Pexp_construct ( {txt= Lident "false"; _},None) -> `bfalse + | Pexp_construct ( {txt= Lident "[]";_},None) -> `nil | Pexp_construct ( {txt= Lident"::";_},Some _) -> let rec loop exp acc = match exp with | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); @@ -194,7 +289,7 @@ let view_expr x = (List.rev acc,true) | {pexp_desc= Pexp_construct ({txt=Lident "::";_}, - Some ({pexp_desc= Pexp_tuple([None, e1;None, e2]); + Some ({pexp_desc= Pexp_tuple([None, e1; None, e2]); pexp_attributes = []})); pexp_attributes = []} -> @@ -265,9 +360,10 @@ 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 longident_loc f x = pp f "%a" longident x.txt +let with_loc pr ppf x = pr ppf x.txt +let value_longident_loc = with_loc value_longident -let constant f = function +let constant_desc f = function | Pconst_char i -> pp f "%C" i | Pconst_untagged_char i -> @@ -296,6 +392,8 @@ let bool f = function | false -> pp f "false" | true -> pp f "true" +let constant f const = constant_desc f const.pconst_desc + (* trailing space*) let mutable_flag f = function | Immutable -> () @@ -325,7 +423,6 @@ 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_internal.tyvar ppf v let string_loc ppf x = fprintf ppf "%s" x.txt @@ -405,7 +502,7 @@ and type_with_label ctxt f (label, c, mode) = and jkind_annotation ?(nested = false) ctxt f k = match k.pjka_desc with | Pjk_default -> pp f "_" | Pjk_abbreviation (s, sa) -> - longident_loc f s; + value_longident_loc f s; List.iter (fun a -> pp f " %s" a.Location.txt) sa | Pjk_mod (t, modes) -> begin match modes with @@ -499,6 +596,13 @@ and core_type ctxt f x = pp f "@[(type@ :@ %a)@]" (jkind_annotation reset_ctxt) jkind | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x +and tuple_type_component ctxt f (label, ty) = + begin match label with + | None -> () + | Some s -> pp f "%s:" s + end; + core_type1 ctxt f ty + and core_type1 ctxt f x = if x.ptyp_attributes <> [] then core_type ctxt f x else @@ -506,7 +610,7 @@ and core_type1 ctxt f x = | Ptyp_any jkind -> tyvar_loc_option_jkind f (None, jkind) | Ptyp_var (s, jkind) -> (tyvar_jkind tyvar) f (s, jkind) | Ptyp_tuple tl -> - pp f "(%a)" (list (labeled_core_type1 ctxt) ~sep:"@;*@;") tl + pp f "(%a)" (list (tuple_type_component ctxt) ~sep:"@;*@;") tl | Ptyp_unboxed_tuple l -> core_type1_labeled_tuple ctxt f ~unboxed:true l | Ptyp_constr (li, l) -> @@ -515,7 +619,7 @@ and core_type1 ctxt f x = |[] -> () |[x]-> pp f "%a@;" (core_type1 ctxt) x | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) - l longident_loc li + l (with_loc type_longident) li | Ptyp_variant (l, closed, low) -> let first_is_inherit = match l with | {Parsetree.prf_desc = Rinherit _}::_ -> true @@ -569,17 +673,11 @@ and core_type1 ctxt f x = | 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) + (with_loc type_longident) li + | Ptyp_package pck_ty -> + pp f "@[(module@ %a)@]" (package_type ctxt) pck_ty | Ptyp_open(li, ct) -> - pp f "@[%a.(%a)@]" longident_loc li (core_type ctxt) ct + pp f "@[%a.(%a)@]" value_longident_loc li (core_type ctxt) ct | Ptyp_quote t -> pp f "@[<[%a]>@]" (core_type ctxt) t | Ptyp_splice t -> @@ -613,14 +711,7 @@ and tyvar_loc_option f str = tyvar_option f (Option.map Location.get_txt str) and core_type1_labeled_tuple ctxt f ~unboxed tl = pp f "%s(%a)" (if unboxed then "#" else "") - (list (labeled_core_type1 ctxt) ~sep:"@;*@;") tl - -and labeled_core_type1 ctxt f (label, ty) = - begin match label with - | None -> () - | Some s -> pp f "%s:" s - end; - core_type1 ctxt f ty + (list (tuple_type_component ctxt) ~sep:"@;*@;") tl and return_type ctxt f (x, m) = let is_curry, ptyp_attributes = split_out_curry_attr x.ptyp_attributes in @@ -633,6 +724,17 @@ and core_type2_with_optional_modes ctxt f (ty, modes) = | [] -> core_type ctxt f ty | _ :: _ -> pp f "%a%a" (core_type2 ctxt) ty optional_at_modes modes +and package_type ctxt f ptyp = + let aux f (s, ct) = + pp f "type %a@ =@ %a" (with_loc type_longident) s (core_type ctxt) ct + in + match ptyp.ppt_cstrs with + | [] -> with_loc type_longident f ptyp.ppt_path + | _ -> + pp f "%a@ with@ %a" + (with_loc type_longident) ptyp.ppt_path + (list aux ~sep:"@ and@ ") ptyp.ppt_cstrs + (********************pattern********************) (* be cautious when use [pattern], [pattern1] is preferred *) and pattern ctxt f x = @@ -658,53 +760,52 @@ and pattern_or ctxt f x = pp f "@[%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = - let rec pattern_list_helper f p = match p with - | {ppat_desc = - Ppat_construct - ({ txt = Lident("::") ;_}, - Some ([], inner_pat)); - ppat_attributes = []} -> - begin match inner_pat.ppat_desc with - | Ppat_tuple([None, pat1; None, pat2], Closed) -> - pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) - | _ -> pattern1 ctxt f p - end - | _ -> 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) -> + | Ppat_construct ({txt=Lident("::");_}, Some ([], + {ppat_desc = Ppat_tuple([None, pat1; None, pat2], Closed);_})) -> + (* Right associative*) + pp f "%a::%a" (simple_pattern ctxt) pat1 (pattern1 ctxt) pat2 + | Ppat_construct (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:"@ " name_loc_jkind) vl - (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) + (match po with + | Some ([], x) -> + (* [true] and [false] are handled above *) + pp f "%a@;%a" value_longident_loc li (simple_pattern ctxt) x + | Some (vl, x) -> + pp f "%a@ (type %a)@;%a" value_longident_loc li + (list ~sep:"@ " name_loc_jkind) vl + (simple_pattern ctxt) x + | None -> pp f "%a" value_longident_loc li) | _ -> simple_pattern ctxt f x -and labeled_pattern1 ctxt (f:Format.formatter) (label, x) : unit = +and tuple_pattern_component ctxt (f:Format.formatter) (label, x) : unit = let simple_name = match x with | {ppat_desc = Ppat_var { txt=s; _ }; ppat_attributes = []; _} -> Some s | _ -> None in match label, simple_name with - | None, _ -> - pattern1 ctxt f x + (* Labeled component can be represented with pun *) | Some lbl, Some simple_name when String.equal simple_name lbl -> pp f "~%s" lbl - | Some lbl, _ -> - pp f "~%s:" lbl; - pattern1 ctxt f x + (* Labeled component general case *) + | Some lbl, _ -> pp f "~%s:%a" lbl (pattern1 ctxt) x + (* Unlabeled component *) + | None, _ -> pattern1 ctxt f x + +and tuple_pattern ctxt f ~unboxed l closed = + let closed_flag ppf = function + | Closed -> () + | Open -> pp ppf ",@;.." + in + pp f "@[<1>%s(%a%a)@]" + (if unboxed then "#" else "") + (list ~sep:",@;" (tuple_pattern_component ctxt)) l + closed_flag closed and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = if x.ppat_attributes <> [] then pattern ctxt f x @@ -728,17 +829,17 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_unpack { txt = Some s } -> pp f "(module@ %s)@ " s | Ppat_type li -> - pp f "#%a" longident_loc li + pp f "#%a" (with_loc type_longident) li | Ppat_record (l, closed) -> record_pattern ctxt f ~unboxed:false l closed | Ppat_record_unboxed_product (l, closed) -> record_pattern ctxt f ~unboxed:true l closed | Ppat_unboxed_unit -> pp f "#()" | Ppat_unboxed_bool b -> pp f "#%a" bool b - | Ppat_tuple (l, closed) -> - labeled_tuple_pattern ctxt f ~unboxed:false l closed - | Ppat_unboxed_tuple (l, closed) -> - labeled_tuple_pattern ctxt f ~unboxed:true l closed + | Ppat_tuple (l, c) -> + tuple_pattern ctxt f ~unboxed:false l c + | Ppat_unboxed_tuple (l, c) -> + tuple_pattern ctxt f ~unboxed:true l c | 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 @@ -748,6 +849,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 = @@ -756,7 +859,7 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false");_}), None) -> false | _ -> true in - pp f "@[<2>%a.%a @]" longident_loc lid + pp f "@[<2>%a.%a @]" value_longident_loc lid (paren with_paren @@ pattern1 ctxt) p | _ -> paren true (pattern ctxt) f x @@ -767,9 +870,9 @@ and record_pattern ctxt f ~unboxed l closed = {ppat_desc=Ppat_var {txt;_}; ppat_attributes=[]; _}) when s = txt -> - pp f "@[<2>%a@]" longident_loc li + pp f "@[<2>%a@]" value_longident_loc li | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + pp f "@[<2>%a@;=@;%a@]" value_longident_loc li (pattern1 ctxt) p in let hash = if unboxed then "#" else "" in match closed with @@ -778,16 +881,6 @@ and record_pattern ctxt f ~unboxed l closed = | Open -> pp f "@[<2>%s{@;%a;_}@]" hash (list longident_x_pattern ~sep:";@;") l -and labeled_tuple_pattern ctxt f ~unboxed l closed = - let closed_flag ppf = function - | Closed -> () - | Open -> pp ppf ",@;.." - in - pp f "@[<1>%s(%a%a)@]" - (if unboxed then "#" else "") - (list ~sep:",@;" (labeled_pattern1 ctxt)) l - closed_flag closed - (** for special treatment of modes in labeled expressions *) and pattern2 ctxt f p = match p.ppat_desc with @@ -847,7 +940,7 @@ and sugar_expr ctxt f e = rem_args = let print_path ppf = function | None -> () - | Some m -> pp ppf ".%a" longident m in + | Some m -> pp ppf ".%a" value_longident m in match assign, rem_args with | false, [] -> pp f "@[%a%a%s%a%s@]" @@ -862,7 +955,8 @@ and sugar_expr ctxt f e = 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 + | Ldot ({txt=path;_}, {txt=("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 @@ -870,18 +964,20 @@ and sugar_expr ctxt f e = print ".(" "" ")" (expression ctxt) [i] rest | Lident "String", i :: rest -> print ".[" "" "]" (expression ctxt) [i] rest - | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + | Ldot ({txt=Lident "Bigarray";_}, {txt="Array1";_}), i1 :: rest -> print ".{" "," "}" (simple_expr ctxt) [i1] rest - | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + | Ldot ({txt=Lident "Bigarray";_}, {txt="Array2";_}), + i1 :: i2 :: rest -> print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest - | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + | Ldot ({txt=Lident "Bigarray";_}, {txt="Array3";_}), + i1 :: i2 :: i3 :: rest -> print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest - | Ldot (Lident "Bigarray", "Genarray"), + | Ldot ({txt=Lident "Bigarray";_}, {txt="Genarray";_}), {pexp_desc = Pexp_array (_, indexes); pexp_attributes = []} :: rest -> print ".{" "," "}" (simple_expr ctxt) indexes rest | _ -> false end - | (Lident s | Ldot(_,s)) , a :: i :: rest + | (Lident s | Ldot(_,{txt=s;_})) , a :: i :: rest when first_is '.' s -> (* extract operator: assignment operators end with [right_bracket ^ "<-"], @@ -903,7 +999,7 @@ and sugar_expr ctxt f e = | '}' -> '{', "}" | _ -> assert false in let path_prefix = match id with - | Ldot(m,_) -> Some m + | Ldot(m,_) -> Some m.txt | _ -> None in let left = String.sub s 0 (1+String.index s left) in print_indexop a path_prefix assign left ";" right @@ -1025,12 +1121,12 @@ and expression ctxt f x = (match view_expr x with | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" | `normal -> - pp f "@[<2>%a@;%a@]" longident_loc li + pp f "@[<2>%a@;%a@]" (with_loc constr) 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 + (simple_expr ctxt) e1 value_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 @@ -1049,7 +1145,7 @@ and expression ctxt f x = pp f "@[%a@]" (list (expression (under_semi ctxt)) ~sep:";@;") lst | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; + pp f "@[new@ %a@]" (with_loc type_longident) li; | Pexp_setvar (s, e) -> pp f "@[%a@ <-@ %a@]" ident_of_name s.txt (expression ctxt) e | Pexp_override l -> (* FIXME *) @@ -1114,9 +1210,9 @@ 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 + pp f "@[%a.%a@]" (simple_expr ctxt) e value_longident_loc li | Pexp_unboxed_field (e, li) -> - pp f "@[%a.#%a@]" (simple_expr ctxt) e longident_loc li + pp f "@[%a.#%a@]" (simple_expr ctxt) e value_longident_loc li | Pexp_send (e, s) -> pp f "@[%a#%a@]" (simple_expr ctxt) e ident_of_name s.txt @@ -1134,16 +1230,18 @@ and simple_expr ctxt f x = | `list xs -> pp f "@[[%a]@]" (list (expression (under_semi ctxt)) ~sep:";@;") xs - | `simple x -> longident f x + | `simple x -> constr f x | _ -> assert false) | Pexp_ident li -> - longident_loc f li + value_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_pack (me, opty) -> + pp f "(module@;%a" (module_expr ctxt) me; + Option.iter (pp f " :@ %a" (package_type ctxt)) opty; + pp f ")" | Pexp_unboxed_unit -> pp f "#()" | Pexp_unboxed_bool b -> pp f "#%a" bool b | Pexp_tuple l -> @@ -1269,7 +1367,7 @@ and class_type ctxt f x = (fun f l -> match l with | [] -> () | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l - longident_loc li + (with_loc type_longident) li (attributes ctxt) x.pcty_attributes | Pcty_arrow (l, co, cl) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) @@ -1280,7 +1378,7 @@ and class_type ctxt f x = 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 + (override o.popen_override) value_longident_loc o.popen_expr (class_type ctxt) e (* [class type a = object end] *) @@ -1402,7 +1500,7 @@ and class_expr ctxt f x = (fun f l-> if l <>[] then pp f "[%a]@ " (list (core_type ctxt) ~sep:",") l) l - longident_loc li + (with_loc type_longident) li | Pcl_constraint (ce, ct) -> pp f "(%a@ :@ %a)" (class_expr ctxt) ce @@ -1410,7 +1508,7 @@ and class_expr ctxt f x = | 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 + (override o.popen_override) value_longident_loc o.popen_expr (class_expr ctxt) e and include_ : 'a. ctxt -> formatter -> @@ -1466,7 +1564,7 @@ and module_type ctxt f x = (module_type1_with_optional_modes ctxt) (mt1, mm1) (module_type_with_optional_modes ctxt) (mt2, mm2) | Some name -> - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name + pp f "@[(%s@ :@ %a)@ ->@ %a@]" name (module_type_with_optional_modes ctxt) (mt1, mm1) (module_type_with_optional_modes ctxt) (mt2, mm2) end @@ -1478,40 +1576,44 @@ and module_type ctxt f x = | Pmty_strengthen (mty, mod_id) -> pp f "@[%a@ with@ %a@]" (module_type1 ctxt) mty - longident_loc mod_id + (with_loc type_longident) mod_id | _ -> 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 ls - longident_loc li (type_declaration ctxt) td + (with_loc type_longident) li (type_declaration ctxt) td | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; + pp f "module %a =@ %a" value_longident_loc li value_longident_loc li2; | Pwith_modtype (li, mty) -> - pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty; + pp f "module type %a =@ %a" + (with_loc type_longident) li + (module_type ctxt) mty; | Pwith_jkind (li, jd) -> - pp f "kind_ %a =@ %a" longident_loc li (jkind_declaration ctxt) jd; + pp f "kind_ %a =@ %a" value_longident_loc li (jkind_declaration ctxt) jd; | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> pp f "type@ %a %a :=@ %a" type_params ls - longident_loc li + (with_loc type_longident) li (type_declaration ctxt) td | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 + pp f "module %a :=@ %a" value_longident_loc li value_longident_loc li2 | Pwith_modtypesubst (li, mty) -> - pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty; + pp f "module type %a :=@ %a" + (with_loc type_longident) li + (module_type ctxt) mty; | Pwith_jkindsubst (li, jd) -> - pp f "kind_ %a :=@ %a" longident_loc li (jkind_declaration ctxt) jd; + pp f "kind_ %a :=@ %a" value_longident_loc li (jkind_declaration ctxt) jd; 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; + pp f "%a" (with_loc type_longident) li; | Pmty_alias li -> - pp f "(module %a)" longident_loc li; + pp f "(module %a)" (with_loc type_longident) li; | Pmty_signature {psg_items; psg_modalities} -> pp f "@[@[sig%a@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) optional_space_atat_modalities psg_modalities @@ -1570,7 +1672,7 @@ and signature_item ctxt f x : unit = pmty_attributes=[]; _}; _} as pmd) -> pp f "@[module@ %s@ =@ %a%a@]%a" (Option.value pmd.pmd_name.txt ~default:"_") - longident_loc alias + value_longident_loc alias optional_space_atat_modalities pmd.pmd_modalities (item_attributes ctxt) pmd.pmd_attributes | Psig_module pmd -> @@ -1581,18 +1683,18 @@ and signature_item ctxt f x : unit = (item_attributes ctxt) pmd.pmd_attributes | Psig_modsubst pms -> pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt - longident_loc pms.pms_manifest + value_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 + value_longident_loc od.popen_expr (item_attributes ctxt) od.popen_attributes | Psig_include (incl, modalities) -> sig_include ctxt f incl modalities | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt + pp f "@[module@ type@ %a%a@]%a" + ident_of_name s.txt (fun f md -> match md with | None -> () | Some mt -> @@ -1655,7 +1757,7 @@ and module_expr ctxt f x = (module_type_with_optional_modes ctxt) (mt, mm) end | Pmod_ident (li) -> - pp f "%a" longident_loc li; + pp f "%a" value_longident_loc li; | Pmod_functor (Unit, me) -> pp f "functor ()@;->@;%a" (module_expr ctxt) me | Pmod_functor (Named (s, mt, mm), me) -> @@ -1713,7 +1815,7 @@ and pp_print_params_then_equals ctxt f x = and poly_type ctxt core_type f (vars, typ) = pp f "type@;%a.@;%a" - (list ~sep:"@;" (tyvar_loc_jkind pp_print_string)) vars + (list ~sep:"@;" (tyvar_loc_jkind ident_of_name)) vars (core_type ctxt) typ and poly_type_with_optional_modes ctxt f (vars, typ, modes) = @@ -1885,8 +1987,8 @@ and structure_item ctxt f x = (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 + pp f "@[module@ type@ %a%a@]%a" + ident_of_name s.txt (fun f md -> match md with | None -> () | Some mt -> @@ -2114,7 +2216,7 @@ and type_extension ctxt f x = in pp f "@[<2>type %a%a += %a@ %a@]%a" type_params x.ptyext_params - longident_loc x.ptyext_path + (with_loc type_longident) x.ptyext_path private_flag x.ptyext_private (* Cf: #7200 *) (list ~sep:"" extension_constructor) x.ptyext_constructors @@ -2165,7 +2267,7 @@ and extension_constructor ctxt f x = (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 + (with_loc constr) li (attributes ctxt) x.pext_attributes and case_list ctxt f l : unit = @@ -2194,30 +2296,30 @@ and label_x_expression_param ctxt f (l,e) = else pp f "~%a:%a" ident_of_name lbl (simple_expr ctxt) e -and tuple_component ctxt f (l,e) = +and tuple_expr_component ctxt f (l,e) = let simple_name = match e with - | {pexp_desc=Pexp_ident {txt=Lident l;_}; - pexp_attributes=[]} -> Some l + | {pexp_desc=Pexp_ident {txt=Lident l;_}; pexp_attributes=[]} -> Some l | _ -> None in match (simple_name, l) with (* Labeled component can be represented with pun *) - | Some simple_name, Some lbl when String.equal simple_name lbl -> pp f "~%s" lbl + | Some simple_name, Some lbl when String.equal simple_name lbl -> + pp f "~%s" lbl (* Labeled component general case *) | _, Some lbl -> pp f "~%s:%a" lbl (simple_expr ctxt) e (* Unlabeled component *) - | _, None -> expression2 ctxt f e (* level 2*) + | _, None -> expression2 ctxt f 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_ident (li) -> pp f "@ %a" value_longident li | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) and block_access ctxt f = function | Baccess_field li -> - pp f ".%a" longident_loc li + pp f ".%a" value_longident_loc li | Baccess_block (mut, index) -> let s = match mut with @@ -2228,7 +2330,7 @@ and block_access ctxt f = function and unboxed_access f = function | Uaccess_unboxed_field li -> - pp f ".#%a" longident_loc li + pp f ".#%a" value_longident_loc li and comprehension_expr ctxt f cexp = let punct, comp = match cexp with @@ -2323,16 +2425,16 @@ and function_params_then_body ctxt f params constraint_ body ~delimiter = and labeled_tuple_expr ctxt f ~unboxed x = pp f "@[%s(%a)@]" (if unboxed then "#" else "") - (list (tuple_component ctxt) ~sep:",@;") x + (list (tuple_expr_component ctxt) ~sep:",@;") x and record_expr ctxt f ~unboxed 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 + pexp_attributes=[]; _} when Longident.same li.txt txt -> + pp f "@[%a@]" value_longident_loc li | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + pp f "@[%a@;=@;%a@]" value_longident_loc li (simple_expr ctxt) e in let hash = if unboxed then "#" else "" in pp f "@[@[%s{@;%a%a@]@;}@]"(* "@[%s{%a%a}@]" *) @@ -2397,7 +2499,7 @@ let top_phrase f x = pp f ";;"; pp_print_newline f () -let longident = print_with_maximal_extensions longident +let longident = print_with_maximal_extensions value_longident let core_type = print_reset_with_maximal_extensions core_type let pattern = print_reset_with_maximal_extensions pattern let signature = print_reset_with_maximal_extensions signature diff --git a/upstream/ocaml_flambda/parsing/pprintast.mli b/upstream/ocaml_flambda/parsing/pprintast.mli index 9e1e48575..9dcd21515 100644 --- a/upstream/ocaml_flambda/parsing/pprintast.mli +++ b/upstream/ocaml_flambda/parsing/pprintast.mli @@ -24,6 +24,8 @@ type space_formatter = (unit, Format.formatter, unit) format val longident : Format.formatter -> Longident.t -> unit +val constr : Format.formatter -> Longident.t -> unit + val expression : Format.formatter -> Parsetree.expression -> unit val string_of_expression : Parsetree.expression -> string @@ -70,6 +72,11 @@ val mode : Format.formatter -> Parsetree.mode Location.loc -> unit (** {!Format_doc} functions for error messages *) module Doc:sig val longident: Longident.t Format_doc.printer + val constr: Longident.t Format_doc.printer val tyvar: string Format_doc.printer val jkind_annotation: Parsetree.jkind_annotation 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_flambda/parsing/printast.ml b/upstream/ocaml_flambda/parsing/printast.ml index 34968d041..937ee8b6b 100644 --- a/upstream/ocaml_flambda/parsing/printast.ml +++ b/upstream/ocaml_flambda/parsing/printast.ml @@ -38,9 +38,9 @@ let fmt_location f loc = 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.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y.txt s.txt | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + fprintf f "%a(%a)" fmt_longident_aux y.txt fmt_longident_aux z.txt let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x @@ -57,27 +57,10 @@ 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_unboxed_integer (i,m) -> fprintf f "PConst_unboxed_int (%s,%c)" i m - | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c) - | Pconst_untagged_char (c) -> - fprintf f "PConst_untagged_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 - | Pconst_unboxed_float (s,m) -> - fprintf f "PConst_unboxed_float (%s,%a)" s fmt_char_option m - let fmt_bool f x = match x with - | false -> fprintf f "false"; - | true -> fprintf f "true"; -;; - + | false -> fprintf f "false" + | true -> fprintf f "true" let fmt_mutable_flag f x = match x with | Immutable -> fprintf f "Immutable" @@ -117,6 +100,23 @@ 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_unboxed_integer (j,m) -> line i f "PConst_unboxed_int (%s,%c)\n" j m + | Pconst_char c -> line i f "PConst_char %02x\n" (Char.code c) + | Pconst_untagged_char c -> + line i f "PConst_untagged_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 + | Pconst_unboxed_float (s,m) -> + line i f "PConst_unboxed_float (%s,%a)\n" s fmt_char_option m + let list i f ppf l = match l with | [] -> line i ppf "[]\n" @@ -222,9 +222,9 @@ let rec core_type i ppf x = line i ppf "Ptyp_poly\n"; list i typevar ppf 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_package ptyp -> + line i ppf "Ptyp_package\n"; + package_type i ppf ptyp; | Ptyp_open (mod_ident, t) -> line i ppf "Ptyp_open \"%a\"\n" fmt_longident_loc mod_ident; core_type i ppf t @@ -255,6 +255,12 @@ and typevar i ppf (s, jkind) = and reprvar i ppf s = line i ppf "reprvar: %s\n" s.txt +and package_type i ppf ptyp = + let i = i + 1 in + line i ppf "package_type %a\n" fmt_longident_loc ptyp.ppt_path; + list i package_with ppf ptyp.ppt_cstrs; + attributes i ppf ptyp.ppt_attrs + and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident_loc s; core_type i ppf t @@ -269,14 +275,18 @@ 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_unboxed_unit -> line i ppf "Ppat_unboxed_unit\n"; | Ppat_unboxed_bool b -> line i ppf "Ppat_unboxed_bool %a\n" fmt_bool b; | Ppat_tuple (l, c) -> line i ppf "Ppat_tuple\n %a\n" fmt_closed_flag c; - list i (labeled_tuple_element pattern) ppf l + list i (labeled_tuple_element pattern) ppf l; | Ppat_unboxed_tuple (l, c) -> line i ppf "Ppat_unboxed_tuple %a\n" fmt_closed_flag c; list i (labeled_tuple_element pattern) ppf l @@ -323,6 +333,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 @@ -336,7 +350,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 (mf, rf, l, e) -> line i ppf "Pexp_let %a %a\n" fmt_mutable_flag mf fmt_rec_flag rf; list i value_binding ppf l; @@ -464,9 +480,10 @@ and expression i ppf x = line i ppf "Pexp_newtype \"%s\"\n" s.txt; jkind_annotation_opt i ppf jkind; expression i ppf e - | Pexp_pack me -> + | Pexp_pack (me, optyp) -> line i ppf "Pexp_pack\n"; - module_expr i ppf me + module_expr i ppf me; + option i package_type ppf optyp | Pexp_open (o, e) -> line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override; module_expr i ppf o.popen_expr; diff --git a/upstream/ocaml_flambda/parsing/printast.mli b/upstream/ocaml_flambda/parsing/printast.mli index 182a31e78..d8fe83f2b 100644 --- a/upstream/ocaml_flambda/parsing/printast.mli +++ b/upstream/ocaml_flambda/parsing/printast.mli @@ -26,10 +26,10 @@ open Format val interface : formatter -> signature -> unit val implementation : formatter -> structure_item list -> unit val top_phrase : formatter -> toplevel_phrase -> unit -val constant: formatter -> constant -> unit +val constant: int -> formatter -> constant -> unit -val expression: int -> formatter -> expression -> unit val pattern: int -> formatter -> pattern -> unit +val expression: int -> formatter -> expression -> unit val structure: int -> formatter -> structure -> unit val payload: int -> formatter -> payload -> unit val core_type: int -> formatter -> core_type -> unit diff --git a/upstream/ocaml_flambda/parsing/unit_info.ml b/upstream/ocaml_flambda/parsing/unit_info.ml index ca798e79f..c101dfc9d 100644 --- a/upstream/ocaml_flambda/parsing/unit_info.ml +++ b/upstream/ocaml_flambda/parsing/unit_info.ml @@ -18,6 +18,9 @@ type modname = string type filename = string type file_prefix = string +type error = Invalid_encoding of string +exception Error of error + type t = { original_source_file: filename; raw_source_file: filename; @@ -42,34 +45,40 @@ let basename_chop_extensions basename = String.sub basename 0 pos with 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 compilation_unit_from_source ~for_pack_prefix source_file = +let lax_modname_from_source source_file = + source_file |> stem |> modulize + +let compilation_unit_from_source ~strict ~for_pack_prefix source_file = + let modname_from_source = + if strict then strict_modname_from_source + else lax_modname_from_source + in let modname = modname_from_source source_file |> Compilation_unit.Name.of_string in Compilation_unit.create for_pack_prefix modname -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 - (* 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 = let name = modname file |> Compilation_unit.name_as_string in @@ -78,7 +87,9 @@ let check_unit_name file = (Warnings.Bad_module_name name) let make ?(check_modname=true) ~source_file ~for_pack_prefix kind prefix = - let modname = compilation_unit_from_source ~for_pack_prefix prefix in + let modname = + compilation_unit_from_source ~strict:true ~for_pack_prefix prefix + in let p = { modname; @@ -124,9 +135,13 @@ module Artifact = struct let prefix x = Filename.remove_extension (filename x) let from_filename ~for_pack_prefix filename = - let modname = compilation_unit_from_source ~for_pack_prefix filename in - - { modname; filename; original_source_file = None; raw_source_file = None } + let modname = + compilation_unit_from_source ~strict:false ~for_pack_prefix filename + in + { modname; + filename; + original_source_file = None; + raw_source_file = None } end @@ -192,3 +207,14 @@ let find_normalized_cmi f = original_source_file = Some f.original_source_file; raw_source_file = Some f.raw_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_flambda/parsing/unit_info.mli b/upstream/ocaml_flambda/parsing/unit_info.mli index 5990b8e2a..e3b387d37 100644 --- a/upstream/ocaml_flambda/parsing/unit_info.mli +++ b/upstream/ocaml_flambda/parsing/unit_info.mli @@ -28,20 +28,27 @@ type file_prefix = string (* CR lmaurer: These overlap with functionality in [Compilation_unit] **) +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 @@ -94,8 +101,8 @@ val kind: t -> intf_or_impl val check_unit_name : t -> unit (** [make ~check ~source_file ~for_pack_prefix kind prefix] associates both the - [source_file] and the module name {!modname_from_source}[ target_prefix] to - the prefix filesystem path [prefix]. + [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}. @@ -152,7 +159,7 @@ module Artifact: sig val modname: t -> Compilation_unit.t (** [from_filename ~for_pack_prefix filename] reconstructs the module name - [modname_from_source filename] associated to the artifact [filename], + [lax_modname_from_source filename] associated to the artifact [filename], assuming the pack prefix is [for_pack_prefix]. *) val from_filename: for_pack_prefix:Compilation_unit.Prefix.t -> filename -> t diff --git a/upstream/ocaml_flambda/typing/btype.ml b/upstream/ocaml_flambda/typing/btype.ml index aca60ead4..579802441 100644 --- a/upstream/ocaml_flambda/typing/btype.ml +++ b/upstream/ocaml_flambda/typing/btype.ml @@ -106,14 +106,67 @@ module TypePairs = struct 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 jkind = newgenty (Tvar { name; jkind }) let newgenstub ~scope jkind = @@ -129,6 +182,8 @@ 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_Tpoly ty = match get_desc ty with Tpoly _ -> 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 = @@ -293,8 +348,8 @@ let fold_type_expr f init ty = | Tarrow (_, ty1, ty2, _) -> let result = f init ty1 in f result ty2 - | Ttuple l -> List.fold_left f init (List.map snd l) - | Tunboxed_tuple l -> List.fold_left f init (List.map snd l) + | Ttuple l -> List.fold_left (fun acc (_, t) -> f acc t) init l + | Tunboxed_tuple l -> List.fold_left (fun acc (_, t) -> f acc t) init l | Tconstr (_, l, _) -> List.fold_left f init l | Tobject(ty, {contents = Some (_, p)}) -> let result = f init ty in @@ -318,8 +373,8 @@ let fold_type_expr f init ty = List.fold_left f result tyl | Trepr (ty, _sort_vars) -> f init ty - | Tpackage (_, fl) -> - List.fold_left (fun result (_n, ty) -> f result ty) init fl + | Tpackage pack -> + List.fold_left (fun result (_n, ty) -> f result ty) init pack.pack_cstrs | Tof_kind _ -> init let iter_type_expr f ty = @@ -482,7 +537,7 @@ let type_iterators mark = match get_desc ty with Tconstr (p, _, _) | Tobject (_, {contents=Some (p, _)}) - | Tpackage (p, _) -> + | Tpackage {pack_path = p} -> it.it_path p | Tvariant row -> Option.iter (fun (p,_) -> it.it_path p) (row_name row) @@ -558,7 +613,9 @@ let rec copy_type_desc ?(keep_names=false) f = function Tpoly (f ty, tyl) | Trepr (ty, sort_vars) -> Trepr (f ty, sort_vars) - | Tpackage (p, fl) -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl) + | Tpackage pack -> + Tpackage {pack with + pack_cstrs = List.map (fun (n, ty) -> (n, f ty)) pack.pack_cstrs} | Tof_kind jk -> Tof_kind jk (* TODO: rename to [module Copy_scope] *) @@ -834,17 +891,6 @@ let tpoly_get_poly ty = let tpoly_get_mono ty = match get_desc ty with | Tpoly(ty, []) -> ty - | _ -> assert false - - (**********) - (* Misc *) - (**********) - -(**** Type information getter ****) - -let cstr_type_path cstr = - match get_desc cstr.cstr_res with - | Tconstr (p, _, _) -> p | _ -> assert false (************) @@ -2431,6 +2477,13 @@ module Jkind0 = struct } ~annotation:None ~why:(Value_creation why) + let for_effect_arg ident = + let why : Jkind_intf.History.value_creation_reason = + Type_argument + { parent_path = Path.Pident ident; position = 1; arity = 1 } + in + Builtin.value ~why + let for_variant_with_null_result path param = let why : Jkind_intf.History.value_or_null_creation_reason = Type_argument diff --git a/upstream/ocaml_flambda/typing/btype.mli b/upstream/ocaml_flambda/typing/btype.mli index f8d15e42b..144e73e8b 100644 --- a/upstream/ocaml_flambda/typing/btype.mli +++ b/upstream/ocaml_flambda/typing/btype.mli @@ -64,6 +64,19 @@ val generic_level: int 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 -> jkind_lr -> type_expr @@ -85,10 +98,10 @@ val is_Tvar: type_expr -> bool val is_Tunivar: type_expr -> bool val is_Tconstr: type_expr -> bool val is_Tpoly: 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 (**** polymorphic variants ****) @@ -321,10 +334,6 @@ 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 - (* These modules exists here to resolve a dependency cycle: [Subst], [Predef], [Datarepr], and [Env] must not depend on [Jkind]. The portions intended for use outside of those modules are re-exported as [Jkind.With_bounds] and @@ -711,6 +720,8 @@ module Jkind0 : sig val for_or_null_argument : Ident.t -> 'd jkind val for_variant_with_null_result : Path.t -> type_expr -> jkind_l + val for_effect_arg : Ident.t -> 'd jkind + (** The jkind of a float. *) val for_float : Ident.t -> jkind_l diff --git a/upstream/ocaml_flambda/typing/cmt2annot.ml b/upstream/ocaml_flambda/typing/cmt2annot.ml index 186217e90..e272f5910 100644 --- a/upstream/ocaml_flambda/typing/cmt2annot.ml +++ b/upstream/ocaml_flambda/typing/cmt2annot.ml @@ -100,10 +100,12 @@ let rec iterator ~scope rebuild_env = 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/ocaml_flambda/typing/ctype.ml b/upstream/ocaml_flambda/typing/ctype.ml index 623c358ee..63e9dc02b 100644 --- a/upstream/ocaml_flambda/typing/ctype.ml +++ b/upstream/ocaml_flambda/typing/ctype.ml @@ -18,6 +18,7 @@ open Misc open Asttypes open Types +open Data_types open Btype open Errortrace open Mode @@ -27,16 +28,6 @@ module Int = Misc.Stdlib.Int let debug_ikind_crossing_mismatch = Sys.getenv_opt "OXCAML_IKIND_CROSSING_MISMATCH" <> None -(* - 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 ============= @@ -147,8 +138,35 @@ exception Cannot_subst exception Cannot_unify_universal_variables +exception Out_of_scope_universal_variable + exception Incompatible +(**** Control tracing of GADT instances *) + +let trace_gadt_instances = ref false +let check_trace_gadt_instances ?(force=false) env = + not !trace_gadt_instances && (force || 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 ?force env f x = + let b = check_trace_gadt_instances ?force env in + Misc.try_finally (fun () -> f x) + ~always:(fun () -> reset_trace_gadt_instances b) + +(**** 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 @@ -172,11 +190,82 @@ 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 +(* [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 = + with_new_pool ~level:!current_level begin fun () -> + let result = wrap_end_def f in + Option.iter (fun g -> g result) before_generalize; + result + end + in + simple_abbrevs := Mnil; + (* Nodes in [pool] were either created by the above calls to [f] + and [before_generalize], 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 ~before_generalize f = + with_local_level_gen + ~begin_def:begin_class_def ~structure:false ~before_generalize f + let mark_toplevel_in_quotations env = let scope = !current_level in (* Create a new scope to make sure we only capture what came before *) @@ -192,7 +281,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 = @@ -203,8 +292,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 () @@ -228,32 +316,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 *) @@ -300,22 +362,22 @@ module Pattern_env : sig type t = private { mutable env : Env.t; equations_scope : int; - allow_recursive_equations : bool; + in_counterexample : bool; is_lpoly : bool; } val make: ?is_lpoly:bool -> Env.t -> equations_scope:int - -> allow_recursive_equations:bool -> t + -> in_counterexample: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; + in_counterexample : bool; is_lpoly : bool; } - let make ?(is_lpoly=false) env ~equations_scope ~allow_recursive_equations = + let make ?(is_lpoly=false) env ~equations_scope ~in_counterexample = { env; equations_scope; - allow_recursive_equations; + in_counterexample; is_lpoly; } let copy ?equations_scope penv = let equations_scope = @@ -326,10 +388,6 @@ end (**** unification mode ****) -type equations_generation = - | Forbidden - | Allowed of { equated_types : TypePairs.t; pattern_stage : Env.stage } - type unification_environment = | Expression of { env : Env.t; @@ -337,7 +395,7 @@ type unification_environment = (* normal unification mode *) | Pattern of { penv : Pattern_env.t; - equations_generation : equations_generation; + equated_types : TypePairs.t; assume_injective : bool; unify_eq_set : TypePairs.t } (* GADT constraint unification mode: @@ -384,18 +442,13 @@ let in_subst_mode = function | Expression {in_subst} -> in_subst | Pattern _ -> false -let can_generate_equations = function - | Expression _ | Pattern { equations_generation = Forbidden } -> false - | Pattern { penv; equations_generation = Allowed { pattern_stage } } -> - Env.stage penv.env >= pattern_stage - (* Can only be called when generate_equations is true. Tracks equations only to improve error messages. *) let record_equation uenv t1 t2 = match uenv with - | Expression _ | Pattern { equations_generation = Forbidden } -> + | Expression _ -> invalid_arg "Ctype.record_equation" - | Pattern { equations_generation = Allowed { equated_types } } -> + | Pattern { equated_types } -> TypePairs.add equated_types (t1, t2) let can_assume_injective = function @@ -405,7 +458,7 @@ let can_assume_injective = function let in_counterexample uenv = match uenv with | Expression _ -> false - | Pattern { penv } -> penv.allow_recursive_equations + | Pattern { penv } -> penv.in_counterexample let allow_recursive_equations uenv = !Clflags.recursive_types || in_counterexample uenv @@ -417,11 +470,6 @@ let without_assume_injective uenv f = | 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 }) - (* In type checking, we only use [decr_stage] when we observe a spliced type. [Env.enter_splice] only fails when the splice would be top-level. Hence, no legitimate errors will ever be raised there and we can omit the [loc]. @@ -506,7 +554,6 @@ let unify_with_decr_stage uenv f = with exn -> Pattern_env.set_env p.penv (incr_stage p.penv.env); raise exn - (* Unification generally must check that the jkinds of the two types being unified agree. However, sometimes we need to delay these jkind checks, and this is tracked by the [jkind_unification_mode] in [lmode]. @@ -708,14 +755,14 @@ exception Non_closed of type_expr * variable_kind the abbreviations for use when displaying the type). [free_vars] accumulates its answer in a monoid-like structure, with - an initial element [zero] and a combining function [add_one], passing + an initial element [init] and a combining function [add_one], passing [add_one] information about whether the variable is a normal type variable or a row variable. [add_one] also received jkind information about [Tvar]s (but not [Tconstr]s that are expanded). It is marked [@inline] so that calls to [add_one] are not indirect. *) -let[@inline] free_vars ~zero ~add_one ?env mark tys = +let[@inline] free_vars ~init ~add_one ?env mark tys = let rec fv ~kind acc ty = if not (try_mark_node mark ty) then acc else match get_desc ty, env with @@ -744,11 +791,15 @@ let[@inline] free_vars ~zero ~add_one ?env mark tys = | _ -> fold_type_expr (fv ~kind) acc ty in - List.fold_left (fv ~kind:Type_variable) zero tys + List.fold_left (fv ~kind:Type_variable) init tys let free_variables ?env ty = let add_one ty _jkind _kind acc = ty :: acc in - with_type_mark (fun mark -> free_vars ~zero:[] ~add_one ?env mark [ty]) + with_type_mark (fun mark -> free_vars ~init:[] ~add_one ?env mark [ty]) + +let free_variables_list ?env tyl = + let add_one ty _jkind _kind acc = ty :: acc in + with_type_mark (fun mark -> free_vars ~init:[] ~add_one ?env mark tyl) let free_non_row_variables_of_list tyl = let add_one ty _jkind kind acc = @@ -756,7 +807,7 @@ let free_non_row_variables_of_list tyl = | Type_variable -> ty :: acc | Row_variable -> acc in - with_type_mark (fun mark -> free_vars ~zero:[] ~add_one mark tyl) + with_type_mark (fun mark -> free_vars ~init:[] ~add_one mark tyl) let free_variable_set_of_list env tys = let add_one ty jkind _kind acc = @@ -765,7 +816,7 @@ let free_variable_set_of_list env tys = | Some _jkind -> TypeSet.add ty acc in with_type_mark (fun mark -> - free_vars ~zero:TypeSet.empty ~add_one ~env mark tys) + free_vars ~init:TypeSet.empty ~add_one ~env mark tys) let exists_free_variable f ty = let exception Exists in @@ -776,12 +827,12 @@ let exists_free_variable f ty = | None -> assert false (* this only happens passing ~env to [free_vars] *) in with_type_mark (fun mark -> - try free_vars ~zero:() ~add_one mark [ty]; false + try free_vars ~init:() ~add_one mark [ty]; false with Exists -> true) let closed_type ?env mark ty = let add_one ty _jkind kind _acc = raise (Non_closed (ty, kind)) in - free_vars ~zero:() ~add_one ?env mark [ty] + free_vars ~init:() ~add_one ?env mark [ty] let closed_type_expr ?env ty = with_type_mark (fun mark -> @@ -955,55 +1006,63 @@ let generalize ty = simple_abbrevs := Mnil; generalize 0 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, Trepr, 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 (fun (_,t) -> generalize_spine t) tyl - | Tunboxed_tuple tyl -> - set_level ty generic_level; - List.iter (fun (_,t) -> generalize_spine t) 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 _ + | Tquote _ + | Tsplice _ + | Tquote_eval _ + | Tof_kind _ -> ty + | ( Tarrow _ | Tpoly _ | Trepr _ | Ttuple _ | Tunboxed_tuple _ | 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) (Jkind.Builtin.any ~why:Dummy_jkind) + 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) + | Trepr (ty', sl) -> + Trepr (copy_rec ty', sl) + | Ttuple tyl -> + Ttuple (List.map (fun (lbl, ty) -> (lbl, copy_rec ty)) tyl) + | Tunboxed_tuple tyl -> + Tunboxed_tuple (List.map (fun (lbl, ty) -> (lbl, copy_rec ty)) tyl) + | Tpackage {pack_path; pack_cstrs} -> + let fl = List.map (fun (n, ty) -> n, copy_rec ty) pack_cstrs in + Tpackage {pack_path; pack_cstrs = 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) @@ -1042,11 +1101,12 @@ let rec check_scope_escape mark env level ty = | exception Cannot_expand -> raise_escape_exn (Constructor p) end - | Tpackage (p, fl) when level < Path.scope p -> + | Tpackage ({pack_path = p} as pack) 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))) + (newty2 ~level:orig_level + (Tpackage {pack with pack_path = p'})) | _ -> iter_type_expr_with_stages (fun env -> check_scope_escape mark env level) env ty @@ -1082,8 +1142,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. *) @@ -1110,13 +1176,13 @@ 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 -> + | Tpackage ({pack_path = p} as pack) 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)); + set_type_desc ty (Tpackage {pack with pack_path = p'}); update_level env level expand ty | Tobject (_, ({contents=Some(p, _tl)} as nm)) when level < Path.scope p -> @@ -1128,13 +1194,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_with_stages (fun env -> update_level env level expand) env ty @@ -1197,8 +1263,8 @@ let rec lower_contravariant env var_level visited contra ty = | 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 + | Tpackage p -> + List.iter (fun (_n, ty) -> lower_rec true ty) p.pack_cstrs | Tarrow (_, t1, t2, _) -> lower_rec true t1; lower_rec contra t2 @@ -1215,11 +1281,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; @@ -1227,20 +1293,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 @@ -1281,8 +1337,8 @@ let limited_generalize ty0 ty = 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 *) @@ -1499,11 +1555,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 -> @@ -1545,7 +1597,7 @@ let new_local_type ?(loc = Location.none) ?manifest_and_scope origin jkind = type_loc = loc; type_attributes = []; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); type_unboxed_version = None; } @@ -1553,7 +1605,7 @@ let new_local_jkind ?(loc = Location.none) ?manifest () = { jkind_manifest = manifest; jkind_attributes = []; - jkind_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + jkind_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); jkind_loc = loc; } @@ -1671,11 +1723,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 @@ -2064,33 +2112,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 (Jkind.Builtin.any ~why:Dummy_jkind) 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 (Jkind.Builtin.any ~why:Dummy_jkind) 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 let jkind_subst env level params args jkind = (* CR layouts v2.8: This function is used a lot, but there is a better way. @@ -2168,6 +2214,7 @@ let check_abbrev_env env = if not (Env.same_type_declarations env !previous_env) then begin (* prerr_endline "cleanup expansion cache"; *) cleanup_abbrev (); + simple_abbrevs := Mnil; previous_env := env end @@ -2411,9 +2458,12 @@ let rec try_reduce_once env t = Trepr (new_quote_eval_ty t, sl) (* [<[ module S with type typ = t ]> eval] ==> [module S with type typ = <[t]> eval] *) - | Tpackage (p, fl) -> - path_must_be_toplevel env p; - Tpackage (p, List.map (fun (n, t) -> n, new_quote_eval_ty t) fl) + | Tpackage { pack_path; pack_cstrs } -> + path_must_be_toplevel env pack_path; + Tpackage { pack_path; + pack_cstrs = + List.map (fun (n, t) -> n, new_quote_eval_ty t) + pack_cstrs } (* It is safe not to expand [Tof_kind], and we do not need to currently *) | Tof_kind _ -> raise Cannot_expand | Tlink _ | Tsubst _ -> assert false @@ -2609,7 +2659,7 @@ let unbox_once env ty = GADTs, but projected onto the instantiated head arguments of the wrapper type rather than the declaration parameters. *) let res_args = - match get_desc cstr.Types.cstr_res with + match get_desc cstr.cstr_res with | Tconstr (_, res_args, _) -> res_args | _ -> Misc.fatal_error "Ctype.unbox_once: cstr_res" in @@ -3370,8 +3420,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 @@ -3532,6 +3582,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 *) (* Invariant: [jkind1] and [jkind2] (newly added) have to be the @@ -3559,15 +3620,24 @@ let unify_univar env t1 t2 jkind1 jkind2 pairs = | _ -> raise Cannot_unify_universal_variables end - | [] -> raise Cannot_unify_universal_variables + | [] -> + raise Out_of_scope_universal_variable in inner t1 t2 pairs (* The same as [unify_univar], but raises the appropriate exception instead of [Cannot_unify_universal_variables] *) -let unify_univar_for tr_exn env t1 t2 jkind1 jkind2 univar_pairs = - try unify_univar env t1 t2 jkind1 jkind2 univar_pairs - with Cannot_unify_universal_variables -> raise_unexplained_for tr_exn +let unify_univar_for (type a) (tr_exn : a trace_exn) env t1 t2 jkind1 jkind2 + univar_pairs = + try unify_univar env t1 t2 jkind1 jkind2 univar_pairs with + | Cannot_unify_universal_variables -> raise_unexplained_for tr_exn + | Out_of_scope_universal_variable -> + (* Allow unscoped univars when checking for equality, since one + might want to compare arbitrary subparts of types, ignoring scopes; + see Typedecl_variance (#13514) for instance *) + match tr_exn with + | Equality -> raise_unexplained_for tr_exn + | _ -> fatal_error "Ctype.unify_univar_for: univar not in scope" (* Test the occurrence of free univars in a type *) (* That's way too expensive. Must do some kind of caching *) @@ -3679,8 +3749,16 @@ let univars_escape env univar_pairs vl ty = occur env 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) @@ -3692,17 +3770,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 = @@ -3796,29 +3872,26 @@ let unexpanded_diff ~got ~expected = (**** Unification ****) +(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) let rec deep_occur_rec mark t0 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 (deep_occur_rec mark t0) ty end -(* Return whether [t0] occurs in any type in [tyl]. Objects are also traversed. *) -let deep_occur_list t0 tyl = - with_type_mark (fun mark -> - try - List.iter (deep_occur_rec mark t0) tyl; - false - with Occur -> - true) - let deep_occur t0 ty = - with_type_mark (fun mark -> - try - deep_occur_rec mark t0 ty; - false - with Occur -> - true) + try + with_type_mark (fun mark -> deep_occur_rec mark t0 ty); + false + with + | Occur -> true +let deep_occur_list t0 tyl = + try + with_type_mark (fun mark -> List.iter (deep_occur_rec mark t0) tyl); + false + with + | Occur -> true (* a local constraint can be added only if the rhs of the constraint does not contain any Tvars. @@ -3944,6 +4017,26 @@ 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 +let equivalent_with_nolabels l1 l2 = + l1 = l2 || (match l1, l2 with + | (Nolabel | Labelled _), (Nolabel | Labelled _) -> true + | _ -> false) + +(* 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) + && equivalent_with_nolabels l1 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 @@ -3955,23 +4048,27 @@ let rec expands_to_datatype env ty = end | _ -> false -let equivalent_with_nolabels l1 l2 = - l1 = l2 || (match l1, l2 with - | (Nolabel | Labelled _), (Nolabel | Labelled _) -> true - | _ -> false) - (* the [tk] means we're comparing a type against a jkind; axes do not matter, so a jkind extracted from a type_declaration does not need to be substed *) let may_have_jkind_intersection_tk env ty jkind = Jkind.may_have_intersection env (type_jkind env ty) jkind -(* [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] tests if two types are "compatible" -- i.e., if there could + exist a witness of their equality. This is distinct from [eqtype], + which checks if two types *are* exactly the same. + [mcomp] is used to decide whether GADT cases are unreachable. + The existence of a witness is necessarily an incomplete property, + i.e. there exists types for which we cannot tell if an equality + witness could exist or not. Typically, this is the case for + abstract types, which could be equal to anything, depending on + their actual definition. As a result [mcomp] overapproximates + compatibilty, i.e. when it says that two types are incompatible, we + are sure that there exists no equality witness, but if it does not + say so, there is no guarantee that such a witness could exist. + *) -(* mcomp type_pairs subst env t1 t2 does not raise an +(* [mcomp type_pairs subst env t1 t2] should 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. @@ -4032,9 +4129,9 @@ let rec mcomp type_pairs env t1 t2 = | (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 + raise Incompatible | (_, Tconstr (_, [], _), _, _) when has_injective_univars env t1' -> - raise_unexplained_for Unify + raise Incompatible | (Tconstr (p, _, _), _, _, other) | (_, Tconstr (p, _, _), other, _) -> begin try let decl = Env.find_type p env in @@ -4046,7 +4143,7 @@ let rec mcomp type_pairs env t1 t2 = end (* Rigid cases -- neither side is flexible nor aliasable *) | (Tarrow ((l1,_,_), t1, u1, _), Tarrow ((l2,_,_), t2, u2, _), _, _) - when equivalent_with_nolabels l1 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, _, _) -> @@ -4074,7 +4171,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) | (Trepr (t1, sort_vars1), Trepr (t2, sort_vars2), _, _) -> @@ -4086,8 +4183,10 @@ let rec mcomp type_pairs env t1 t2 = (fun () -> mcomp type_pairs env t1 t2) with Invalid_argument _ -> raise Incompatible) | (Tunivar {jkind=jkind1}, Tunivar {jkind=jkind2}, _, _) -> - (try unify_univar env t1' t2' jkind1 jkind2 !univar_pairs - with Cannot_unify_universal_variables -> raise Incompatible) + begin try unify_univar env t1' t2' jkind1 jkind2 !univar_pairs with + | Cannot_unify_universal_variables -> raise Incompatible + | Out_of_scope_universal_variable -> () + end | (_, _, _, _) -> raise Incompatible end @@ -4098,7 +4197,7 @@ and mcomp_list type_pairs env tl1 tl2 = List.iter2 (mcomp type_pairs env) tl1 tl2 and mcomp_labeled_list type_pairs env labeled_tl1 labeled_tl2 = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then raise Incompatible; List.iter2 (fun (label1, ty1) (label2, ty2) -> @@ -4393,29 +4492,18 @@ let eq_package_path env 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) +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 - 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 +(* Find the type paths nl1 in the module type pack2, 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 = +let complete_type_list ?(allow_absent=false) env fl1 lv2 pack2 = (* 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. @@ -4427,14 +4515,15 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = 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 env' = Env.add_module id2 Mp_present (Mty_ident pack2.pack_path) 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 + let lid = "Pkg" :: n in + let lid = Option.get (Longident.unflatten lid) in match Env.find_type_by_name lid env' with | (_, {type_arity = 0; type_kind = Type_abstract _; type_private = Public; type_manifest = Some t2}) -> @@ -4454,7 +4543,7 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = | exception Not_found when allow_absent-> complete nl fl2 in - match complete fl1 fl2 with + match complete fl1 pack2.pack_cstrs with | res -> res | exception Exit -> raise Not_found @@ -4463,7 +4552,7 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = let rec is_instantiable_ty uenv ty = match get_desc ty with | Tconstr (path, [], _) -> - can_generate_equations uenv && + in_pattern_mode uenv && is_instantiable (get_env uenv) ~for_jkind_eqn:false path | Tquote ty' -> unify_with_incr_stage uenv (fun uenv -> @@ -4491,13 +4580,14 @@ let rec instantiable_scope ty = | _ -> -1 (* 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 +let compare_package env unify_list lv1 pack1 lv2 pack2 = + let ntl2 = complete_type_list env pack1.pack_cstrs lv2 pack2 + and ntl1 = complete_type_list env pack2.pack_cstrs lv1 pack1 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 pack1.pack_path pack2.pack_path then Ok () + else Result.bind + (!package_subtype env pack1 pack2) + (fun () -> !package_subtype env pack2 pack1) let unify_alloc_mode_for tr_exn a b = match Alloc.equate a b with @@ -4554,24 +4644,22 @@ let unify3_var uenv jkind1 t1' t2 t2' = backtrack snap; reify uenv t1'; reify uenv t2'; - if can_generate_equations uenv then begin - begin match get_desc t2' with - | Tconstr(path,[],_) - when is_instantiable (get_env uenv) ~for_jkind_eqn:false path -> - add_gadt_equation uenv path t1' - (* This is necessary because a failed kind-check above - might meaningfully refine a type constructor *) - | _ -> - occur_univar ~inj_only:true (get_env uenv) t2'; - mcomp_for Unify (get_env uenv) t1' t2' - (* the call to [mcomp] can be skipped in the other case in this - [match] because [add_gadt_equation] checks for jkind - intersection, which is the only interesting check in [mcomp] - when one side is a variable. We could pull that check out - here specially, but it seems simpler not to. *) - end; - record_equation uenv t1' t2'; - end + begin match get_desc t2' with + | Tconstr(path,[],_) + when is_instantiable (get_env uenv) ~for_jkind_eqn:false path -> + add_gadt_equation uenv path t1' + (* This is necessary because a failed kind-check above + might meaningfully refine a type constructor *) + | _ -> + occur_univar ~inj_only:true (get_env uenv) t2'; + mcomp_for Unify (get_env uenv) t1' t2' + (* the call to [mcomp] can be skipped in the other case in this + [match] because [add_gadt_equation] checks for jkind + intersection, which is the only interesting check in [mcomp] + when one side is a variable. We could pull that check out + here specially, but it seems simpler not to. *) + end; + record_equation uenv t1' t2' (* 1. When unifying two non-abbreviated types, one type is made a link @@ -4739,15 +4827,11 @@ and unify3 uenv t1 t1' t2 t2' = end; try begin match (d1, d2) with - (Tarrow ((l1,a1,r1), t1, u1, c1), - Tarrow ((l2,a2,r2), t2, u2, c2)) - when - (l1 = l2 || - (!Clflags.classic || in_pattern_mode uenv) && - equivalent_with_nolabels l1 l2) -> + (Tarrow ((l1,a1,r1), t1, u1, c1), Tarrow ((l2,a2,r2), t2, u2, c2)) -> + eq_labels Unify ~in_pattern_mode:(in_pattern_mode uenv) l1 l2; unify_alloc_mode_for Unify a1 a2; unify_alloc_mode_for Unify r1 r2; - unify uenv t1 t2; unify uenv u1 u2; + 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 @@ -4759,7 +4843,7 @@ and unify3 uenv t1 t1' t2 t2' = | (Tunboxed_tuple labeled_tl1, Tunboxed_tuple labeled_tl2) -> unify_labeled_list uenv labeled_tl1 labeled_tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> - if not (can_generate_equations uenv) then + if not (in_pattern_mode 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) @@ -4775,22 +4859,17 @@ and unify3 uenv t1 t1' t2 t2' = 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) + if i then unify uenv t1 t2 else begin + 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 ~for_jkind_eqn:false path - && is_instantiable env ~for_jkind_eqn:false path' - && can_generate_equations uenv -> + when in_pattern_mode uenv && + let env = get_env uenv in + is_instantiable env ~for_jkind_eqn:false path + && is_instantiable env ~for_jkind_eqn:false path' -> let source, destination = if Path.scope path > Path.scope path' then path , t2' @@ -4799,14 +4878,14 @@ and unify3 uenv t1 t1' t2 t2' = record_equation uenv t1' t2'; add_gadt_equation uenv source destination | (Tconstr (path,[],_), _) - when is_instantiable (get_env uenv) ~for_jkind_eqn:false path - && can_generate_equations uenv -> + when in_pattern_mode uenv + && is_instantiable (get_env uenv) ~for_jkind_eqn:false path -> reify uenv t2'; record_equation uenv t1' t2'; add_gadt_equation uenv path t2' | (_, Tconstr (path,[],_)) - when is_instantiable (get_env uenv) ~for_jkind_eqn:false path - && can_generate_equations uenv -> + when in_pattern_mode uenv + && is_instantiable (get_env uenv) ~for_jkind_eqn:false path -> reify uenv t1'; record_equation uenv t1' t2'; add_gadt_equation uenv path t1' @@ -4845,10 +4924,8 @@ and unify3 uenv t1 t1' t2 t2' = && (is_equatable_ty t1 || is_equatable_ty t2) -> 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' - ) + 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] *) @@ -4870,10 +4947,8 @@ and unify3 uenv t1 t1' t2 t2' = 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' - ) + 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 @@ -4894,7 +4969,7 @@ 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) | (Trepr (t1, sort_vars1), Trepr (t2, sort_vars2)) -> (* For layout-polymorphic types, establish correspondence between @@ -4904,15 +4979,8 @@ and unify3 uenv t1 t1' t2 t2' = Jkind_types.Sort.enter_repr pairs (fun () -> unify uenv t1 t2) with Invalid_argument _ -> raise_unexplained_for Unify) - | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try - unify_package (get_env uenv) (unify_list uenv) - (get_level t1) p1 fl1 (get_level t2) p2 fl2 - with 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 + | (Tpackage pack1, Tpackage pack2) -> + unify_package uenv (get_level t1) pack1 (get_level t2) pack2 | (Tnil, Tconstr _ ) -> raise_for Unify (Obj (Abstract_row Second)) | (Tconstr _, Tnil ) -> @@ -4941,15 +5009,33 @@ and unify_list env tl1 tl2 = List.iter2 (unify env) tl1 tl2 and unify_labeled_list env labeled_tl1 labeled_tl2 = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then raise_unexplained_for Unify; List.iter2 (fun (label1, ty1) (label2, ty2) -> - if not (Option.equal String.equal label1 label2) then - raise_unexplained_for Unify; + if not (Option.equal String.equal label1 label2) then begin + let diff = { Errortrace.got=label1; expected=label2} in + raise_for Unify (Errortrace.Tuple_label_mismatch diff) + end; unify env ty1 ty2) labeled_tl1 labeled_tl2 +and unify_package uenv lvl1 pack1 lvl2 pack2 = + match + compare_package (get_env uenv) (unify_list uenv) lvl1 pack1 lvl2 pack2 + 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) + (pack1.pack_cstrs @ pack2.pack_cstrs); + | exception Not_found -> + if not (in_pattern_mode uenv) then raise_unexplained_for Unify; + List.iter (fun (_n, ty) -> reify uenv ty) + (pack1.pack_cstrs @ pack2.pack_cstrs); + (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) + (* Build a fresh row variable for unification *) and make_rowvar level use1 rest1 use2 rest2 = let set_name ty name = @@ -5233,21 +5319,30 @@ let unify uenv ty1 ty2 = undo_compress snap; raise (Unify (expand_to_unification_error (get_env uenv) trace)) -let unify_gadt (penv : Pattern_env.t) ty1 ty2 = - Misc.protect_refs [R (univar_pairs, [])] begin fun () -> +let unify_gadt (penv : Pattern_env.t) ~pat:ty1 ~expected:ty2 = let equated_types = TypePairs.create 0 in - let equations_generation = - Allowed { equated_types; pattern_stage = Env.stage penv.env } - in - let uenv = Pattern - { penv; - equations_generation; - assume_injective = true; - unify_eq_set = TypePairs.create 11; } + let do_unify_gadt () = + let uenv = Pattern + { penv; + equated_types; + assume_injective = true; + unify_eq_set = TypePairs.create 11; } + in + unify uenv ty1 ty2; + equated_types in - unify uenv ty1 ty2; - equated_types - end + let no_leak = penv.in_counterexample || closed_type_expr ty2 in + if no_leak then with_univar_pairs [] do_unify_gadt else + let snap = Btype.snapshot () in + try + (* If there are free variables, first try normal unification *) + let uenv = Expression {env = penv.env; in_subst = false} in + with_univar_pairs [] (fun () -> unify uenv ty1 ty2); + equated_types + with Unify _ -> + (* If it fails, retry in pattern mode *) + Btype.backtrack snap; + with_univar_pairs [] do_unify_gadt let unify_var uenv t1 t2 = if eq_type t1 t2 then () else @@ -5280,10 +5375,8 @@ let unify_var env ty1 ty2 = unify_var (Expression {env; in_subst = false}) ty1 ty2 let unify_pairs env ty1 ty2 pairs = - Misc.protect_refs [R (univar_pairs, pairs)] begin fun () -> - univar_pairs := pairs; - unify (Expression {env; in_subst = false}) ty1 ty2 - end + with_univar_pairs pairs (fun () -> + unify (Expression {env; in_subst = false}) ty1 ty2) let unify env ty1 ty2 = unify_pairs env ty1 ty2 [] @@ -5772,26 +5865,19 @@ 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 (Jkind.Builtin.value ~why:Object)) 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. @@ -5801,7 +5887,7 @@ 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 is_Tvar ty && lv >= subject_level then raise Occur else if try_mark_node mark ty then iter_type_expr occur ty in try @@ -5982,7 +6068,7 @@ let moregen_alloc_mode env ~is_ret ty v a1 a2 = 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 variance type_pairs env t1 t2 = @@ -6018,9 +6104,8 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = check_type_jkind_exn env Moregen t2 (Jkind.disallow_left jkind); link_type t1' t2 | (Tarrow ((l1,a1,r1), t1, u1, _), - Tarrow ((l2,a2,r2), t2, u2, _)) when - (l1 = l2 - || !Clflags.classic && equivalent_with_nolabels l1 l2) -> + Tarrow ((l2,a2,r2), t2, u2, _)) -> + eq_labels Moregen ~in_pattern_mode:false l1 l2; moregen inst_nongen (neg_variance variance) type_pairs env t1 t2; moregen inst_nongen variance type_pairs env u1 u2; (* [t2] and [u2] is the user-written interface, which we deem as @@ -6049,12 +6134,9 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = | exception Not_found -> moregen_list inst_nongen Invariant type_pairs env tl1 tl2 end - | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try - unify_package env (moregen_list inst_nongen variance type_pairs env) - (get_level t1') p1 fl1 (get_level t2') p2 fl2 - with Not_found -> raise_unexplained_for Moregen - end + | (Tpackage pack1, Tpackage pack2) -> + moregen_package inst_nongen variance type_pairs env + (get_level t1') pack1 (get_level t2') pack2 | (Tnil, Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second)) | (Tconstr _, Tnil ) -> raise_for Moregen (Obj (Abstract_row First)) | (Tvariant row1, Tvariant row2) -> @@ -6069,7 +6151,7 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = | (Tpoly (t1, []), Tpoly (t2, [])) -> moregen inst_nongen variance 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 variance type_pairs env) | (Trepr (t1, sort_vars1), Trepr (t2, sort_vars2)) -> (* For layout-polymorphic types, establish correspondence @@ -6105,7 +6187,7 @@ and moregen_list inst_nongen variance type_pairs env tl1 tl2 = and moregen_labeled_list inst_nongen variance type_pairs env labeled_tl1 labeled_tl2 = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then raise_unexplained_for Moregen; List.iter2 (fun (label1, ty1) (label2, ty2) -> @@ -6123,6 +6205,15 @@ and moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 = moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 | _, _, _ -> raise_unexplained_for Moregen +and moregen_package inst_nongen variance type_pairs env lvl1 pack1 lvl2 pack2 = + match + compare_package env (moregen_list inst_nongen variance type_pairs env) + lvl1 pack1 lvl2 pack2 + with + | Ok () -> () + | Error fme -> raise_for Moregen (First_class_module fme) + | exception Not_found -> raise_unexplained_for Moregen + and moregen_fields inst_nongen variance type_pairs env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in @@ -6277,63 +6368,70 @@ and moregen_row inst_nongen variance type_pairs env row1 row2 = is unimportant. So, no need to propagate abbreviations. *) let moregeneral env inst_nongen pat_sort_vars subj_sort_vars pat_sch subj_sch = - let old_level = !current_level in - Misc.try_finally - (fun () -> - 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_sorts, subj_inst) = - Jkind_types.Sort.instance_with ~level:!current_level subj_sort_vars - (fun () -> instance subj_sch) - in - let subj = duplicate_type subj_inst in - current_level := generic_level; - (* Duplicate generic variables *) - let (pat_sorts, patt) = - Jkind_types.Sort.instance_with ~level:!current_level pat_sort_vars - (fun () -> instance pat_sch) - in - try - Misc.protect_refs [R (univar_pairs, [])] begin fun () -> - let type_pairs = fresh_moregen_pairs () in - moregen inst_nongen Covariant type_pairs env patt subj; - (* After [moregen], [pat_sorts] have been set to [subj_sorts]. - [subj_sorts] are ephemeral rigid vars created by - [instance_with] to stand for [subj_sort_vars] during moregen. - Replace them back with the originals so that the returned - [pat_sort_refs] refer to [subj_sort_vars], not to the - short-lived rigid instances. *) - let subj_sort_vars = + (* 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, + by regeneralizing the levels of the types on the error path. + *) + with_level ~level:(subject_level - 1) begin fun () -> + (* + 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_sorts, subj_inst, subj) = + with_level ~level:subject_level begin fun () -> + let (subj_sorts, subj_inst) = + Jkind_types.Sort.instance_with ~level:!current_level subj_sort_vars + (fun () -> instance subj_sch) + in + let subj = duplicate_type subj_inst in + (subj_sorts, subj_inst, subj) + end + in + (* Duplicate generic variables *) + let (pat_sorts, patt) = + Jkind_types.Sort.instance_with ~level:generic_level pat_sort_vars + (fun () -> generic_instance pat_sch) + in + try + with_univar_pairs [] begin fun () -> + let type_pairs = fresh_moregen_pairs () in + moregen inst_nongen Covariant type_pairs env patt subj; + (* After [moregen], [pat_sorts] have been set to [subj_sorts]. + [subj_sorts] are ephemeral rigid vars created by + [instance_with] to stand for [subj_sort_vars] during moregen. + Replace them back with the originals so that the returned + [pat_sort_refs] refer to [subj_sort_vars], not to the + short-lived rigid instances. *) + let subj_sort_vars = List.map (fun v -> Jkind_types.Sort.Var v) subj_sort_vars - in - let subst_map = List.combine subj_sorts subj_sort_vars in - List.map - (fun v -> - v - |> Jkind_types.Sort.get_representable_var - |> Option.map (Jkind_types.Sort.subst subst_map)) - pat_sorts - end - 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; - let (), _sub_sorts = - Jkind_types.Sort.generalize_with (fun () -> generalize subj_inst) - in - raise (Moregen (expand_to_moregen_error env trace))) - ~always:(fun () -> current_level := old_level) + in + let subst_map = List.combine subj_sorts subj_sort_vars in + List.map + (fun v -> + v + |> Jkind_types.Sort.get_representable_var + |> Option.map (Jkind_types.Sort.subst subst_map)) + pat_sorts + end + with Moregen_trace trace -> + (* 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 this error, we need to merge them back together, + by regeneralizing the levels of the types after they were + instantiated at [subject_level] 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. *) + let (), _sub_sorts = + Jkind_types.Sort.generalize_with (fun () -> generalize subj_inst) + in + 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 @@ -6495,13 +6593,12 @@ let rec eqtype rename type_pairs subst env ~do_jkind_check t1 t2 = let check_phys_eq t1 t2 = not rename && eq_type t1 t2 in - (* Checking for physical equality 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. + (* 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 phyiscal + 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 @@ -6525,9 +6622,8 @@ let rec eqtype rename type_pairs subst env ~do_jkind_check t1 t2 = (Tvar { jkind = k1 }, Tvar { jkind = k2 }) when rename -> eqtype_subst env type_pairs subst t1' k1 t2' k2 ~do_jkind_check | (Tarrow ((l1,a1,r1), t1, u1, _), - Tarrow ((l2,a2,r2), t2, u2, _)) when - (l1 = l2 - || !Clflags.classic && equivalent_with_nolabels l1 l2) -> + Tarrow ((l2,a2,r2), t2, u2, _)) -> + eq_labels Equality ~in_pattern_mode:false l1 l2; eqtype rename type_pairs subst env t1 t2 ~do_jkind_check:true; eqtype rename type_pairs subst env u1 u2 ~do_jkind_check:true; eqtype_alloc_mode a1 a2; @@ -6542,13 +6638,9 @@ let rec eqtype rename type_pairs subst env ~do_jkind_check t1 t2 = when Path.same p1 p2 -> eqtype_list_same_length rename type_pairs subst env tl1 tl2 ~do_jkind_check:true - | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> - begin try - unify_package env - (eqtype_list rename type_pairs subst env ~do_jkind_check:true) - (get_level t1') p1 fl1 (get_level t2') p2 fl2 - with Not_found -> raise_unexplained_for Equality - end + | (Tpackage pack1, Tpackage pack2) -> + eqtype_package rename type_pairs subst env + (get_level t1') pack1 (get_level t2') pack2 | (Tnil, Tconstr _ ) -> raise_for Equality (Obj (Abstract_row Second)) | (Tconstr _, Tnil ) -> @@ -6565,7 +6657,7 @@ let rec eqtype rename type_pairs subst env ~do_jkind_check t1 t2 = | (Tpoly (t1, []), Tpoly (t2, [])) -> eqtype rename type_pairs subst env t1 t2 ~do_jkind_check | (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 ~do_jkind_check) | (Trepr (t1, sort_vars1), Trepr (t2, sort_vars2)) -> (* For layout-polymorphic types, establish correspondence @@ -6603,7 +6695,7 @@ and eqtype_list rename type_pairs subst env tl1 tl2 ~do_jkind_check = eqtype_list_same_length rename type_pairs subst env tl1 tl2 ~do_jkind_check and eqtype_labeled_list rename type_pairs subst env labeled_tl1 labeled_tl2 = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then raise_unexplained_for Equality; List.iter2 (fun (label1, ty1) (label2, ty2) -> @@ -6612,6 +6704,16 @@ and eqtype_labeled_list rename type_pairs subst env labeled_tl1 labeled_tl2 = eqtype rename type_pairs subst env ty1 ty2 ~do_jkind_check:true) labeled_tl1 labeled_tl2 +and eqtype_package rename type_pairs subst env lvl1 pack1 lvl2 pack2 = + match + compare_package env + (eqtype_list rename type_pairs subst env ~do_jkind_check:true) + lvl1 pack1 lvl2 pack2 + with + | Ok () -> () + | Error fme -> raise_for Equality (First_class_module fme) + | exception Not_found -> raise_unexplained_for Equality + and eqtype_fields rename type_pairs subst env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 in let (fields2, rest2) = flatten_fields ty2 in @@ -6741,16 +6843,16 @@ and eqtype_alloc_mode m1 m2 = (* Must empty univar_pairs first *) let eqtype_list_same_length rename type_pairs subst env tl1 tl2 ~do_jkind_check = - Misc.protect_refs [R (univar_pairs, [])] begin 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 ~do_jkind_check) - end + 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 ~do_jkind_check)) let eqtype rename type_pairs subst env t1 t2 = - eqtype_list ~do_jkind_check:true rename type_pairs subst env [t1] [t2] + eqtype_list_same_length ~do_jkind_check:true rename type_pairs subst env [t1] + [t2] (* Two modes: with or without renaming of variables *) let equal ?(do_jkind_check = true) env rename tyl1 tyl2 = @@ -6924,48 +7026,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 = fresh_moregen_pairs () 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.invariant_pairs (self1, self2); - (* Always succeeds *) - moregen true Covariant 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 ~before_generalize:ignore 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 = fresh_moregen_pairs () 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.invariant_pairs (self1, self2); + (* Always succeeds *) + moregen true Covariant 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 @@ -7388,8 +7490,8 @@ let rec subtype_rec env trace t1 t2 cstrs = (Tvar _, _) | (_, Tvar _) -> (trace, t1, t2, !univar_pairs)::cstrs | (Tarrow((l1,a1,r1), t1, u1, _), - Tarrow((l2,a2,r2), t2, u2, _)) when l1 = l2 - || !Clflags.classic && equivalent_with_nolabels l1 l2 -> + Tarrow((l2,a2,r2), t2, u2, _)) + when compatible_labels ~in_pattern_mode:false l1 l2 -> let cstrs = subtype_rec env @@ -7428,7 +7530,8 @@ let rec subtype_rec env trace t1 t2 cstrs = if co then if cn then (trace, newty2 ~level:(get_level t1) (Ttuple[None, t1]), - newty2 ~level:(get_level t2) (Ttuple[None, t2]), !univar_pairs) + newty2 ~level:(get_level t2) (Ttuple[None, t2]), + !univar_pairs) :: cstrs else subtype_rec @@ -7473,7 +7576,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 @@ -7486,31 +7589,9 @@ let rec subtype_rec env trace t1 t2 cstrs = Jkind_types.Sort.enter_repr pairs (fun () -> subtype_rec env trace u1 u2 cstrs) with Invalid_argument _ -> (trace, t1, t2, !univar_pairs)::cstrs) - | (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 !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 + | (Tpackage pack1, Tpackage pack2) -> + subtype_package env trace (get_level t1) pack1 + (get_level t2) pack2 cstrs | (Tquote t1, Tquote t2) -> subtype_rec (incr_stage env) trace t1 t2 cstrs | (Tsplice t1, Tsplice t2) -> @@ -7522,7 +7603,7 @@ let rec subtype_rec env trace t1 t2 cstrs = end and subtype_labeled_list env trace labeled_tl1 labeled_tl2 cstrs = - if not (Int.equal (List.length labeled_tl1) (List.length labeled_tl2)) then + if 0 <> List.compare_lengths labeled_tl1 labeled_tl2 then subtype_error ~env ~trace ~unification_trace:[]; List.fold_left2 (fun cstrs (label1, ty1) (label2, ty2) -> @@ -7535,6 +7616,31 @@ and subtype_labeled_list env trace labeled_tl1 labeled_tl2 cstrs = cstrs) cstrs labeled_tl1 labeled_tl2 +and subtype_package env trace lvl1 pack1 lvl2 pack2 cstrs = + try + let ntl1 = complete_type_list env pack2.pack_cstrs lvl1 pack1 + and ntl2 = + complete_type_list env pack1.pack_cstrs lvl2 pack2 + ~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 pack1.pack_path pack2.pack_path 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 pack1 pack2) -> + Btype.backtrack snap; cstrs' @ cstrs + | () | exception Unify _ -> + Btype.backtrack snap; raise Not_found + end + with Not_found -> + (trace, newty (Tpackage pack1), newty (Tpackage pack2), !univar_pairs) + ::cstrs + and subtype_fields env trace ty1 ty2 cstrs = (* Assume that either rest1 or rest2 is not Tvar *) let (fields1, rest1) = flatten_fields ty1 in @@ -7587,7 +7693,7 @@ and subtype_row env trace row1 row2 cstrs = | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) when row1_closed && r1 = [] -> List.fold_left - (fun cstrs (_,f1,f2) -> + (fun cstrs (l,f1,f2) -> match row_field_repr f1, row_field_repr f2 with (Rpresent None|Reither(true,_,_)), Rpresent None -> cstrs @@ -7604,7 +7710,12 @@ and subtype_row env trace row1 row2 cstrs = t1 t2 cstrs | Rabsent, _ -> cstrs - | _ -> raise Exit) + | Rpresent None, Rpresent (Some _) + | Rpresent (Some _), Rpresent None -> + subtype_error ~env ~trace + ~unification_trace:[Variant (Incompatible_types_for l)] + | _ -> + raise Exit) cstrs pairs | Tunivar _, Tunivar _ when row1_closed = row2_closed && r1 = [] && r2 = [] -> @@ -7636,20 +7747,22 @@ and subtype_row env trace row1 row2 cstrs = let subtype env ty1 ty2 = TypePairs.clear subtypes; - Misc.protect_refs [R (univar_pairs, [])] begin 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) - end + 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 *) @@ -7841,7 +7954,8 @@ let rec normalize_type_rec mark ty = begin match !nm with | None -> () | Some (n, v :: l) -> - if deep_occur_list ty l then + if deep_occur_list ty l + then (* The abbreviation may be hiding something, so remove it *) set_name nm None else @@ -7955,13 +8069,16 @@ let rec nondep_type_rec ?(expand_private=false) env ids ty = *) with Cannot_expand -> raise exn end - | Tpackage(p, fl) when Path.exists_free ids p -> - let p' = normalize_package_path env p in + | Tpackage pack when Path.exists_free ids pack.pack_path -> + let p' = normalize_package_path env pack.pack_path 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) + Tpackage { + pack_path = p'; + pack_cstrs = List.map nondep_field_rec pack.pack_cstrs + } end | Tobject (t1, name) -> Tobject (nondep_type_rec env ids t1, diff --git a/upstream/ocaml_flambda/typing/ctype.mli b/upstream/ocaml_flambda/typing/ctype.mli index d2741b9ad..3b1539d6d 100644 --- a/upstream/ocaml_flambda/typing/ctype.mli +++ b/upstream/ocaml_flambda/typing/ctype.mli @@ -34,6 +34,16 @@ 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: + before_generalize:('a -> unit) -> (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. @@ -143,7 +153,7 @@ val iter_type_expr_with_stages: (Env.t -> type_expr -> unit) -> Env.t -> type_expr -> unit val generalize: type_expr -> unit - (* Generalize in-place the given type *) +(* 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 *) @@ -151,23 +161,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 @@ -196,13 +199,13 @@ module Pattern_env : sig { mutable env : Env.t; equations_scope : int; (* scope for local type declarations *) - allow_recursive_equations : bool; + in_counterexample : bool; (* true iff checking counter examples *) is_lpoly : bool; (* true iff the pattern is under let poly_ *) } - val make: ?is_lpoly:bool -> Env.t -> equations_scope:int - -> allow_recursive_equations:bool -> t + val make: ?is_lpoly:bool -> + Env.t -> equations_scope:int -> in_counterexample:bool -> t val copy: ?equations_scope:int -> t -> t val set_env: t -> Env.t -> unit end @@ -211,10 +214,12 @@ type existential_treatment = | Keep_existentials_flexible | Make_existentials_abstract of Pattern_env.t -val instance_constructor: existential_treatment -> - constructor_description -> - Types.constructor_argument list * type_expr * type_expr list - (* Same, for a constructor. Also returns existentials. *) +val instance_constructor: + existential_treatment -> + Data_types.constructor_description -> + Types.constructor_argument 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 @@ -235,10 +240,12 @@ val instance_poly_fixed: checking that an expression matches this scheme. *) val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool + val instance_label: - fixed:bool -> - _ gen_label_description -> type_expr list * type_expr * type_expr - (* Same, for a label *) + fixed:bool -> + _ Data_types.gen_label_description -> + type_expr list * type_expr * type_expr +(* Same, for a label *) val prim_mode : (Mode.allowed * 'r) Mode.Locality.t option -> (Primitive.mode * Primitive.native_repr) -> (Mode.allowed * 'r) Mode.Locality.t @@ -306,13 +313,19 @@ 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: - 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. *) + Pattern_env.t -> pat:type_expr -> expected:type_expr -> Btype.TypePairs.t + (* [unify_gadt penv ~pat:ty1 ~expected:ty2] unifies [ty1] and [ty2] + in [Pattern] mode, possible adding local constraints to the + environment in [penv]. Raises [Unify] if not possible. + Returns the pairs of types that have been equated. + Type variables in [ty1] are always assumed to be non-leaking + (safely reifiable); if [penv.in_counterexample = true] + then both [ty1] and [ty2] are assumed to be non-leaking. *) val unify_var: Env.t -> type_expr -> type_expr -> unit (* Same as [unify], but allow free univars when first type is a variable. *) @@ -348,11 +361,11 @@ 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 + (* Check whether a type occurs structurally within another. *) val deep_occur_list: type_expr -> type_expr list -> bool (* Check whether a type occurs structurally within any type from a list of types. *) -val deep_occur: type_expr -> type_expr -> bool - (* Check whether a type occurs structurally within another. *) val moregeneral: Env.t -> bool -> Jkind_types.Sort.var list -> Jkind_types.Sort.var list -> type_expr -> type_expr -> Jkind_types.Sort.t option list @@ -569,15 +582,15 @@ type closed_class_failure = { val free_variables: ?env:Env.t -> type_expr -> type_expr list (* If env present, then check for incomplete definitions too; returns both normal variables and row variables*) +val free_variables_list: ?env:Env.t -> type_expr list -> type_expr list + (* If env present, then check for incomplete definitions too *) val free_non_row_variables_of_list: type_expr list -> type_expr list (* gets only non-row variables *) val free_variable_set_of_list: Env.t -> type_expr list -> Btype.TypeSet.t (* post-condition: all elements in the set are Tvars *) - val exists_free_variable : (type_expr -> jkind_lr -> bool) -> type_expr -> bool (* Check if there exists a free variable that satisfies the given predicate. *) - val closed_type_expr: ?env:Env.t -> type_expr -> bool (* If env present, expand abbreviations to see if expansion eliminates the variable *) @@ -598,12 +611,12 @@ 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 wrap_trace_gadt_instances: ?force:bool -> Env.t -> ('a -> 'b) -> 'a -> 'b (* Stubs *) val package_subtype : - (Env.t -> Path.t -> (Longident.t * type_expr) list -> - Path.t -> (Longident.t * type_expr) list -> bool) ref + (Env.t -> package -> package -> + (unit,Errortrace.first_class_module) Result.t) ref (* Raises [Incompatible] *) val mcomp : Env.t -> type_expr -> type_expr -> unit diff --git a/upstream/ocaml_flambda/typing/data_types.ml b/upstream/ocaml_flambda/typing/data_types.ml new file mode 100644 index 000000000..e385eed25 --- /dev/null +++ b/upstream/ocaml_flambda/typing/data_types.ml @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Picube, 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 Asttypes +open Types + +(* 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: constructor_argument list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: tag; (* Tag for heap blocks *) + cstr_repr: variant_representation; (* Repr of the outer variant *) + cstr_shape: constructor_representation; (* Repr of the constructor itself *) + cstr_constant: bool; + (* True if it's the constructor of a non-[@@unboxed] variant with 0 bits of + payload. (Or equivalently, if it's represented as either a tagged int or + the null pointer) *) + 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; + } + +let equal_constr c1 c2 = + equal_tag c1.cstr_tag c2.cstr_tag + +let may_equal_constr c1 c2 = + c1.cstr_arity = c2.cstr_arity + && (match c1.cstr_tag,c2.cstr_tag with + | Extension _, Extension _ -> + (* extension constructors may be rebindings of each other *) + true + | tag1, tag2 -> + equal_tag tag1 tag2) + +let cstr_res_type_path cstr = + match get_desc cstr.cstr_res with + | Tconstr (p, _, _) -> p + | _ -> assert false + +type 'a gen_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: mutability; (* Is this a mutable field? *) + lbl_modalities: Mode.Modality.Const.t;(* Modalities on the field *) + lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) + lbl_pos: int; (* Position in type *) + lbl_all: 'a gen_label_description array; (* All the labels in this type *) + lbl_repres: 'a; (* Representation for outer record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +type label_description = record_representation gen_label_description + +type unboxed_label_description = + record_unboxed_product_representation gen_label_description + +type _ record_form = + | Legacy : record_representation record_form + | Unboxed_product : record_unboxed_product_representation record_form + +type record_form_packed = + | P : _ record_form -> record_form_packed + +let record_form_to_string (type rep) (record_form : rep record_form) = + match record_form with + | Legacy -> "record" + | Unboxed_product -> "unboxed record" + +let gen_lbl_res_type_path lbl = + match get_desc lbl.lbl_res with + | Tconstr (p, _, _) -> p + | _ -> assert false + +let lbl_res_type_path lbl = gen_lbl_res_type_path lbl diff --git a/upstream/ocaml_flambda/typing/data_types.mli b/upstream/ocaml_flambda/typing/data_types.mli new file mode 100644 index 000000000..7d5509764 --- /dev/null +++ b/upstream/ocaml_flambda/typing/data_types.mli @@ -0,0 +1,96 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Picube, 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 Asttypes +open Types + +(* 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: constructor_argument list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: tag; (* Tag for heap blocks *) + cstr_repr: variant_representation; (* Repr of the outer variant *) + cstr_shape: constructor_representation; (* Repr of the constructor itself *) + cstr_constant: bool; (* True if all args are void *) + 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; + (* [Some decl] here iff the cstr has an inline record (which is decl) *) + cstr_uid: Uid.t; + } + +(* Constructors are the same: they return (structurally)-equal values + when applied to equal arguments. *) +val equal_constr : + constructor_description -> constructor_description -> bool + +(* Constructors may be the same, given potential rebinding. *) +val may_equal_constr : + constructor_description -> constructor_description -> bool + +(* Type constructor of the constructor's result type. *) +val cstr_res_type_path : constructor_description -> Path.t + +type 'a gen_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: mutability; (* Is this a mutable field? *) + lbl_modalities: Mode.Modality.Const.t; + (* Modalities on the field *) + lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) + lbl_pos: int; (* Position in type *) + lbl_all: 'a gen_label_description array; (* All the labels in this type *) + lbl_repres: 'a; (* Representation for outer record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +type label_description = record_representation gen_label_description + +type unboxed_label_description = + record_unboxed_product_representation gen_label_description + +(** This type tracks the distinction between legacy records ([{ field }]) and + unboxed records ([#{ field }]). Note that [Legacy] includes normal boxed + records, as well as inlined and [[@@unboxed]] records. + + As a GADT, it also lets us avoid duplicating functions that handle both + record forms, such as [Env.find_label_by_name], which has type + ['rep record_form -> Longident.t -> Env.t -> 'rep gen_label_description]. +*) +type _ record_form = + | Legacy : record_representation record_form + | Unboxed_product : record_unboxed_product_representation record_form + +type record_form_packed = + | P : _ record_form -> record_form_packed + +val record_form_to_string : _ record_form -> string + +(* Type constructor of the label record type. *) +val lbl_res_type_path : label_description -> Path.t +val gen_lbl_res_type_path : _ gen_label_description -> Path.t diff --git a/upstream/ocaml_flambda/typing/datarepr.ml b/upstream/ocaml_flambda/typing/datarepr.ml index bbeb1a6fa..cef6887da 100644 --- a/upstream/ocaml_flambda/typing/datarepr.ml +++ b/upstream/ocaml_flambda/typing/datarepr.ml @@ -18,6 +18,7 @@ open Asttypes open Types +open Data_types open Btype module Jkind = Btype.Jkind0 @@ -31,13 +32,13 @@ let free_vars ?(param=false) ty = | 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_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 @@ -283,7 +284,7 @@ let dummy_label (type rep) (record_form : rep record_form) { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; lbl_modalities = Mode.Modality.Const.id; lbl_sort = Jkind_types.Sort.Const.void; - lbl_pos = -1; lbl_all = [||]; + lbl_pos = (-1); lbl_all = [||]; lbl_repres = repres; lbl_private = Public; lbl_loc = Location.none; @@ -293,7 +294,7 @@ let dummy_label (type rep) (record_form : rep record_form) let label_descrs record_form ty_res lbls repres priv = let all_labels = Array.make (List.length lbls) (dummy_label record_form) in - let rec describe_labels pos = function + let rec describe_labels num = function [] -> [] | l :: rest -> let lbl = @@ -303,7 +304,7 @@ let label_descrs record_form ty_res lbls repres priv = lbl_mut = l.ld_mutable; lbl_modalities = l.ld_modalities; lbl_sort = l.ld_sort; - lbl_pos = pos; + lbl_pos = num; lbl_all = all_labels; lbl_repres = repres; lbl_private = priv; @@ -311,8 +312,8 @@ let label_descrs record_form ty_res lbls repres priv = lbl_attributes = l.ld_attributes; lbl_uid = l.ld_uid; } in - all_labels.(pos) <- lbl; - (l.ld_id, lbl) :: describe_labels (pos+1) rest in + all_labels.(num) <- lbl; + (l.ld_id, lbl) :: describe_labels (num+1) rest in describe_labels 0 lbls exception Constr_not_found diff --git a/upstream/ocaml_flambda/typing/datarepr.mli b/upstream/ocaml_flambda/typing/datarepr.mli index 6c8e7c24e..ab11e613a 100644 --- a/upstream/ocaml_flambda/typing/datarepr.mli +++ b/upstream/ocaml_flambda/typing/datarepr.mli @@ -17,9 +17,10 @@ determining their representation. *) open Types +open Data_types val extension_descr: - current_unit:Unit_info.t option -> Path.t -> extension_constructor -> + current_unit:(Unit_info.t option) -> Path.t -> extension_constructor -> constructor_description val labels_of_type: @@ -29,7 +30,7 @@ val unboxed_labels_of_type: Path.t -> type_declaration -> (Ident.t * unboxed_label_description) list val constructors_of_type: - current_unit:Unit_info.t option -> Path.t -> type_declaration -> + current_unit:(Unit_info.t option) -> Path.t -> type_declaration -> (Ident.t * constructor_description) list diff --git a/upstream/ocaml_flambda/typing/env.ml b/upstream/ocaml_flambda/typing/env.ml index e04625b3c..0b4a045bd 100644 --- a/upstream/ocaml_flambda/typing/env.ml +++ b/upstream/ocaml_flambda/typing/env.ml @@ -23,6 +23,7 @@ open Asttypes open Longident open Path open Types +open Data_types open Local_store @@ -1123,49 +1124,59 @@ let rec address_head = function | Adot (a, _, _) -> address_head a (* The name of the compilation unit currently compiled. *) -module Current_unit_name : sig +module Current_unit : sig val get : unit -> Unit_info.t option - val set : Unit_info.t option -> unit - val is : string -> bool - val is_ident : Ident.t -> bool - val is_path : Path.t -> bool + val set : Unit_info.t -> unit + val unset : unit -> unit + + module Name : sig + val get : unit -> string + val is : string -> 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 unit_info = - current_unit := unit_info - let get_cu () = - Option.map Unit_info.modname (get ()) - let get_name () = - Option.map Compilation_unit.name (get_cu ()) - let is name = - let current_name_string = - Option.map Compilation_unit.Name.to_string (get_name ()) - in - Option.equal String.equal current_name_string (Some name) - let is_ident id = - Ident.is_global 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 -> + Compilation_unit.Name.to_string + (Compilation_unit.name (Unit_info.modname cu)) + let is name = + get () = name + let is_ident id = + Ident.is_global 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_without_locks id tbl with | x -> x | exception Not_found - when Ident.is_global id && not (Current_unit_name.is_ident id) -> + when Ident.is_global id && not (Current_unit.Name.is_ident id) -> Mod_persistent let find_name_module ~mark name tbl = match IdTbl.find_name_and_locks wrap_module ~mark name tbl with | Ok x -> x - | Error locks when not (Current_unit_name.is name) -> + | Error locks when not (Current_unit.Name.is name) -> let path = Pident(Ident.create_persistent name) in path, locks, Mod_persistent | _ -> @@ -1173,7 +1184,7 @@ let find_name_module ~mark name tbl = let add_persistent_structure id env = if not (Ident.is_global 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 @@ -1194,7 +1205,7 @@ let add_persistent_structure id env = 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 + if material || not !Clflags.no_alias_deps then IdTbl.add id Mod_persistent env.modules else env.modules @@ -1331,7 +1342,7 @@ let reset_declaration_caches () = () let reset_cache ~preserve_persistent_env = - Current_unit_name.set None; + Current_unit.unset (); if not preserve_persistent_env then Persistent_env.clear !persistent_env; reset_declaration_caches (); @@ -1820,7 +1831,7 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = properly populated. *) assert false | exception Not_found - when Ident.is_global id && not (Current_unit_name.is_ident id) -> + when Ident.is_global id && not (Current_unit.Name.is_ident id) -> Shape.for_persistent_unit (Ident.name id) end | Module_type -> @@ -1857,7 +1868,7 @@ let add_required_unit cu = if not (List.exists (Compilation_unit.equal cu) !required_globals) then required_globals := cu :: !required_globals let add_required_ident id env = - if not !Clflags.transparent_modules && Ident.is_global id then + if not !Clflags.no_alias_deps && Ident.is_global id then let address = find_ident_module_address id env in match address_head address with | AHlocal _ -> () @@ -1885,7 +1896,7 @@ and expand_module_path lax env path = try match find_module_lazy ~alias:true path env with {md_type=Mty_alias path1} -> let path' = normalize_module_path lax env path1 in - if not (lax || !Clflags.transparent_modules) then begin + if not (lax || !Clflags.no_alias_deps) then begin let id = Path.head path in if Ident.is_global_or_predef id && not (Ident.same id (Path.head path')) then add_required_global (Pident id) env @@ -2278,16 +2289,6 @@ let module_declaration_address env id presence md = | Mp_present -> Lazy_backtrack.create_forced (Alocal 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_mode; cm_shape} : _ result = @@ -2349,7 +2350,7 @@ let rec components_of_module_maker | Type_variant (_,repr,umc) -> 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 -> @@ -2403,7 +2404,7 @@ let rec components_of_module_maker | Sig_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 @@ -2531,7 +2532,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)) @@ -2649,13 +2651,13 @@ 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) + (fun s -> Warnings.Unused_type_declaration (s, Warnings.Declaration)) !type_declarations; let store_decl path info env = match info.type_kind with | Type_variant (_,repr,umc) -> 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, umc), List.fold_left @@ -2724,7 +2726,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; @@ -3229,7 +3232,7 @@ let register_parameter modname = 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 @@ -3374,7 +3377,7 @@ let mark_label_used usage uid = | exception Not_found -> () let mark_constructor_description_used usage env cstr = - let ty_path = Btype.cstr_type_path cstr in + let ty_path = cstr_res_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 @@ -3899,7 +3902,8 @@ let rec lookup_module_components ~errors ~use ~loc lid env = !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env in Papply (f_path, arg), fcomp_res_mode_with_locks, comps -and lookup_structure_components ~errors ~use ~loc ?(reason = Project) lid env = +and lookup_structure_components ~errors ~use ?(reason = Project) l env = + let { txt=lid; loc } = l in let path, mode_with_locks, comps = lookup_module_components ~errors ~use ~loc lid env in @@ -3927,7 +3931,7 @@ and get_functor_components ~errors ~loc lid env comps = | 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 = +and lookup_all_args ~errors ~use lid0 env = let rec loop_lid_arg args = function | Lident _ | Ldot _ as f_lid -> (f_lid, args) @@ -3936,19 +3940,21 @@ and lookup_all_args ~errors ~use ~loc lid0 env = application at runtime and thus both the functor and the arguments are not closed over. Therefore, they all remains at legacy mode which don't need to be tracked. *) + let { txt = arg_lid; loc } = arg_lid in 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 + loop_lid_arg ((f_lid,arg_path,arg_md.md_type)::args) f_lid.txt 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 f0_lid, args0 = lookup_all_args ~errors ~use 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 = + let { txt = f_lid; loc } = f_lid in get_functor_components ~errors ~loc f_lid env f_comp in check_functor_appl @@ -4007,11 +4013,11 @@ and lookup_module ~errors ~use ~loc lid env = and lookup_dot_module ~errors ~use ~loc l s env = let p, (_, locks), comps = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_modules with + match NameMap.find s.txt comps.comp_modules with | mda -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_module ~use ~loc path mda; (path, locks, mda) | exception Not_found -> @@ -4019,11 +4025,11 @@ and lookup_dot_module ~errors ~use ~loc l s env = let lookup_dot_value ~errors ~use ~loc l s env = let (path, (_, locks), comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_values with + match NameMap.find s.txt comps.comp_values with | vda -> - let path = Pdot(path, s) in + let path = Pdot(path, s.txt) in use_value ~use ~loc path vda; (path, locks, vda) | exception Not_found -> @@ -4031,11 +4037,11 @@ let lookup_dot_value ~errors ~use ~loc l s env = let lookup_dot_type ~errors ~use ~loc l s env = let (p, _, comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_types with + match NameMap.find s.txt comps.comp_types with | tda -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_type ~use ~loc path tda; (path, tda) | exception Not_found -> @@ -4043,11 +4049,11 @@ let lookup_dot_type ~errors ~use ~loc l s env = let lookup_dot_modtype ~errors ~use ~loc l s env = let (p, _, comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_modtypes with + match NameMap.find s.txt comps.comp_modtypes with | mta -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_modtype ~use ~loc path mta.mtda_declaration; (path, mta.mtda_declaration) | exception Not_found -> @@ -4055,39 +4061,39 @@ let lookup_dot_modtype ~errors ~use ~loc l s env = let lookup_dot_class ~errors ~use ~loc l s env = let (p, (_, locks), comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_classes with + match NameMap.find s.txt comps.comp_classes with | clda -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_class ~use ~loc path clda; (path, locks, 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 + let (p, _, comps) = lookup_structure_components ~errors ~use l env in + match NameMap.find s.txt comps.comp_cltypes with | cltda -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) 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_dot_jkind ~errors ~use ~loc l s env = - let (p, _, comps) = lookup_structure_components ~errors ~use ~loc l env in - match NameMap.find s comps.comp_jkinds with + let (p, _, comps) = lookup_structure_components ~errors ~use l env in + match NameMap.find s.txt comps.comp_jkinds with | jkind -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_jkind ~use ~loc path jkind; (path, jkind.jkda_declaration) | exception Not_found -> may_lookup_error errors loc env (Unbound_jkind (Ldot(l, s))) let lookup_all_dot_labels ~record_form ~errors ~use ~loc usage l s env = - let (_, _, comps) = lookup_structure_components ~errors ~use ~loc l env in - match NameMap.find s (comp_labels record_form comps) with + let (_, _, comps) = lookup_structure_components ~errors ~use l env in + match NameMap.find s.txt (comp_labels record_form comps) with | [] | exception Not_found -> may_lookup_error errors loc env (Unbound_label (Ldot(l, s), P record_form, usage)) @@ -4100,15 +4106,16 @@ let lookup_all_dot_labels ~record_form ~errors ~use ~loc usage l s env = let lookup_all_dot_constructors ~errors ~use ~loc usage l s env = match l with - | Longident.Lident "*predef*" -> + | { txt=Longident.Lident "*predef*"; _ } -> (* Hack to support compilation of default arguments *) + let { txt=s; loc } = s in lookup_all_ident_constructors ~errors ~use ~loc usage s (Lazy.force initial) | _ -> let (_, (_, locks), comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_constrs with + match NameMap.find s.txt comps.comp_constrs with | [] | exception Not_found -> may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s))) | cstrs -> @@ -4182,9 +4189,9 @@ let open_signature_by_path path env0 = let comps = find_structure_components path env0 in add_components None path env0 comps locks_empty -let open_signature ~errors ~loc slot lid env0 = +let open_signature ~errors slot lid env0 = let (root, mode_with_locks, comps) = - lookup_structure_components ~errors ~use:true ~loc ~reason:Open lid env0 + lookup_structure_components ~errors ~use:true ~reason:Open lid env0 in let _, locks = mode_with_locks in root, mode_with_locks, add_components slot root env0 comps locks @@ -4231,7 +4238,7 @@ let remove_last_open root env0 = (* Open a signature from a file *) let open_pers_signature name env = - open_signature ~errors:false ~loc:Location.none None (Lident name) env + open_signature ~errors:false None (Location.mknoloc (Lident name)) env let open_signature ~used_slot @@ -4279,16 +4286,16 @@ let open_signature end; used := true in - open_signature ~errors:true ~loc:lid.loc (Some slot) lid.txt env + open_signature ~errors:true (Some slot) lid env end - else open_signature ~errors:true ~loc:lid.loc None lid.txt env + else open_signature ~errors:true None lid env (* General forms of the lookup functions *) let lookup_module_path ~errors ~use ~loc ~load lid env = match lid with | Lident s -> - if !Clflags.transparent_modules && not load then + if !Clflags.no_alias_deps && not load then let path, mode_with_locks, () = lookup_ident_module Don't_load ~errors ~use ~loc s env in @@ -4311,7 +4318,7 @@ let lookup_module_instance_path ~errors ~use ~loc ~load name env = [lookup_module_path] on a module not found in the environment *) let locks = IdTbl.get_all_locks env.modules in let path, loc_def = - if !Clflags.transparent_modules && not load then + if !Clflags.no_alias_deps && not load then let path, () = lookup_global_name_module_no_locks Don't_load ~errors ~use ~loc name env in @@ -4361,8 +4368,8 @@ let lid_without_hash = function | None -> None end | Ldot(l, s) -> begin - match string_without_hash s with - | Some s -> Some (Ldot(l, s)) + match string_without_hash s.txt with + | Some txt -> Some (Ldot(l, { s with txt })) | None -> None end | Lapply _ -> None @@ -4657,7 +4664,7 @@ let bound_module name env = match IdTbl.find_name_and_locks wrap_module ~mark:false name env.modules with | Ok _ -> true | Error _ -> - 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 ~allow_excess_args:false @@ -4909,27 +4916,31 @@ 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 print_type_expr : Types.type_expr printer ref = ref (fun _ _ -> assert false) -let spellcheck ppf extract env lid = +module Style = Misc.Style + +let quoted_longident = Style.as_inline_code Pprintast.Doc.longident +let quoted_constr = Style.as_inline_code Pprintast.Doc.constr + +let spellcheck extract env lid = let choices ~path name = Misc.spellcheck (extract path env) name in - match lid with - | Longident.Lapply _ -> () + match lid with + | Longident.Lapply _ -> None | Longident.Lident s -> - Misc.did_you_mean ppf (fun () -> choices ~path:None s) + Misc.did_you_mean (choices ~path:None s) | Longident.Ldot (r, s) -> - Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) + let pp ppf s = + quoted_longident ppf (Longident.Ldot(r, Location.mknoloc s)) + in + Misc.did_you_mean ~pp (choices ~path:(Some r.txt) s.txt) -let spellcheck_name ppf extract env name = - Misc.did_you_mean ppf - (fun () -> Misc.spellcheck (extract env) name) +let spellcheck_name extract env name = + Misc.did_you_mean (Misc.spellcheck (extract env) name) let extract_values path env = fold_values (fun name _ _ _ acc -> name :: acc) path env [] @@ -4960,18 +4971,16 @@ let print_lock_item ppf (item, lid) = match (item : Mode.Hint.lock_item) with | Module -> fprintf ppf "The module %a is" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Class -> fprintf ppf "%a is a class, and classes are always" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Value -> fprintf ppf "The value %a is" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Constructor -> fprintf ppf "The constructor %a is" - (Style.as_inline_code !print_longident) lid - -module Style = Misc.Style + quoted_longident lid let print_stage ppf stage = if stage = 0 then fprintf ppf "outside any quotations" @@ -5024,134 +5033,160 @@ let print_unbound_in_quotation ppf = | Label -> fprintf ppf "Label" | Constructor -> fprintf ppf "Constructor" -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 +let report_lookup_error_doc loc env = function + | Unbound_value(lid, hint) -> + Location.aligned_error_hint ~loc + "@{Unbound value @}%a" quoted_longident lid + (spellcheck extract_values env lid) + ~sub:( + match hint with + | No_hint ->[] + | Missing_rec def_loc -> + let (_, line, _) = + Location.get_pos_info def_loc.Location.loc_start + in + [Location.msg + "@[@{Hint@}: If this is a recursive definition,@ \ + you should add the %a keyword on line %i@]" + Style.inline_code "rec" + line + ] + ) | Unbound_type lid -> - fprintf ppf "Unbound type constructor %a" - quoted_longident lid; - spellcheck ppf extract_types env lid; + Location.aligned_error_hint ~loc + "@{Unbound type constructor @}%a" + quoted_longident lid + (spellcheck extract_types env lid) | Unbound_module lid -> begin - fprintf ppf "Unbound module %a" - quoted_longident lid; - match find_modtype_by_name_lazy lid env with - | exception Not_found -> spellcheck ppf extract_modules env lid; + let main ppf = + fprintf ppf "@{Unbound module @}%a" quoted_longident lid in + match find_modtype_by_name_lazy lid env with + | exception Not_found -> + Location.aligned_error_hint ~loc "%t" main + (spellcheck extract_modules env lid) | _ -> - fprintf ppf - "@.@[@{Hint@}: There is a module type named %a, %s@]" - quoted_longident lid - "but module types are not modules" + Location.errorf ~loc "%t" main + ~sub:[Location.msg + "@{Hint@}: There is a module type named %a,@ \ + but module types are not modules" + quoted_longident lid + ] end | Unbound_constructor lid -> - fprintf ppf "Unbound constructor %a" - quoted_longident lid; - spellcheck ppf extract_constructors env lid; + Location.aligned_error_hint ~loc + "@{Unbound constructor @}%a" + quoted_constr lid + (spellcheck extract_constructors env lid) | Unbound_label (lid, record_form, usage) -> - let P record_form = record_form in - fprintf ppf "Unbound %s field %a" - (record_form_to_string record_form) - quoted_longident lid; - spellcheck ppf (extract_labels record_form) env lid; - let label_of_other_form = match record_form with - | Legacy -> - (match find_label_by_name Unboxed_product lid env with - | _ -> Some "an unboxed record" - | exception Not_found -> None) - | Unboxed_product -> - (match find_label_by_name Legacy lid env with - | _ -> Some "a boxed record" - | exception Not_found -> None) - in - (match label_of_other_form with - | Some other_form -> - fprintf ppf - "@\n@{Hint@}: @[There is %s field with this name." other_form; - (match record_form, usage with - | Unboxed_product, _ -> - (* If an unboxed field isn't in scope but a boxed field is, then - the boxed field must come from a record that didn't get an unboxed - version. *) - fprintf ppf - "@ Note that float- and [%@%@unboxed]- records don't get unboxed \ - versions." - | Legacy, Projection -> - let print_projection ppf (op, lid) = - fprintf ppf "%s%a" op !print_longident lid - in - fprintf ppf "@ To project an unboxed record field, use %a instead of \ - %a." - (Style.as_inline_code print_projection) (".#", lid) - (Style.as_inline_code print_projection) (".", lid) - | _ -> ()); - fprintf ppf "@]" - | None -> ()); + let P record_form = record_form in + let label_of_other_form = match record_form with + | Legacy -> + (match find_label_by_name Unboxed_product lid env with + | _ -> Some "an unboxed record" + | exception Not_found -> None) + | Unboxed_product -> + (match find_label_by_name Legacy lid env with + | _ -> Some "a boxed record" + | exception Not_found -> None) + in + let sub = + match label_of_other_form with + | Some other_form -> + [ Location.msg + "@{Hint@}: There is %s field with this name." other_form ] + @ + (match record_form, usage with + | Unboxed_product, _ -> + (* If an unboxed field isn't in scope but a boxed field is, then the + boxed field must come from a record that didn't get an unboxed + version. *) + [ Location.msg + "Note that float- and [@@@@unboxed]- records don't get \ + unboxed versions." ] + | Legacy, Projection -> + let print_projection ppf (op, lid) = + fprintf ppf "%s%a" op Pprintast.Doc.longident lid + in + [ Location.msg + "To project an unboxed record field, use %a instead of %a." + (Style.as_inline_code print_projection) (".#", lid) + (Style.as_inline_code print_projection) (".", lid) ] + | _ -> []) + | None -> [] + in + Location.aligned_error_hint ~loc + "@{Unbound %s field @}%a" + (record_form_to_string record_form) + quoted_longident lid + (spellcheck (extract_labels record_form) env lid) + ~sub | Unbound_class lid -> begin - fprintf ppf "Unbound class %a" - quoted_longident lid; + let main ppf = + fprintf ppf "@{Unbound class @}%a" quoted_longident lid + in match find_cltype_by_name lid env with - | exception Not_found -> spellcheck ppf extract_classes env lid; + | exception Not_found -> + Location.aligned_error_hint ~loc "%t" main + (spellcheck extract_classes env lid) | _ -> - fprintf ppf - "@.@[@{Hint@}: There is a class type named %a, %s@]" - quoted_longident lid - "but classes are not class types" + Location.errorf ~loc "%t" main + ~sub:[ + Location.msg + "@{Hint@}: There is a class type named %a,@ \ + but classes are not class types." + quoted_longident lid + ] end | Unbound_modtype lid -> begin - fprintf ppf "Unbound module type %a" - quoted_longident lid; + let main ppf = + fprintf ppf "@{Unbound module type @}%a" + quoted_longident lid in match find_module_by_name_lazy lid env with - | exception Not_found -> spellcheck ppf extract_modtypes env lid; + | exception Not_found -> + Location.aligned_error_hint ~loc "%t" main + (spellcheck extract_modtypes env lid) | _ -> - fprintf ppf - "@.@[@{Hint@}: There is a module named %a, %s@]" - quoted_longident lid - "but modules are not module types" - end + Location.errorf ~loc "%t" main + ~sub:[ + Location.msg + "@{Hint@}: There is a module named %a,@ \ + but modules are not module types" + quoted_longident lid + ] + end | Unbound_cltype lid -> - fprintf ppf "Unbound class type %a" - quoted_longident lid; - spellcheck ppf extract_cltypes env lid + Location.aligned_error_hint ~loc + "@{Unbound class type @}%a" quoted_longident lid + (spellcheck extract_cltypes env lid) | Unbound_jkind lid -> - fprintf ppf "Unbound kind %a" - (Style.as_inline_code !print_longident) lid; - spellcheck ppf extract_jkinds env lid + Location.aligned_error_hint ~loc + "@{Unbound kind @}%a" quoted_longident lid + (spellcheck extract_jkinds env lid) | Unbound_settable_variable s -> - fprintf ppf "Unbound instance variable or mutable variable %a" - Style.inline_code s; - spellcheck_name ppf extract_settable_variables env s + Location.aligned_error_hint ~loc + "@{Unbound instance variable or mutable variable @}%a" + Style.inline_code s + (spellcheck_name extract_settable_variables env s) | Not_a_settable_variable s -> - fprintf ppf "The value %a is not an instance variable or mutable variable" - Style.inline_code s; - spellcheck_name ppf extract_settable_variables env s + Location.aligned_error_hint ~loc + "@{The value @}%a is not an instance variable or mutable \ + variable" + Style.inline_code s + (spellcheck_name extract_settable_variables env s) | Masked_instance_variable lid -> - fprintf ppf - "The instance variable %a@ \ - cannot be accessed from the definition of another instance variable" + Location.errorf ~loc + "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" + Location.errorf ~loc + "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" + Location.errorf ~loc + "The ancestor variable %a@ cannot@ be@ accessed@ from@ \ + the definition of an instance variable" quoted_longident lid | Illegal_reference_to_recursive_module { container; unbound } -> let container = Option.value ~default:"_" container in @@ -5162,7 +5197,7 @@ let report_lookup_error_doc _loc env ppf = function dprintf "the definition of the module %a" Style.inline_code container, dprintf "the module type of %a" Style.inline_code unbound in - fprintf ppf + Location.errorf ~loc "@[This module type is recursive.@ \ This use of the recursive module %a@ \ within %t@ \ @@ -5180,7 +5215,7 @@ let report_lookup_error_doc _loc env ppf = function then dprintf "itself" else dprintf "the module type of %a" Style.inline_code unbound in - fprintf ppf + Location.errorf ~loc "@[This class type is recursive.@ This use of the class type %a@ \ from the recursive module %a@ within the definition of@ \ the class type %a@ in the recursive module %a@ \ @@ -5194,87 +5229,95 @@ let report_lookup_error_doc _loc env ppf = function Style.inline_code container self_or_unbound | Structure_used_as_functor lid -> - fprintf ppf "@[The module %a is a structure, it cannot be applied@]" + Location.errorf ~loc + "The module %a is a structure, it cannot be applied" quoted_longident lid | Abstract_used_as_functor (lid, p) -> - fprintf ppf "@[The module %a is of abstract type %a, it cannot be applied@]" - quoted_longident lid - (Style.as_inline_code !print_path) p + Location.errorf ~loc + "The module %a is of abstract type %a, it cannot be applied" + quoted_longident lid + (Style.as_inline_code pp_path) p | Functor_used_as_structure (lid, reason) -> - fprintf ppf "@[The module %a is a functor, \ - it cannot %a@]" - quoted_longident lid - print_structure_components_reason reason + Location.errorf ~loc + "The module %a is a functor, it cannot %a" + quoted_longident lid + print_structure_components_reason reason | Abstract_used_as_structure (lid, p, reason) -> - fprintf ppf "@[The module %a is of abstract type %a, \ - it cannot %a@]" - quoted_longident lid - (Style.as_inline_code !print_path) p - print_structure_components_reason reason + Location.errorf ~loc + "The module %a is of abstract type %a, it cannot %a" + quoted_longident lid + (Style.as_inline_code pp_path) p + print_structure_components_reason reason | Generative_used_as_applicative lid -> - fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ - applied@ in@ type@ expressions@]" + Location.errorf ~loc + "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" + if Current_unit.Name.is_path p then "is the current compilation unit" else "is missing" in - fprintf ppf + Location.errorf ~loc "The module %a is an alias for module %a, which %s" quoted_longident lid - (Style.as_inline_code !print_path) p cause + (Style.as_inline_code pp_path) p cause | Local_value_used_in_exclave (item, lid) -> - fprintf ppf "@[%a local, so it cannot be used \ - inside an exclave_@]" + Location.errorf ~loc + "%a local, so it cannot be used inside an exclave_" print_lock_item (item, lid) | Non_value_used_in_object (lid, typ, err) -> - fprintf ppf "@[%a must have a type of layout value because it is \ - captured by an object.@ %a@]" + Location.errorf ~loc + "%a must have a type of layout value because it is captured by an \ + object.@ %a" quoted_longident lid - (fun v -> !report_jkind_violation_with_offender + (fun ppf v -> !report_jkind_violation_with_offender ~offender:(fun ppf -> !print_type_expr ppf typ) - env v) + env ppf v) err | No_unboxed_version (lid, decl) -> - fprintf ppf "@[The type %a has no unboxed version.@]" - quoted_longident lid; - begin match decl.type_kind with - | Type_record (_, Record_unboxed, _) -> - fprintf ppf - "@.@[@{Hint@}: \ - [%@%@unboxed] records don't get unboxed versions.@]" - | Type_record (_, (Record_float | Record_ufloat | Record_mixed _), _) -> - fprintf ppf - "@.@[@{Hint@}: Float records don't get unboxed versions.@]"; - | Type_record_unboxed_product _ -> - fprintf ppf "@.@[@{Hint@}: It is already an unboxed record.@]"; - | _ -> () - end + let sub = + match decl.type_kind with + | Type_record (_, Record_unboxed, _) -> + [Location.msg + "@{Hint@}: [@@@@unboxed] records don't get unboxed \ + versions."] + | Type_record (_, (Record_float | Record_ufloat | + Record_mixed _), _) -> + [Location.msg + "@{Hint@}: Float records don't get unboxed versions."] + | Type_record_unboxed_product _ -> + [Location.msg + "@{Hint@}: It is already an unboxed record."] + | _ -> [] + in + Location.errorf ~loc ~sub + "The type %a has no unboxed version." + quoted_longident lid | Error_from_persistent_env err -> - Persistent_env.report_error_doc ppf err + Location.error_of_printer ~loc Persistent_env.report_error_doc err | Mutable_value_used_in_closure ctx -> - fprintf ppf - "@[Mutable variable cannot be used inside %t.@]" + Location.errorf ~loc + "Mutable variable cannot be used inside %t." ((Mode.print_pinpoint ctx |> Option.get) ~definite:false ~capitalize:false) | Incompatible_stage (lid, usage_loc, usage_stage, intro_loc, intro_stage) -> - fprintf ppf - "@[Identifier %a is used at %a,@ \ + Location.errorf ~loc + "Identifier %a is used at %a,@ \ %a;@ \ it is introduced at %a,@ \ - %a.@]" + %a." quoted_longident lid (Location.Doc.loc ~capitalize_first:false) usage_loc print_stage usage_stage (Location.Doc.loc ~capitalize_first:false) intro_loc print_stage intro_stage | Unbound_in_stage (context, lid, usage_loc, usage_stage, avail_stage) -> - fprintf ppf - "@[%a %a used at %a@ \ + Location.errorf ~loc + "%a %a used at %a@ \ cannot be used in this context;@ \ %a is not defined %a.@]\ - @.@[@{Hint@}: %a %a is defined %a.@]" + @.@[@{Hint@}: %a %a is defined %a." print_unbound_in_quotation context quoted_longident lid (Location.Doc.loc ~capitalize_first:false) usage_loc @@ -5284,9 +5327,9 @@ let report_lookup_error_doc _loc env ppf = function quoted_longident lid print_stage avail_stage -let report_error_doc ppf = function - | Missing_module(_, path1, path2) -> - fprintf ppf "@[@["; +let report_error_doc = function + | Missing_module(loc, path1, path2) -> + let pp_path path1 path2 ppf = if Path.same path1 path2 then fprintf ppf "Internal path@ %a@ is dangling." Style.inline_code (Path.name path1) @@ -5294,31 +5337,33 @@ let report_error_doc ppf = function 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" + in + Location.errorf ~loc + "%t@ @[The compiled interface for module@ %a@ was not found.@]" + (pp_path path1 path2) 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." + | Illegal_value_name(loc, name) -> + Location.errorf ~loc "%a is not a valid value identifier." Style.inline_code name - | Implicit_jkind_already_defined { name; defined_at; loc = _ } -> - fprintf ppf + | Lookup_error(loc, t, err) -> report_lookup_error_doc loc t err + | Implicit_jkind_already_defined { name; defined_at; loc } -> + Location.errorf ~loc "@[The implicit kind for %a is already defined at %a.@]" Style.inline_code name (Location.Doc.loc ~capitalize_first:false) defined_at - | Lookup_error(loc, t, err) -> report_lookup_error_doc loc t ppf err | Incomplete_instantiation { unset_param } -> - fprintf ppf "@[Not enough instance arguments: the parameter@ %a@ is \ - required.@]" + Location.errorf ~loc:Location.none + "@[Not enough instance arguments: \ + the parameter@ %a@ is required.@]" Global_module.Parameter_name.print unset_param | Toplevel_splice loc -> - fprintf ppf + Location.errorf ~loc "@[Splices ($) are not allowed in the initial stage,@ \ as encountered at %a.@,\ Did you forget to insert a quotation?@]" (Location.Doc.loc ~capitalize_first:false) loc | Unsupported_inside_quotation (loc, context) -> - fprintf ppf + Location.errorf ~loc "@[%a@ is not supported inside quoted expressions,@ \ as seen at %a.@]" print_unsupported_quotation context @@ -5328,34 +5373,13 @@ let () = Location.register_error_of_exn (function | Error err -> - let loc = - match err with - | Missing_module (loc, _, _) - | Illegal_value_name (loc, _) - | Implicit_jkind_already_defined { loc; _ } - | Toplevel_splice loc - | Unsupported_inside_quotation (loc, _) - | Lookup_error(loc, _, _) -> loc - | Incomplete_instantiation _ -> Location.none - in - let error_of_printer = - if loc = Location.none - then Location.error_of_printer_file - else Location.error_of_printer ~loc ?sub:None - in - Some - (error_of_printer - report_error_doc err) + Some (report_error_doc err) | _ -> None ) let () = let get_current_compilation_unit () = - Option.map Unit_info.modname (get_unit_name ()) + Option.map Unit_info.modname (get_current_unit ()) in Compilation_unit.Private.fwd_get_current := get_current_compilation_unit - -let report_lookup_error loc t = - Format_doc.compat (report_lookup_error_doc loc t) -let report_error = Format_doc.compat report_error_doc diff --git a/upstream/ocaml_flambda/typing/env.mli b/upstream/ocaml_flambda/typing/env.mli index 0f4afa87e..38fc9feaf 100644 --- a/upstream/ocaml_flambda/typing/env.mli +++ b/upstream/ocaml_flambda/typing/env.mli @@ -16,6 +16,7 @@ (* Environment handling *) open Types +open Data_types open Misc module Jkind = Btype.Jkind0 @@ -432,7 +433,7 @@ val add_value: ?check:(string -> Warnings.t) -> mode:(Mode.allowed * 'r) Mode.Value.t -> Ident.t -> Types.value_description -> t -> t val add_type: - check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t + 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 @@ -576,9 +577,10 @@ val reset_cache: preserve_persistent_env:bool -> 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: Unit_info.t option -> unit -val get_unit_name: unit -> Unit_info.t option +(* 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: @@ -675,14 +677,6 @@ type 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 @@ -716,8 +710,6 @@ val same_constr: (t -> type_expr -> type_expr -> bool) ref val constrain_type_jkind: (t -> type_expr -> jkind_r -> (unit, Jkind.Violation.t) result) 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 (* Forward declaration to break mutual recursion with Printtyp. *) val print_type_expr: Types.type_expr Format_doc.printer ref diff --git a/upstream/ocaml_flambda/typing/envaux.ml b/upstream/ocaml_flambda/typing/envaux.ml index 48b3a8073..02a48a363 100644 --- a/upstream/ocaml_flambda/typing/envaux.ml +++ b/upstream/ocaml_flambda/typing/envaux.ml @@ -120,7 +120,7 @@ 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.path) p + (Style.as_inline_code Printtyp.Doc.path) p let () = Location.register_error_of_exn diff --git a/upstream/ocaml_flambda/typing/errortrace.ml b/upstream/ocaml_flambda/typing/errortrace.ml index eab4bc121..9ea29ae47 100644 --- a/upstream/ocaml_flambda/typing/errortrace.ml +++ b/upstream/ocaml_flambda/typing/errortrace.ml @@ -98,14 +98,22 @@ 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 arg_label diff + | Tuple_label_mismatch of string option 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 | Bad_jkind : type_expr * Jkind.Violation.t -> ('a, _) elt @@ -125,7 +133,9 @@ 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 _ | Tuple_label_mismatch _ + | Incompatible_fields _ + | Rec_occur (_, _) | First_class_module _ as x -> x | Bad_jkind _ as x -> x | Bad_jkind_sort _ as x -> x | Unequal_var_jkinds _ as x -> x diff --git a/upstream/ocaml_flambda/typing/errortrace.mli b/upstream/ocaml_flambda/typing/errortrace.mli index 0c3898a70..76fd39058 100644 --- a/upstream/ocaml_flambda/typing/errortrace.mli +++ b/upstream/ocaml_flambda/typing/errortrace.mli @@ -84,13 +84,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 arg_label diff + | Tuple_label_mismatch of string option 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 | Bad_jkind : type_expr * Jkind.Violation.t -> ('a, _) elt diff --git a/upstream/ocaml_flambda/typing/errortrace_report.ml b/upstream/ocaml_flambda/typing/errortrace_report.ml new file mode 100644 index 000000000..42e8873dd --- /dev/null +++ b/upstream/ocaml_flambda/typing/errortrace_report.ml @@ -0,0 +1,657 @@ +(**************************************************************************) +(* *) +(* 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_arg env ty = + let ty, vars = Btype.tpoly_get_poly ty in + if vars <> [] then false + else begin + match Types.get_desc (Ctype.expand_head env ty) with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + end + +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_arg 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_arg 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 + | Types.Fixed_existential -> 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 | Fixed_existential)) -> + (* 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 ~missing_label_msg {Errortrace.got;expected} = + let quoted_label ppf l = + Style.inline_code ppf (Printtyp.string_of_label l) + in + match got, expected with + | Types.Nolabel, Types.(Labelled _ | Optional _ | Position _) -> + doc_printf "@,@[A label@ %a@ was expected@]" + quoted_label expected + | Types.(Labelled _ | Optional _ | Position _), Types.Nolabel -> + doc_printf missing_label_msg + quoted_label got + | Types.Labelled g, Types.Optional e when g = e -> + doc_printf + "@,@[The label@ %a@ was expected to be optional@]" + quoted_label got + | Types.Optional g, Types.Labelled e when g = e -> + doc_printf + "@,@[The label@ %a@ was expected to not be optional@]" + quoted_label got + | Types.(Labelled _ | Optional _ | Position _), + Types.(Labelled _ | Optional _ | Position _) -> + doc_printf "@,@[Labels %a@ and@ %a do not match@]" + quoted_label got + quoted_label expected + | Types.Nolabel, Types.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 -> + let missing_label_msg = + format_of_string + "@,@[The first argument is labeled@ %a,@ \ + but an unlabeled argument was expected@]" + in + Some(explain_label_mismatch ~missing_label_msg diff) + | Errortrace.Tuple_label_mismatch diff -> + let types_label = function + | None -> Types.Nolabel + | Some x -> Types.Labelled x + in + let diff = Errortrace.map_diff types_label diff in + let missing_label_msg = + format_of_string + "@,@[The first tuple element is labeled@ %a,@ \ + but an unlabeled element was expected@]" + in + Some(explain_label_mismatch ~missing_label_msg diff) + | 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 + | Errortrace.Bad_jkind (t,e) -> + Some (doc_printf "@ @[%a@]" + (Jkind.Violation.report_with_offender + ~offender:(fun ppf -> + prepare_for_printing [t]; + prepared_type_expr ppf t) + env) e) + | Errortrace.Bad_jkind_sort (t,e) -> + Some (doc_printf "@ @[%a@]" + (Jkind.Violation.report_with_offender_sort + ~offender:(fun ppf -> + prepare_for_printing [t]; + prepared_type_expr ppf t) + env) e) + | Errortrace.Unequal_var_jkinds (t1,k1,t2,k2) -> + let fmt_history t k ppf = + Jkind.(format_history env ~intro:( + dprintf "The layout of %a is %a" prepared_type_expr t + (format env) k) ppf k) + in + Some (doc_printf "@ because the layouts of their variables are different.\ + @ @[%t@;%t@]" + (fmt_history t1 k1) (fmt_history t2 k2)) + | Errortrace.Unequal_tof_kind_jkinds (k1, k2) -> + let fmt_history which k ppf = + Jkind.(format_history env ~intro:( + dprintf "The kind of %s is %a" which (format env) k) ppf k) + in + Some (doc_printf "@ because their kinds are different.\ + @ @[%t@;%t@]" + (fmt_history "the first" k1) (fmt_history "the second" k2)) + +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 ~var_jkinds mode txt_got txt_but = function + | None -> Format_doc.Doc.empty + | Some d -> + let d = + Errortrace.map_diff (trees_of_type_expansion' ~var_jkinds 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 + let jkind_error = match Misc.last tr with + | Some (Bad_jkind _ | Bad_jkind_sort _ | Unequal_var_jkinds _ + | Unequal_tof_kind_jkinds _) -> + true + | _ -> + false + 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 ~var_jkinds:jkind_error 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 && not jkind_error + (* the jkinds mechanism has its own way of reporting missing cmis + CR jkinds: streamline these *) + 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_flambda/typing/errortrace_report.mli b/upstream/ocaml_flambda/typing/errortrace_report.mli new file mode 100644 index 000000000..bb6f0ea9e --- /dev/null +++ b/upstream/ocaml_flambda/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_flambda/typing/gprinttyp.ml b/upstream/ocaml_flambda/typing/gprinttyp.ml new file mode 100644 index 000000000..91a7d5cd9 --- /dev/null +++ b/upstream/ocaml_flambda/typing/gprinttyp.ml @@ -0,0 +1,999 @@ +(**************************************************************************) +(* *) +(* 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 } + type level_and_scope = { level:int; scope: int } + type 'a desc = { + id: 'a; + color: Decoration.color option; + desc: Types.type_desc; + lvl:level_and_scope; + } + val subnode: name:string -> t -> t + val either_ext: Types.row_field_cell -> t + val split: params -> Types.type_expr -> t 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 level_and_scope = { level:int; scope: int } + type 'a desc = { + id: 'a; + color: Decoration.color option; + desc: Types.type_desc; + lvl:level_and_scope; + } + + 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 + let scope = Types.Transient_expr.get_scope x in + let level = x.level in + { id = pretty_id params x.id; + color; + desc = x.desc; + lvl = {level;scope} + } + + 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.txt s.txt + | Longident.Lapply(f,x) -> + fprintf ppf "%a(%a)" longident f.txt longident x.txt + + 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" + | Some Types.Fixed_existential -> fprintf ppf "existential" + + 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 + | Types.Nolabel -> () + | Types.Labelled s -> fprintf ppf "%s" s + | Types.Optional s -> fprintf ppf "?%s" s + | Types.Position 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 + + (* Use unicode superscript digit to circumvent graphviz limited support for + superscript. *) + let superscript_digit ppf n = + let s = match n with + | 1 -> "¹" + | 2 -> "²" + | 3 -> "³" + | 0 -> "⁰" + | 4 -> "⁴" + | 5 -> "⁵" + | 6 -> "⁶" + | 7 -> "⁷" + | 8 -> "⁸" + | 9 -> "⁹" + | _ -> assert false + in + Format.pp_print_string ppf s + + let rec superscript ppf n = + if n < 10 then + superscript_digit ppf n + else begin + superscript ppf (n/10); + superscript_digit ppf (n mod 10) + end + + let superscript_level ppf lvl = + (* avoid a dependency on Btype *) + if lvl = Ident.highest_scope then Format.pp_print_string ppf "᪲" + else superscript ppf lvl + + let add_node explicit_d color id ?lvl tynode dg = + let d = match lvl with + | None -> labelf "%a" Pp.prettier_index id + | Some {Index.level; scope=0} -> + labelf "%a %a" + Pp.prettier_index id superscript_level level + | Some {Index.level; scope} -> + labelf "%a %a⁺%a" + Pp.prettier_index id + superscript_level level + superscript scope + 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 {Index.id; _ } as desc = Index.split params ty0 in + let tynode = Node id in + if Elt_map.mem tynode g then id, None + else id, Some { desc with id = tynode } + + 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 Index.{id=tynode; color; desc; lvl} -> + id, node params color ~lvl 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 labeled_edge params id0 (i,gh) (l,ty) = + let l = + match l with + | None -> labelr "%d" i + | Some l -> labelr "%d%s" i l + in + i + 1, edge params id0 l ty gh + and labeled_edges params id0 l gh = + snd @@ List.fold_left + (labeled_edge params id0) + (0,gh) l + and node params color ~lvl id tynode desc dg = + let add_tynode l = add_node l color ~lvl 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 "*" |> labeled_edges params id tl + | Types.Tunboxed_tuple tl -> + mk "#*" |> labeled_edges params id 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 {Index.color; desc; lvl; _ } -> + group_fields ~params ~prev_id:id ~lvl + dg.elts dg.graph empty_subgraph + ~id:next_id ~color ~desc + end + | Types.Tfield _ -> + group_fields ~params ~prev_id:id ~lvl + dg.elts dg.graph empty_subgraph + ~color ~id ~desc + | Types.Tnil -> mk "[Nil]" + | Types.Tquote t -> mk "[Quote]" |> std_edge t + | Types.Tsplice t -> mk "[Splice]" |> std_edge t + | Types.Tquote_eval t -> mk "[QuoteEval]" |> std_edge t + | 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.Trepr (t, _sort_vars) -> + mk "[Repr]" |> std_edge t + | 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 {pack_path; pack_cstrs} -> + let types = List.map snd pack_cstrs in + let pp_cstrs ppf (l, _) = + Pp.longident ppf (Option.get @@ Longident.unflatten l) + in + mk "[mod %a with %a]" + pp_path pack_path + Pp.(list ~sep:semi pp_cstrs) pack_cstrs + |> numbered types + | Types.Tof_kind _ -> + mk "[Kind]" + 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 ~lvl ~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 {Index.color; desc; lvl; _} -> + group_fields ~params ~prev_id:id ~lvl + 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 ~lvl 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_flambda/typing/gprinttyp.mli b/upstream/ocaml_flambda/typing/gprinttyp.mli new file mode 100644 index 000000000..e6bbd61c3 --- /dev/null +++ b/upstream/ocaml_flambda/typing/gprinttyp.mli @@ -0,0 +1,326 @@ +(**************************************************************************) +(* *) +(* 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 +{[ + .---------------. + | lvl | + | 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_flambda/typing/ident.ml b/upstream/ocaml_flambda/typing/ident.ml index 21d432d4d..a2a979792 100644 --- a/upstream/ocaml_flambda/typing/ident.ml +++ b/upstream/ocaml_flambda/typing/ident.ml @@ -131,6 +131,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 @@ -168,19 +171,48 @@ let to_global = function | Global_with_args g -> Some g | _ -> None +let canonical_stamps = s_table Hashtbl.create 0 +let next_canonical_stamp = s_table Hashtbl.create 0 + +let canonicalize name stamp = + try Hashtbl.find !canonical_stamps (name, stamp) + with Not_found -> + let canonical_stamp = + try Hashtbl.find !next_canonical_stamp name + with Not_found -> 0 + in + Hashtbl.replace !next_canonical_stamp name + (canonical_stamp + 1); + Hashtbl.add !canonical_stamps (name, stamp) + canonical_stamp; + canonical_stamp + +let pp_stamped ppf (name, stamp) = + let open Format_doc in + if not !Clflags.unique_ids then + fprintf ppf "%s" name + else begin + let stamp = + if not !Clflags.canonical_ids then stamp + else canonicalize name stamp + in + fprintf ppf "%s/%i" name stamp + end + 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 "") + | Global name -> + fprintf ppf "%s!" name + | Predef { name; stamp } -> + fprintf ppf "%a!" + pp_stamped (name, stamp) + | Local { name; stamp } -> + fprintf ppf "%a" + pp_stamped (name, stamp) + | Scoped { name; stamp; scope } -> + fprintf ppf "%a%s" + pp_stamped (name, stamp) (if with_scope then asprintf "[%i]" scope else "") | Global_with_args g -> fprintf ppf "%a!" Global_module.Name.print g diff --git a/upstream/ocaml_flambda/typing/ident.mli b/upstream/ocaml_flambda/typing/ident.mli index e5ec7fdcf..e0570e8ad 100644 --- a/upstream/ocaml_flambda/typing/ident.mli +++ b/upstream/ocaml_flambda/typing/ident.mli @@ -59,7 +59,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 is_global: t -> bool val is_global_or_predef: t -> bool diff --git a/upstream/ocaml_flambda/typing/includeclass.ml b/upstream/ocaml_flambda/typing/includeclass.ml index 8448339bf..5c560c156 100644 --- a/upstream/ocaml_flambda/typing/includeclass.ml +++ b/upstream/ocaml_flambda/typing/includeclass.ml @@ -42,6 +42,7 @@ let class_declarations env cty1 cty2 = open Format_doc open Ctype +module Printtyp=Printtyp.Doc (* let rec hide_params = function @@ -58,7 +59,7 @@ 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 + 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") @@ -70,16 +71,16 @@ 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 + 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) -> - Printtyp.report_comparison_error ppf mode 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) -> - Printtyp.report_comparison_error ppf mode 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 -> diff --git a/upstream/ocaml_flambda/typing/includeclass.mli b/upstream/ocaml_flambda/typing/includeclass.mli index 5ba26a888..a4d4d8588 100644 --- a/upstream/ocaml_flambda/typing/includeclass.mli +++ b/upstream/ocaml_flambda/typing/includeclass.mli @@ -29,6 +29,6 @@ val class_declarations: class_match_failure list val report_error : - Printtyp.type_or_scheme -> class_match_failure list Format_doc.format_printer + Out_type.type_or_scheme -> class_match_failure list Format_doc.format_printer val report_error_doc : - Printtyp.type_or_scheme -> class_match_failure list Format_doc.printer + Out_type.type_or_scheme -> class_match_failure list Format_doc.printer diff --git a/upstream/ocaml_flambda/typing/includecore.ml b/upstream/ocaml_flambda/typing/includecore.ml index cc2ad4e05..daea728c8 100644 --- a/upstream/ocaml_flambda/typing/includecore.ml +++ b/upstream/ocaml_flambda/typing/includecore.ml @@ -18,6 +18,7 @@ open Asttypes open Path open Types +open Data_types open Mode open Typedtree @@ -64,7 +65,8 @@ type mmodes = let child_close_over_coercion_opt id c = match c with | None -> None - | Some (locks, lid, loc) -> Some (locks, Longident.Ldot (lid, id), loc) + | Some (locks, lid, loc) -> + Some (locks, Longident.Ldot (Location.mkloc lid loc, Location.mknoloc id), loc) let child_modes id = function | All -> All @@ -150,6 +152,27 @@ let primitive_descriptions pd1 pd2 = else native_repr_args pd1.prim_native_repr_args pd2.prim_native_repr_args +(* 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 _, _) -> + (* Here we can not compute a valid coercion, because it may depend on the + local environment of the module, which is not made available in the + consistency check. But the coercion computed by the [*_consistency] + functions is never used, so it's fine. We return [Tcoerce_invalid] so + that if someone ever started using this, they'd get a loud error. *) + Tcoerce_invalid + | (_, Val_prim _) -> raise (Dont_match Not_a_primitive) + | (_, _) -> Tcoerce_none + let moregeneral_lpoly env pat_lpoly subj_lpoly ty1 ty2 = let pat_refs = Ctype.moregeneral env true pat_lpoly subj_lpoly ty1 ty2 @@ -245,13 +268,15 @@ let value_descriptions ~loc env name | Some err -> raise (Dont_match (Primitive_mismatch err)) end | _ -> - let ty1, mode_l1, _, sort1 = Ctype.instance_prim env p1 vd1.val_type in + let ty1, mode_l1, _, sort1 = + Ctype.instance_prim env p1 vd1.val_type + in (try moregeneral_lpoly env val_lpoly1 val_lpoly2 ty1 vd2.val_type with Ctype.Moregen err -> raise (Dont_match (Type err))); let pc = {pc_desc = p1; pc_type = vd2.Types.val_type; pc_poly_mode = Option.map Mode.Locality.disallow_right mode_l1; - pc_poly_sort=sort1; + pc_poly_sort = sort1; pc_env = env; pc_loc = vd1.Types.val_loc; } in Tcoerce_primitive pc end @@ -391,11 +416,13 @@ type jkind_mismatch = | Manifest_missing | Manifest_mismatch +module Printtyp = Printtyp.Doc + let report_modality_sub_error first second ppf e = let Modality.Error (ax, {left; right}) = e in let print_modality id ppf m = Printtyp.modality - ~id:(fun ppf -> Format_doc.pp_print_string ppf id) ax ppf m + ~id:(fun ppf () -> Format_doc.pp_print_string ppf id) ax ppf m in Format_doc.fprintf ppf "%s is %a and %s is %a." (String.capitalize_ascii second) @@ -466,7 +493,7 @@ let report_value_mismatch first second env ppf err = pr "The implementation is not a primitive." | Type trace -> let msg = Fmt.Doc.msg in - Printtyp.report_moregen_error ppf Type_scheme env trace + Errortrace_report.moregen ppf Type_scheme env trace (msg "The type") (msg "is not compatible with the type") | Zero_alloc e -> Zero_alloc.print_error ppf e @@ -505,7 +532,7 @@ let report_value_mismatch first second env ppf err = let report_type_inequality env ppf err = let msg = Fmt.Doc.msg in - Printtyp.report_equality_error ppf Type_scheme env err + Errortrace_report.equality ppf Type_scheme env err (msg "The type") (msg "is not equal to the type") @@ -745,7 +772,6 @@ let report_unsafe_mode_crossing_mismatch first second ppf e = 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." @@ -928,14 +954,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 = @@ -1120,13 +1169,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) @@ -1449,6 +1497,17 @@ let type_manifest env ty1 ty2 priv2 kind2 = their jkinds changed during unification. *) +(* 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 + (* See Note [Contravariance of type parameter jkinds]. *) let type_declarations ?(equality = false) ~loc env ~mark name decl1 path decl2 = @@ -1458,7 +1517,8 @@ 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 = type_declarations_consistency env decl1 decl2 in + if err <> None then err else (* Step 1 from the Note *) let err = match Ctype.equal ~do_jkind_check:false env true @@ -1488,20 +1548,13 @@ let type_declarations ?(equality = false) ~loc env ~mark name "Unification in type_declarations failed, \ but not with Bad_jkind:@;<1 2>%t" (fun ppf -> - Printtyp.report_unification_error ppf env err + Errortrace_report.unification ppf env err (Fmt.doc_printf "The type") (Fmt.doc_printf "does not unify with the type")) end | () -> None in if err <> None then err else - (* Step 5 from the Note *) - let err = - match privacy_mismatch env decl1 decl2 with - | Some err -> Some (Privacy err) - | None -> None - in - if err <> None then err else let err = match (decl1.type_manifest, decl2.type_manifest) with (_, None) -> None | (Some ty1, Some ty2) -> @@ -1606,10 +1659,21 @@ let type_declarations ?(equality = false) ~loc env ~mark name [])))) | All_good -> let abstr = Btype.type_kind_is_abstract decl2 && decl2.type_manifest = None in + (* We need to check coherence of internal and exported variance either + * when the export type is abstract, as there is no manifest to get + the minimal variance from + * when the export type is private, as the private manifest may be + result of expansions within Ctype.equal_private, forgetting + an explicit variance annotation in the internal type + * when the internal type is private, but this is already included + in the above two cases (a private type can only be exported as + abstract or private) + * when the internal type is open, as we do not allow changing the + variance in that case *) + let abstr' = abstr || decl2.type_private = Private in let need_variance = - abstr || decl1.type_private = Private || decl1.type_kind = Type_open in + 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 @@ -1617,10 +1681,13 @@ let type_declarations ?(equality = false) ~loc env ~mark name 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) + (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 + (* Only check the lower bound for abstract types. + For private types, the lower bound can be inferred, and + the internal one may be wrong in the result of functors. *) 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 diff --git a/upstream/ocaml_flambda/typing/includecore.mli b/upstream/ocaml_flambda/typing/includecore.mli index 9c4bdee2b..f98136915 100644 --- a/upstream/ocaml_flambda/typing/includecore.mli +++ b/upstream/ocaml_flambda/typing/includecore.mli @@ -207,6 +207,21 @@ val jkind_declarations: loc:Location.t -> Env.t -> string -> jkind_declaration -> jkind_declaration -> jkind_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 diff --git a/upstream/ocaml_flambda/typing/includemod.ml b/upstream/ocaml_flambda/typing/includemod.ml index 49be7fa2f..4ae0a259e 100644 --- a/upstream/ocaml_flambda/typing/includemod.ml +++ b/upstream/ocaml_flambda/typing/includemod.ml @@ -111,11 +111,13 @@ module Error = struct | Param of (functor_parameter, unit) functor_param_symptom | Incompatible - and functor_params_diff = - (functor_parameter list * module_type, functor_params_symptom) diff + and functor_params_info = + { params: functor_parameter list; res: module_type } + and functor_params_diff = (functor_params_info, functor_params_symptom) diff and signature_symptom = { env: Env.t; + subst: Subst.t; missings: signature_item list; incompatibles: (Ident.t * sigitem_symptom) list; } @@ -149,6 +151,12 @@ module Error = struct | In_Jkind_declaration of Ident.t * core_sigitem_symptom | In_Expansion of core_module_type_symptom + let cons_arg arg params_info = + { params = arg :: params_info.params; res = params_info.res } + + let functor_params info1 info2 symptom = + Error (Functor (Params (diff info1 info2 symptom))) + end module Directionality = struct @@ -245,79 +253,87 @@ let modes_unit = let modes_toplevel = Specific ((Env.mode_unit, None), Env.mode_unit) -(* 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 ~direction subst id ~mmodes vd1 vd2 = - if Directionality.mark_as_used direction 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) ~mmodes vd1 vd2) - with Includecore.Dont_match err -> - Error Error.(Core (Value_descriptions (mdiff vd1 vd2 mmodes err))) - -(* Inclusion between type declarations *) +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 ~direction subst id ~mmodes vd1 vd2 = + if Directionality.mark_as_used direction 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) ~mmodes + vd1 vd2) + with Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (mdiff vd1 vd2 mmodes err))) + + (* Inclusion between type declarations *) + + let type_declarations ~loc env ~direction subst id ~mmodes:_ decl1 decl2 = + let mark = Directionality.mark_as_used direction 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 ~direction subst id ~mmodes:_ ext1 ext2 = + let mark = Directionality.mark_as_used direction 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 jkind declarations *) + + let jkind_declarations ~loc env ~direction subst id ~mmodes:_ decl1 decl2 = + let mark = Directionality.mark_as_used direction in + if mark then + Env.mark_jkind_used decl1.jkind_uid; + let decl2 = Subst.jkind_declaration subst decl2 in + match + Includecore.jkind_declarations ~loc env (Ident.name id) decl1 decl2 + with + | None -> Ok Tcoerce_none + | Some err -> + Error Error.(Core(Jkind_declarations (diff decl1 decl2 err))) + + (* Inclusion between class declarations *) + + let class_type_declarations ~loc env ~direction:_ subst _id ~mmodes:_ 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 ~direction:_ subst id ~mmodes decl1 decl2 = + let modes = Includecore.child_modes (Ident.name id) mmodes in + match Includecore.check_modes env ~item:Class modes with + | Error e -> + Error Error.(Core(Class_declarations( + mdiff decl1 decl2 mmodes (Class_mode e)))) + | Ok () -> + 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( + mdiff decl1 decl2 mmodes (Class_type reason)))) +end -let type_declarations ~loc env ~direction subst id decl1 decl2 = - let mark = Directionality.mark_as_used direction 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 ~direction subst id ext1 ext2 = - let mark = Directionality.mark_as_used direction 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 jkind declarations *) -let jkind_declarations ~loc env ~direction subst id decl1 decl2 = - let mark = Directionality.mark_as_used direction in - if mark then - Env.mark_jkind_used decl1.jkind_uid; - let decl2 = Subst.jkind_declaration subst decl2 in - match Includecore.jkind_declarations ~loc env (Ident.name id) decl1 decl2 with - | None -> Ok Tcoerce_none - | Some err -> - Error Error.(Core(Jkind_declarations (diff decl1 decl2 err))) - -(* Inclusion between class declarations *) - -let class_type_declarations ~loc 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 env subst id ~mmodes decl1 decl2 = - let modes = Includecore.child_modes (Ident.name id) mmodes in - match Includecore.check_modes env ~item:Class modes with - | Error e -> - Error Error.(Core(Class_declarations( - mdiff decl1 decl2 mmodes (Class_mode e)))) - | Ok () -> - 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( - mdiff decl1 decl2 mmodes (Class_type reason)))) (* Extract name, kind and ident from a signature item *) @@ -426,11 +442,13 @@ 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 - (Format_doc.compat Printtyp.raw_type_expr) pc_type + Rawprinttyp.type_expr pc_type | Tcoerce_alias (_, p, c) -> pr "@[<2>alias %a@ (%a)@]" - Printtyp.Compat.path p + Printtyp.path p print_coercion c + | Tcoerce_invalid -> + pr "invalid_coercion" and print_coercion2 ppf (n, c) = Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c and print_coercion3 ppf (i, n, c) = @@ -543,7 +561,7 @@ let retrieve_functor_params env mty = mode is intentionally ignored. *) retrieve_functor_params (p :: before) env res | Mty_ident _ | Mty_alias _ | Mty_signature _ | Mty_strengthen _ as res -> - List.rev before, res + { Error.params = List.rev before; res } in retrieve_functor_params [] env mty @@ -592,6 +610,25 @@ 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 -> direction:Directionality.t -> Subst.t -> Ident.t -> + mmodes:modes -> '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; + jkind_declarations: Types.jkind_declaration core_incl; +} + (* Quickly compare module types without expanding them, succeeding only if mty1 is a subtype of mty2 with no coercion *) let rec shallow_modtypes env subst mty1 mty2 = @@ -629,8 +666,8 @@ and shallow_module_paths env subst p1 mty2 p2 = | Mty_alias _ | Mty_ident _ | Mty_signature _ | Mty_functor _ | exception Not_found -> false -let rec modtypes ~direction ~loc env subst ~modes mty1 mty2 shape = - match try_modtypes ~direction ~loc env subst ~modes mty1 mty2 shape with +let rec modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 shape = + match try_modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 shape with | Ok _ as ok -> ok | Error reason -> let mty1 = Subst.Lazy.force_modtype mty1 in @@ -639,7 +676,7 @@ let rec modtypes ~direction ~loc env subst ~modes mty1 mty2 shape = in Error Error.(mdiff mty1 mty2 modes reason) -and try_modtypes ~direction ~loc env subst ~modes +and try_modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 orig_shape = let open Subst.Lazy in (* Do a quick nominal comparison for simple types and if that fails, try to @@ -659,14 +696,14 @@ and try_modtypes ~direction ~loc env subst ~modes in begin match mty1, mty2 with | Some mty1, Some mty2 -> - try_modtypes ~direction ~loc env subst ~modes mty1 mty2 orig_shape + try_modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 + orig_shape | _, _ -> Error (Error.Mode e) end | Ok () -> Ok (Tcoerce_none, orig_shape) end - | (Mty_alias p1, _) when not (is_alias mty2) -> begin match Env.normalize_module_path (Some Location.none) env p1 @@ -676,8 +713,8 @@ and try_modtypes ~direction ~loc env subst ~modes | p1 -> begin match Env.find_module_lazy p1 env with | md -> begin - match strengthened_modtypes ~direction ~loc ~aliasable:true env - subst ~modes md.md_type p1 mty2 orig_shape + match strengthened_modtypes ~core ~direction ~loc ~aliasable:true + env subst ~modes md.md_type p1 mty2 orig_shape with | Ok _ as x -> x | Error reason -> Error (Error.After_alias_expansion reason) @@ -693,7 +730,7 @@ and try_modtypes ~direction ~loc env subst ~modes |> map_error (fun e -> Error.Mode e) in begin match - signatures ~direction ~loc env subst ~modes sig1 sig2 orig_shape + signatures ~core ~direction ~loc env subst ~modes sig1 sig2 orig_shape with | Ok _ as ok -> ok | Error e -> Error (Error.Signature e) @@ -707,7 +744,7 @@ and try_modtypes ~direction ~loc env subst ~modes in let cc_arg, env, subst = let direction = Directionality.negate direction in - functor_param ~direction ~loc env + functor_param ~core ~direction ~loc env subst param1 param2 in let var, res_shape = @@ -715,10 +752,10 @@ and try_modtypes ~direction ~loc env subst ~modes | 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 @@ -727,7 +764,7 @@ and try_modtypes ~direction ~loc env subst ~modes let cc_res : (_, _ Error.mdiff) result = let mres1 = Mode.alloc_as_value mres1 in let mres2 = Mode.alloc_as_value mres2 in - modtypes ~direction ~loc env subst res1 res2 res_shape + modtypes ~core ~direction ~loc env subst res1 res2 res_shape ~modes:(Specific ((mres1, None), mres2)) in begin match cc_arg, cc_res with @@ -746,27 +783,19 @@ and try_modtypes ~direction ~loc env subst ~modes 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.diff - (force_functor_parameter param1::got_params, got_res) - (force_functor_parameter param2::expected_params, expected_res) - res.symptom + let got = Error.cons_arg (force_functor_parameter param1) res.got in + let expected = + Error.cons_arg (force_functor_parameter param2) res.expected in - Error Error.(Functor (Params d)) + Error.functor_params got expected res.symptom | Error symptom, _ -> - let params1, res1 = - retrieve_functor_params env (Subst.Lazy.force_modtype res1) - in - let params2, res2 = - retrieve_functor_params env (Subst.Lazy.force_modtype res2) + let params env param res = + Error.cons_arg (force_functor_parameter param) + (retrieve_functor_params env (Subst.Lazy.force_modtype res)) in - let d = Error.diff - (force_functor_parameter param1::params1, res1) - (force_functor_parameter param2::params2, res2) + Error.functor_params + (params env param1 res1) (params env param2 res2) (Error.Param symptom) - in - Error Error.(Functor (Params d)) | Ok _, Error res -> Error Error.(Functor (Result res)) end @@ -787,7 +816,7 @@ and try_modtypes ~direction ~loc env subst ~modes in match red with | Some (mty1,mty2) -> - try_modtypes ~direction ~loc env subst ~modes mty1 mty2 orig_shape + try_modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 orig_shape | None -> (* Report error *) match mty1, mty2 with @@ -802,14 +831,10 @@ and try_modtypes ~direction ~loc env subst ~modes Error Error.(Mt_core Incompatible_aliases) | Mty_functor _, _ | _, Mty_functor _ -> - let params1 = - retrieve_functor_params env (Subst.Lazy.force_modtype mty1) - in - let params2 = - retrieve_functor_params env (Subst.Lazy.force_modtype mty2) - in - let d = Error.diff params1 params2 Error.Incompatible in - Error Error.(Functor (Params d)) + Error.functor_params + (retrieve_functor_params env (Subst.Lazy.force_modtype mty1)) + (retrieve_functor_params env (Subst.Lazy.force_modtype mty2)) + Error.Incompatible | _, (Mty_ident _ | Mty_strengthen _) -> Error Error.(Mt_core Not_an_identifier) | _, Mty_alias _ -> @@ -819,7 +844,7 @@ and try_modtypes ~direction ~loc env subst ~modes (* Functor parameters *) -and functor_param ~direction ~loc env subst param1 param2 = +and functor_param ~core ~direction ~loc env subst param1 param2 = let open Subst.Lazy in match param1, param2 with | Unit, Unit -> @@ -830,7 +855,7 @@ and functor_param ~direction ~loc env subst param1 param2 = let marg2 = Mode.alloc_as_value marg2 in let cc_arg = match - modtypes ~direction ~loc env Subst.identity arg2' arg1 + modtypes ~core ~direction ~loc env Subst.identity arg2' arg1 Shape.dummy_mod ~modes:(Specific ((marg2, None), marg1)) with | Ok (cc, _) -> Ok cc @@ -860,22 +885,22 @@ and equate_one_functor_param subst env arg2' name1 name2 = | None, None -> env, subst -and strengthened_modtypes ~direction ~loc ~aliasable env - subst ~modes mty1 path1 mty2 shape = +and strengthened_modtypes ~core ~direction ~loc ~aliasable env + subst mty1 path1 mty2 shape = let mty1 = Mtype.strengthen_lazy ~aliasable mty1 path1 in - modtypes ~direction ~loc env subst ~modes mty1 mty2 shape + modtypes ~core ~direction ~loc env subst mty1 mty2 shape -and strengthened_module_decl ~loc ~aliasable ~direction env +and strengthened_module_decl ~loc ~aliasable ~core ~direction env subst ~mmodes md1 path1 md2 shape = let md1 = Subst.Lazy.of_module_decl md1 in let md1 = Mtype.strengthen_lazy_decl ~aliasable md1 path1 in let mty2 = Subst.Lazy.of_modtype md2.md_type in let modes = mmodes in - modtypes ~direction ~loc env subst ~modes md1.md_type mty2 shape + modtypes ~core ~direction ~loc env subst ~modes md1.md_type mty2 shape (* Inclusion between signatures *) -and signatures ~direction ~loc env subst ~modes sig1 sig2 mod_shape = +and signatures ~core ~direction ~loc env subst ~modes sig1 sig2 mod_shape = let open Subst.Lazy in (* Environment used to check inclusion of components *) let sig1 = force_signature_once sig1 in @@ -903,7 +928,7 @@ and signatures ~direction ~loc env subst ~modes sig1 sig2 mod_shape = (* Do the pairing and checking, and return the final coercion *) let paired, unpaired, subst = pair_components subst comps1 sig2 in let d = - signature_components ~direction ~loc new_env subst mod_shape + signature_components ~core ~direction ~loc new_env subst mod_shape Shape.Map.empty ~mmodes:modes (List.rev paired) in @@ -934,14 +959,16 @@ and signatures ~direction ~loc env subst ~modes sig1 sig2 mod_shape = | missings, incompatibles, _runtime_coercions, _leftovers -> Error { Error.env=new_env; + subst; missings = List.map force_signature_item missings; incompatibles; } (* Inclusion between signature components *) and signature_components : - 'a. direction:_ -> loc:_ -> _ -> _ -> _ -> _ -> mmodes:_ -> (_ * _ * 'a) list -> 'a Sign_diff.t = - fun ~direction ~loc env subst orig_shape shape_map ~mmodes paired -> + 'a. core:_ -> direction:_ -> loc:_ -> _ -> _ -> _ -> _ -> + mmodes:_ -> (_ * _ * 'a) list -> 'a Sign_diff.t = + fun ~core ~direction ~loc env subst orig_shape shape_map ~mmodes paired -> let open Subst.Lazy in match paired with | [] -> Sign_diff.{ empty with shape_map } @@ -951,7 +978,7 @@ and signature_components : match sigi1, sigi2 with | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) -> let item = - value_descriptions ~loc ~direction env subst id1 ~mmodes + core.value_descriptions ~loc ~direction env subst id1 ~mmodes (Subst.Lazy.force_value_description valdecl1) (Subst.Lazy.force_value_description valdecl2) in @@ -965,7 +992,8 @@ and signature_components : id1, item, paired_uids, shape_map, present_at_runtime | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) -> let item = - type_declarations ~loc ~direction env subst id1 tydec1 tydec2 + core.type_declarations ~loc ~direction env subst id1 ~mmodes + tydec1 tydec2 in let item = mark_error_as_unrecoverable item in (* Right now we don't filter hidden constructors / labels from the @@ -974,7 +1002,8 @@ and signature_components : id1, item, (tydec1.type_uid, tydec2.type_uid), shape_map, false | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> let item = - extension_constructors ~loc ~direction env subst id1 ext1 ext2 + core.extension_constructors ~loc ~direction env subst id1 + ~mmodes ext1 ext2 in let item = mark_error_as_unrecoverable item in let shape_map = @@ -987,8 +1016,8 @@ and signature_components : Shape.(proj orig_shape (Item.module_ id1)) in let item = - module_declarations ~direction ~loc env subst id1 mty1 mty2 - ~mmodes orig_shape + module_declarations ~core ~direction ~loc env subst id1 + mty1 mty2 ~mmodes orig_shape in let item, shape_map = match item with @@ -1017,7 +1046,7 @@ and signature_components : end | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> let item = - modtype_infos ~direction ~loc env subst id1 info1 info2 + modtype_infos ~core ~direction ~loc env subst id1 info1 info2 in let shape_map = Shape.Map.add_module_type_proj shape_map id1 orig_shape @@ -1026,7 +1055,8 @@ and signature_components : id1, item, (info1.mtd_uid, info2.mtd_uid), shape_map, false | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> let item = - class_declarations env subst id1 ~mmodes decl1 decl2 + core.class_declarations ~loc ~direction env subst id1 ~mmodes + decl1 decl2 in let shape_map = Shape.Map.add_class_proj shape_map id1 orig_shape @@ -1035,7 +1065,8 @@ and signature_components : id1, item, (decl1.cty_uid, decl2.cty_uid), shape_map, true | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> let item = - class_type_declarations ~loc env subst info1 info2 + core.class_type_declarations ~loc ~direction env subst id1 ~mmodes + info1 info2 in let item = mark_error_as_unrecoverable item in let shape_map = @@ -1044,7 +1075,8 @@ and signature_components : id1, item, (info1.clty_uid, info2.clty_uid), shape_map, false | Sig_jkind (id1, jd1, _), Sig_jkind (_id2, jd2, _) -> let item = - jkind_declarations ~loc env ~direction subst id1 jd1 jd2 + core.jkind_declarations ~loc env ~direction subst id1 ~mmodes jd1 + jd2 in let item = mark_error_as_unrecoverable item in let shape_map = Shape.Map.add_jkind_proj shape_map id1 orig_shape in @@ -1088,7 +1120,7 @@ and signature_components : in let rest = if continue then - signature_components ~direction ~loc env subst + signature_components ~core ~direction ~loc env subst orig_shape shape_map ~mmodes rem else let rem = List.map @@ -1102,7 +1134,8 @@ and signature_components : in Sign_diff.merge first rest -and module_declarations ~direction ~loc env subst id1 ~mmodes md1 md2 orig_shape = +and module_declarations ~core ~direction ~loc env subst id1 ~mmodes md1 md2 + orig_shape = let open Subst.Lazy in Builtin_attributes.check_alerts_inclusion ~def:md1.md_loc @@ -1119,13 +1152,13 @@ and module_declarations ~direction ~loc env subst id1 ~mmodes md1 md2 orig_shape Includecore.child_modes_with_modalities id ~modalities mmodes |> map_error (fun e -> Error.(Core (Modalities e))) in - strengthened_modtypes ~direction ~loc ~aliasable:true env subst ~modes + strengthened_modtypes ~core ~direction ~loc ~aliasable:true env subst ~modes md1.md_type p1 md2.md_type orig_shape |> map_error (fun x -> Error.Module_type x) (* Inclusion between module type specifications *) -and modtype_infos ~direction ~loc env subst id info1 info2 = +and modtype_infos ~core ~direction ~loc env subst id info1 info2 = let open Subst.Lazy in Builtin_attributes.check_alerts_inclusion ~def:info1.mtd_loc @@ -1139,10 +1172,10 @@ and modtype_infos ~direction ~loc env subst id info1 info2 = (None, None) -> Ok Tcoerce_none | (Some _, None) -> Ok Tcoerce_none | (Some mty1, Some mty2) -> - check_modtype_equiv ~direction ~loc env mty1 mty2 + check_modtype_equiv ~core ~direction ~loc env mty1 mty2 | (None, Some mty2) -> let mty1 = Mty_ident(Path.Pident id) in - check_modtype_equiv ~direction ~loc env mty1 mty2 in + check_modtype_equiv ~core ~direction ~loc env mty1 mty2 in match r with | Ok _ as ok -> ok | Error e -> @@ -1150,11 +1183,11 @@ and modtype_infos ~direction ~loc env subst id info1 info2 = let info2 = Subst.Lazy.force_modtype_decl info2 in Error Error.(Module_type_declaration (diff info1 info2 e)) -and check_modtype_equiv ~direction ~loc env mty1 mty2 = +and check_modtype_equiv ~core ~direction ~loc env mty1 mty2 = let nested_eq = direction.Directionality.in_eq in let direction = Directionality.enter_eq direction in let c1 = - modtypes ~direction ~loc env Subst.identity mty1 mty2 Shape.dummy_mod + modtypes ~core ~direction ~loc env Subst.identity mty1 mty2 Shape.dummy_mod ~modes:All in let c2 = @@ -1166,7 +1199,7 @@ and check_modtype_equiv ~direction ~loc env mty1 mty2 = else let direction = Directionality.negate direction in Some ( - modtypes ~direction ~loc env Subst.identity ~modes:All + modtypes ~core ~direction ~loc env Subst.identity ~modes:All mty2 mty1 Shape.dummy_mod ) in @@ -1181,11 +1214,11 @@ and check_modtype_equiv ~direction ~loc env mty1 mty2 = | Error less_than, Some Error greater_than -> Error Error.(Incomparable {less_than; greater_than}) -let include_functor_signatures ~direction ~loc env subst sig1 sig2 +let include_functor_signatures ~core ~direction ~loc env subst sig1 sig2 ~modes mod_shape = let _, _, comps1 = build_component_table (fun _pos name -> name) sig1 in let paired, unpaired, subst = pair_components subst comps1 sig2 in - let d = signature_components ~direction ~loc env subst mod_shape + let d = signature_components ~core ~direction ~loc env subst mod_shape Shape.Map.empty ~mmodes:modes (List.rev paired) in @@ -1195,7 +1228,7 @@ let include_functor_signatures ~direction ~loc env subst sig1 sig2 Ok d.runtime_coercions | missings, incompatibles, _leftovers -> let missings = List.map Subst.Lazy.force_signature_item missings in - Error Error.{ env; missings; incompatibles } + Error Error.{ env; subst; missings; incompatibles } let can_alias env path = let rec no_apply = function @@ -1205,6 +1238,54 @@ 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; + jkind_declarations; +} + +let core_consistency = + let type_declarations ~loc:_ env ~direction:_ _ _ ~mmodes:_ 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 ~direction:_ _ _ ~mmodes:_ vd1 vd2 = + match Includecore.value_descriptions_consistency env vd1 vd2 with + | x -> Ok x + | exception Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (mdiff vd1 vd2 All err))) + in + let accept ~loc:_ _env ~direction:_ _subst _id ~mmodes:_ _d1 _d2 = + Ok Tcoerce_none + in + { + type_declarations; + value_descriptions; + class_declarations=accept; + class_type_declarations=accept; + extension_constructors=accept; + jkind_declarations=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 + * Typedtree.mode_with_locks) list ; + } let signatures ~direction ~loc env subst sig1 sig2 mod_shape = let sig1 = Subst.Lazy.of_signature sig1 in @@ -1223,28 +1304,11 @@ let strengthened_modtypes ~direction ~loc ~aliasable env strengthened_modtypes ~direction ~loc ~aliasable env subst mty1 path1 mty2 shape -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 - * Typedtree.mode_with_locks) list ; - } - let check_functor_application_raw ~loc env mty1 path1 mty2 = let aliasable = can_alias env path1 in let direction = Directionality.unknown ~mark:true in - strengthened_modtypes ~direction ~loc ~aliasable env - Subst.identity ~modes:All mty1 path1 mty2 - Shape.dummy_mod + strengthened_modtypes ~core:core_inclusion ~direction ~loc ~aliasable env + Subst.identity ~modes:All mty1 path1 mty2 Shape.dummy_mod |> Result.map fst let check_functor_application ~loc env mty1 path1 mty2 = @@ -1283,10 +1347,11 @@ let () = let compunit0 ~comparison env ~mark impl_name impl_sig intf_name intf_sig unit_shape = + let loc = Location.in_file impl_name in let direction = Directionality.strictly_positive ~mark ~both:false in match - signatures ~direction ~loc:(Location.in_file impl_name) env - Subst.identity ~modes:modes_unit impl_sig intf_sig unit_shape + signatures ~core:core_inclusion ~direction ~loc env Subst.identity + ~modes:modes_unit impl_sig intf_sig unit_shape with Result.Error reasons -> let diff = Error.diff impl_name intf_name reasons in let cdiff = @@ -1357,8 +1422,8 @@ module Functor_inclusion_diff = struct | None -> None | Some res -> match retrieve_functor_params env res with - | [], _ -> None - | params, res -> + | { params = []; _ } -> None + | { params; res} -> let more = Array.of_list params in Some (keep_expansible_param res, more) @@ -1399,7 +1464,8 @@ module Functor_inclusion_diff = struct in expand_params { st with env; subst } - let diff env (l1,res1) (l2,_) = + type inclusion_env = { i_env:Env.t; i_subst:Subst.t } + let diff {i_env=env; i_subst=subst} (l1,res1) (l2,_) = let module Compute = Diff.Left_variadic(struct let test st mty1 mty2 = let loc = Location.none in @@ -1407,7 +1473,7 @@ module Functor_inclusion_diff = struct let mty1 = Subst.Lazy.of_functor_parameter mty1 in let mty2 = Subst.Lazy.of_functor_parameter mty2 in let direction = Directionality.unknown ~mark:false in - functor_param ~direction ~loc st.env + functor_param ~core:core_inclusion ~direction ~loc st.env st.subst mty1 mty2 in res @@ -1418,7 +1484,7 @@ module Functor_inclusion_diff = struct 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} + { env; subst; res = keep_expansible_param res1} in Compute.diff state param1 param2 @@ -1493,7 +1559,7 @@ module Functor_app_diff = struct I.expand_params { st with env; res} let diff env ~f ~args = - let params, res = retrieve_functor_params env f in + let {Error.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,arg_mode) param = @@ -1507,7 +1573,7 @@ module Functor_app_diff = struct let param_m = Mode.alloc_as_value param_m in let direction = Directionality.unknown ~mark:false in match - modtypes ~direction ~loc state.env + modtypes ~core:core_inclusion ~direction ~loc state.env state.subst arg_mty param ~modes:(Specific (arg_mode, param_m)) Shape.dummy_mod with @@ -1532,23 +1598,35 @@ end let modtypes_constraint ~shape ~loc env ~mark ~modes mty1 mty2 = (* modtypes with shape is used when typing module expressions in [Typemod] *) let direction = Directionality.strictly_positive ~mark ~both:true in - match modtypes ~direction ~loc env - Subst.identity ~modes mty1 mty2 shape + match + modtypes ~core:core_inclusion ~direction ~loc env + Subst.identity ~modes 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 = + let direction = Directionality.unknown ~mark:false in + match + modtypes ~core:core_consistency ~direction ~loc env Subst.identity + ~modes:All mty1 mty2 Shape.dummy_mod + with + | Ok _ -> () + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + let modtypes ~loc env ~mark ~modes mty1 mty2 = let direction = Directionality.unknown ~mark in - match modtypes ~direction ~loc env - Subst.identity ~modes mty1 mty2 Shape.dummy_mod + match + modtypes ~core:core_inclusion ~direction ~loc env Subst.identity + ~modes mty1 mty2 Shape.dummy_mod with | Ok (cc, _) -> cc | Error reason -> raise (Error (env, Error.(In_Module_type reason))) let gen_signatures env ~direction ~modes sig1 sig2 = - match signatures ~direction ~loc:Location.none env - Subst.identity ~modes sig1 sig2 Shape.dummy_mod + match + signatures ~core:core_inclusion ~direction ~loc:Location.none env + Subst.identity ~modes sig1 sig2 Shape.dummy_mod with | Ok (cc, _) -> cc | Error reason -> raise (Error(env,Error.(In_Signature reason))) @@ -1567,15 +1645,19 @@ let include_functor_signatures env ~mark sig1 sig2 ~modes = let sig1 = List.map Subst.Lazy.of_signature_item sig1 in let sig2 = List.map Subst.Lazy.of_signature_item sig2 in let direction = Directionality.unknown ~mark in - match include_functor_signatures ~direction ~loc:Location.none env + match include_functor_signatures ~core:core_inclusion ~direction + ~loc:Location.none env Subst.identity sig1 sig2 ~modes Shape.dummy_mod with | Ok cc -> cc - | Error reason -> raise (Error(env,Error.(In_Include_functor_signature reason))) + | Error reason -> + raise (Error(env,Error.(In_Include_functor_signature reason))) let type_declarations ~loc env ~mark id decl1 decl2 = let direction = Directionality.unknown ~mark in - match type_declarations ~loc env ~direction Subst.identity id decl1 decl2 with + match Core_inclusion.type_declarations ~loc env ~direction + Subst.identity id ~mmodes:All decl1 decl2 + with | Ok _ -> () | Error (Error.Core reason) -> raise (Error(env,Error.(In_Type_declaration(id,reason)))) @@ -1584,7 +1666,8 @@ let type_declarations ~loc env ~mark id decl1 decl2 = let jkind_declarations ~loc env ~mark id decl1 decl2 = let direction = Directionality.unknown ~mark in match - jkind_declarations ~loc env ~direction Subst.identity id decl1 decl2 + Core_inclusion.jkind_declarations ~loc env ~direction + Subst.identity id ~mmodes:All decl1 decl2 with | Ok _ -> () | Error (Error.Core reason) -> @@ -1593,8 +1676,8 @@ let jkind_declarations ~loc env ~mark id decl1 decl2 = let strengthened_module_decl ~loc ~aliasable env ~mark ~mmodes md1 path1 md2 = let direction = Directionality.unknown ~mark in - match strengthened_module_decl ~loc ~aliasable ~direction env Subst.identity - ~mmodes md1 path1 md2 Shape.dummy_mod with + match strengthened_module_decl ~core:core_inclusion ~loc ~aliasable ~direction + env Subst.identity ~mmodes md1 path1 md2 Shape.dummy_mod with | Ok (x, _shape) -> x | Error d -> raise (Error(env,Error.(In_Module_type d))) @@ -1609,7 +1692,9 @@ let check_modtype_equiv ~loc env id mty1 mty2 = let mty1' = Subst.Lazy.of_modtype mty1 in let mty2' = Subst.Lazy.of_modtype mty2 in let direction = Directionality.unknown ~mark:true in - match check_modtype_equiv ~direction ~loc env mty1' mty2' with + match + check_modtype_equiv ~core:core_inclusion ~direction ~loc env mty1' mty2' + with | Ok _ -> () | Error e -> raise (Error(env, diff --git a/upstream/ocaml_flambda/typing/includemod.mli b/upstream/ocaml_flambda/typing/includemod.mli index 349d6b82c..e44d19590 100644 --- a/upstream/ocaml_flambda/typing/includemod.mli +++ b/upstream/ocaml_flambda/typing/includemod.mli @@ -97,13 +97,16 @@ module Error: sig (** One side is a functor but the other side is not *) and functor_params_diff = - (Types.functor_parameter list * Types.module_type, - functor_params_symptom) diff + (functor_params_info, functor_params_symptom) diff (** the return mode of the functor is intentionally omitted, since the diff is only about parameters. *) + and functor_params_info = + { params: functor_parameter list; res: module_type } + and signature_symptom = { env: Env.t; + subst: Subst.t; missings: Types.signature_item list; incompatibles: (Ident.t * sigitem_symptom) list; } @@ -178,11 +181,16 @@ val modtypes: loc:Location.t -> Env.t -> mark:bool -> modes:modes -> module_type -> module_type -> module_coercion +val modtypes_consistency: + loc:Location.t -> Env.t -> module_type -> module_type -> unit + (** [modtypes_constraint ~shape ~loc env ~mark exp_modtype constraint_modtype] checks that [exp_modtype] is a subtype of [constraint_modtype], and returns the module coercion and the shape of the constrained module. + It also marks as used paired items in positive position in [exp_modtype], and also paired items in negative position in [constraint_modtype]. + This marking in negative position allows to raise an [unused item] warning whenever an item in a functor parameter in [constraint_modtype] does not exist in [exp_modtypes]. This behaviour differs from the one in @@ -214,8 +222,8 @@ val signatures: Env.t -> mark:bool -> modes:modes -> val include_functor_signatures : Env.t -> mark:bool -> signature -> signature -> modes:modes -> (Ident.t * module_coercion) list -val check_implementation: Env.t -> modes:modes -> signature -> signature -> unit (** Check an implementation against an interface *) +val check_implementation: Env.t -> modes:modes -> signature -> signature -> unit val compunit: Env.t -> mark:bool -> string -> signature -> @@ -266,7 +274,8 @@ module Functor_inclusion_diff: sig type diff = (Types.functor_parameter, unit) Error.functor_param_symptom type state end - val diff: Env.t -> + type inclusion_env = { i_env:Env.t; i_subst:Subst.t } + val diff: inclusion_env -> Types.functor_parameter list * Types.module_type -> Types.functor_parameter list * Types.module_type -> Diffing.Define(Defs).patch diff --git a/upstream/ocaml_flambda/typing/includemod_errorprinter.ml b/upstream/ocaml_flambda/typing/includemod_errorprinter.ml index c1b5172b0..b8932a96c 100644 --- a/upstream/ocaml_flambda/typing/includemod_errorprinter.ml +++ b/upstream/ocaml_flambda/typing/includemod_errorprinter.ml @@ -15,6 +15,9 @@ module Style = Misc.Style module Fmt = Format_doc +module Printtyp = Printtyp.Doc +type inclusion_env = Includemod.Functor_inclusion_diff.inclusion_env = + { i_env:Env.t; i_subst:Subst.t } module Context = struct type pos = @@ -40,9 +43,9 @@ module Context = struct Fmt.fprintf ppf "@[<2>module type %a =@ %a@]" Printtyp.ident id context_mty rem | Body x :: rem -> - Fmt.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem + Fmt.fprintf ppf "(%s) ->@ %a" (argname x) context_mty rem | Arg x :: rem -> - Fmt.fprintf ppf "functor (%s : %a) -> ..." + Fmt.fprintf ppf "(%s : %a) -> ..." (argname x) context_mty rem | [] -> Fmt.fprintf ppf "" @@ -68,14 +71,14 @@ module Context = struct let alt_pp ppf cxt = if cxt = [] then () else if List.for_all (function Module _ -> true | _ -> false) cxt then - Fmt.fprintf ppf "in module %t," + Fmt.fprintf ppf ",@ in module %t" (fun ppf -> Fmt.deprecated_printer (fun fmt -> Format.fprintf fmt "%a" (Fmt.compat (Style.as_inline_code Printtyp.path)) (path_of_context cxt) ) ppf) else - Fmt.fprintf ppf "@[at position@ %a,@]" + Fmt.fprintf ppf ",@ @[at position@ %a@]" (Style.as_inline_code context) cxt let pp ppf cxt = @@ -92,9 +95,8 @@ module Context = struct (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}. *) @@ -107,43 +109,53 @@ 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 { pos_cc_list; _ } -> either - (not_fixpoint path 0) pos_cc_list + (first_item_transposition path 0) pos_cc_list (first_non_id path 0) pos_cc_list | 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 + | Tcoerce_invalid -> + Misc.fatal_error + "Includemod_errorprinter.first_change_under: invalid coercion" + (* 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 @@ -180,19 +192,60 @@ module Illegal_permutation = struct (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 + 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 *) 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 @@ -216,7 +269,7 @@ let show_locs ppf (loc1, loc2) = let dmodtype mty = - let tmty = Printtyp.tree_of_modtype ~abbrev:true mty in + let tmty = Out_type.tree_of_modtype ~abbrev:true mty in Fmt.dprintf "%a" !Oprint.out_module_type tmty let space ppf () = Fmt.fprintf ppf "@ " @@ -532,17 +585,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 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 - Printtyp.functor_parameters ~sep elt params + pp_params params let expected ~is_modal d = let extract: _ Diffing.change -> _ = function @@ -712,7 +786,7 @@ module Functor_suberror = struct Fmt.pp_open_tbox () Diffing.prefix (pos, Diffing.classify diff) Fmt.pp_set_tab () - (Printtyp.wrap_printing_env env ~error:true + (Printtyp.wrap_printing_env env.i_env ~error:true (fun () -> sub ~expansion_token env diff) ) Fmt.pp_close_tbox () @@ -720,7 +794,7 @@ module Functor_suberror = struct let onlycase sub ~expansion_token env (_, diff) = Location.msg "%a@[%t@]" Fmt.pp_print_tab () - (Printtyp.wrap_printing_env env ~error:true + (Printtyp.wrap_printing_env env.i_env ~error:true (fun () -> sub ~expansion_token env diff) ) @@ -791,84 +865,77 @@ let core env id x = let mode1, mode2 = maybe_print_modes ~in_structure:true ~is_modal diff.modes in - Fmt.dprintf "@[@[%s:@;<1 2>%a%t@ %s@;<1 2>%a%t@]%a%a%t@]" + Fmt.dprintf "@[@[%s:@;<1 2>%a%t@ %s@;<1 2>%a%t@]%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) mode1 "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) mode2 (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.Modalities e -> Fmt.dprintf "@[%s:@;%a@]" ("Modalities on " ^ (Ident.name id) ^ " do not match") (Includecore.report_modality_sub_error "the first" "the second") e | Err.Type_declarations diff -> - Fmt.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 -> - Fmt.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 -> 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) + (Out_type.tree_of_cltype_declaration id diff.expected Trec_first) (Includeclass.report_error_doc Type_scheme) diff.symptom - Printtyp.Conflicts.print_explanations | Err.Class_declarations {got;expected;symptom=Class_type reason} -> - let t1 = Printtyp.tree_of_class_declaration id got Trec_first in - let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in + 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_doc Type_scheme) reason - Printtyp.Conflicts.print_explanations | Err.Class_declarations {symptom=Class_mode e} -> Fmt.dprintf - "@[Class declarations %s do not match:@ @]@ %a%t" + "@[Class declarations %s do not match:@ @]@ %a" (Ident.name id) (Includecore.report_mode_sub_error "first is" "second is") e - Printtyp.Conflicts.print_explanations | Err.Jkind_declarations diff -> - Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + Fmt.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" "Kind declarations do not match" !Oprint.out_sig_item - (Printtyp.tree_of_jkind_declaration id diff.got) + (Out_type.tree_of_jkind_declaration id diff.got) "is not included in" !Oprint.out_sig_item - (Printtyp.tree_of_jkind_declaration id diff.expected) + (Out_type.tree_of_jkind_declaration id diff.expected) (Includecore.report_jkind_mismatch "the first" "the second") diff.symptom show_locs (diff.got.jkind_loc, diff.expected.jkind_loc) - Printtyp.Conflicts.print_explanations let missing_field ppf item = let id, loc, kind = Includemod.item_ident_name item in @@ -884,9 +951,9 @@ let module_types ~env {Err.got=mty1; expected=mty2; modes; symptom}= Fmt.dprintf "@[Modules do not match:@ \ %a%t@;<1 -2>is not included in@ %a%t@]" - !Oprint.out_module_type (Printtyp.tree_of_modtype ~abbrev:true mty1) + !Oprint.out_module_type (Out_type.tree_of_modtype ~abbrev:true mty1) mode1 - !Oprint.out_module_type (Printtyp.tree_of_modtype ~abbrev:true mty2) + !Oprint.out_module_type (Out_type.tree_of_modtype ~abbrev:true mty2) mode2 let eq_module_types ~env ({Err.got=mty1; expected=mty2} : _ mdiff) = @@ -894,15 +961,15 @@ let eq_module_types ~env ({Err.got=mty1; expected=mty2} : _ mdiff) = Fmt.dprintf "@[Module types do not match:@ \ %a@;<1 -2>is not equal to@ %a@]" - !Oprint.out_module_type (Printtyp.tree_of_modtype ~abbrev:true mty1) - !Oprint.out_module_type (Printtyp.tree_of_modtype ~abbrev:true mty2) + !Oprint.out_module_type (Out_type.tree_of_modtype ~abbrev:true mty1) + !Oprint.out_module_type (Out_type.tree_of_modtype ~abbrev:true 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 (Printtyp.tree_of_modtype_declaration ~abbrev:true id d1) - !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration ~abbrev:true id d2) + !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration ~abbrev:true id d1) + !Oprint.out_sig_item (Out_type.tree_of_modtype_declaration ~abbrev:true id d2) let interface_mismatch ppf (diff: _ Err.diff) = Fmt.fprintf ppf @@ -922,10 +989,7 @@ let compilation_unit_mismatch comparison ppf diff = 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(Fmt.dprintf "Unbound module %a" (Style.as_inline_code Printtyp.path) path @@ -933,8 +997,43 @@ let core_module_type_symptom (x:Err.core_module_type_symptom) = (* Construct a linearized error message from the error tree *) +let functor_expected ~before ~ctx = + let main = + (* The abstract module type case is detected by {!Includemod} *) + Fmt.dprintf + "@[This module should not be@ a@ structure,@ \ + a@ functor@ was expected.@]" + in + dwith_context ctx main :: before + +let unexpected_functor ~env ~before ~ctx diff = + let rmty = diff.got.res in + let intro = + match diff.expected.res with + | Mty_ident _ -> + Fmt.dprintf + "@[This module should not be a functor,@ a@ module with an@ \ + abstract@ module@ type@ was@ expected.@]" + | Mty_signature _ | _ -> + Fmt.dprintf + "@[This module should not be a functor,@ a@ structure was expected.@]" + in + let main = + match Includemod.modtypes_consistency ~loc:Location.none env rmty + diff.expected.res with + | _ -> + Fmt.dprintf + "%t@ @{Hint@}: Did you forget to apply the functor?" + intro + | exception _ -> + Fmt.dprintf "%t@ @[Moreover,@ the type of the functor@ body@ is@ \ + incompatible@ with@ the@ expected@ module type.@]" + intro + in + dwith_context ctx main :: before + let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx - (diff : _ mdiff) = + (diff : _ mdiff) = match diff.symptom with | Invalid_module_alias _ (* the difference is non-informative here *) | After_alias_expansion _ (* we print only the expanded module types *) -> @@ -946,7 +1045,11 @@ let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx diff.symptom | _ -> - let inner = if eqmode then eq_module_types ~env else module_types ~env in + let inner = + if eqmode + then eq_module_types ~env:env.i_env + else module_types ~env:env.i_env + in let next = match diff.symptom with | Mt_core _ -> @@ -983,16 +1086,27 @@ and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function in dwith_context ctx printer :: before -and functor_params ~expansion_token ~env ~before ~ctx {got;expected;symptom} = +and functor_params ~expansion_token ~env ~before ~ctx diff = + match diff.got.params, diff.expected.params with + | [], _ -> functor_expected ~before ~ctx + | _, [] -> unexpected_functor ~env:env.i_env ~before ~ctx diff + | _ :: _, _ :: _ -> + compare_functor_params ~expansion_token ~env ~before ~ctx diff + +and compare_functor_params ~expansion_token ~env ~before ~ctx + {got;expected;symptom} = let is_modal = Is_modal.functor_params_symptom symptom in - let d = Functor_suberror.Inclusion.patch env got expected in + let d = Functor_suberror.Inclusion.patch env + (got.params, got.res) + (expected.params, expected.res) + in let actual = Functor_suberror.Inclusion.got ~is_modal d in let expected = Functor_suberror.expected ~is_modal d in let main = 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 @@ -1019,12 +1133,14 @@ and signature ~expansion_token ~env:_ ~before ~ctx sgs = :: before else before - | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a + | [], a :: _ -> + let env = {i_env=sgs.env; i_subst=sgs.subst } in + sigitem ~expansion_token ~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 + dwith_context ctx (core env.i_env name c) :: before | Module_type diff -> module_type ~expansion_token ~eqmode:false ~env ~before ~ctx:(Context.Module name :: ctx) diff @@ -1056,7 +1172,8 @@ 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.i_env) + (mty,c) :: before end @@ -1105,10 +1222,10 @@ let module_type_subst ~env id diff = ~ctx:[Modtype id] mts.less_than | Illegal_permutation c -> let mty = diff.got in - let main = - with_context [Modtype id] - (Illegal_permutation.pp Context.alt_pp env) (mty,c) in - [main] + [with_context [Modtype id] + (Runtime_coercion.illegal_permutation Context.alt_pp env.i_env) + (mty,c) + ] let all env = function | In_Compilation_unit (comparison, diff) -> @@ -1117,9 +1234,9 @@ let all env = function in signature ~expansion_token:true ~env ~before:[first] ~ctx:[] diff.symptom | In_Type_declaration (id,reason) -> - [Location.msg "%t" (core env id reason)] + [Location.msg "%t" (core env.i_env id reason)] | In_Jkind_declaration (id,reason) -> - [Location.msg "%t" (core env id reason)] + [Location.msg "%t" (core env.i_env id reason)] | In_Module_type diff -> module_type ~expansion_token:true ~eqmode:false ~before:[] ~env ~ctx:[] diff @@ -1137,28 +1254,32 @@ let all env = function (* General error reporting *) let err_msgs ppf (env, err) = - Printtyp.Conflicts.reset(); Printtyp.wrap_printing_env ~error:true env - (fun () -> (coalesce @@ all env err) ppf) + (fun () -> (coalesce @@ all {i_env=env; i_subst=Subst.identity} err) ppf) let report_error_doc err = - Location.errorf ~loc:Location.(in_file !input_name) "%a" err_msgs 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 "%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:[] + module_type_symptom ~eqmode:false ~expansion_token:true + ~env:{i_env=env; i_subst=Subst.identity} ~before:[] ~ctx:[] mty_diff.symptom in let is_modal = Is_modal.module_type_symptom mty_diff.symptom in - Location.errorf ~loc "%t" + Location.errorf ~loc ~footnote "%t" (Functor_suberror.App.single_diff ~is_modal g e more) | _ -> let not_functor = @@ -1195,16 +1316,21 @@ let report_apply_error_doc ~loc env (app_name, mty_f, args) = let actual = Functor_suberror.App.got ~is_modal:None d in let expected = Functor_suberror.expected ~is_modal:None d in let sub = + let env = {i_env=env; i_subst=Subst.identity} in 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 diff --git a/upstream/ocaml_flambda/typing/includemod_errorprinter.mli b/upstream/ocaml_flambda/typing/includemod_errorprinter.mli index 080ea1cb2..0c7dda4e5 100644 --- a/upstream/ocaml_flambda/typing/includemod_errorprinter.mli +++ b/upstream/ocaml_flambda/typing/includemod_errorprinter.mli @@ -14,4 +14,6 @@ (**************************************************************************) 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_flambda/typing/jkind.ml b/upstream/ocaml_flambda/typing/jkind.ml index c21fdd1a7..4f9d23780 100644 --- a/upstream/ocaml_flambda/typing/jkind.ml +++ b/upstream/ocaml_flambda/typing/jkind.ml @@ -2443,6 +2443,12 @@ let for_array_element_sort ~level = ( fresh_jkind jkind ~annotation:None ~why:(Concrete_creation Array_element), sort ) +let for_effect_arg ident = + let why : History.value_creation_reason = + Type_argument { parent_path = Path.Pident ident; position = 1; arity = 1 } + in + Builtin.value ~why + (******************************) (* elimination and defaulting *) diff --git a/upstream/ocaml_flambda/typing/jkind.mli b/upstream/ocaml_flambda/typing/jkind.mli index 8929b7f92..29593a5a8 100644 --- a/upstream/ocaml_flambda/typing/jkind.mli +++ b/upstream/ocaml_flambda/typing/jkind.mli @@ -527,6 +527,9 @@ val for_abbreviation : (** The jkind for array elements, creating a new sort variable. *) val for_array_element_sort : level:int -> Types.jkind_lr * sort +(** The jkind of the parameter of the [effect] type. *) +val for_effect_arg : Ident.t -> 'd Types.jkind + (******************************) (* elimination and defaulting *) diff --git a/upstream/ocaml_flambda/typing/jkind_intf.ml b/upstream/ocaml_flambda/typing/jkind_intf.ml index deaf22ae6..13950795d 100644 --- a/upstream/ocaml_flambda/typing/jkind_intf.ml +++ b/upstream/ocaml_flambda/typing/jkind_intf.ml @@ -159,6 +159,10 @@ module type Sort = sig val for_type_extension : t val for_class : t + + val for_effect : t + + val for_continuation : t end module Var : sig diff --git a/upstream/ocaml_flambda/typing/jkind_types.ml b/upstream/ocaml_flambda/typing/jkind_types.ml index 441373533..5ca41b2c5 100644 --- a/upstream/ocaml_flambda/typing/jkind_types.ml +++ b/upstream/ocaml_flambda/typing/jkind_types.ml @@ -301,6 +301,10 @@ module Sort = struct let for_type_extension = scannable let for_class = scannable + + let for_effect = scannable + + let for_continuation = scannable end module Var = struct diff --git a/upstream/ocaml_flambda/typing/mtype.ml b/upstream/ocaml_flambda/typing/mtype.ml index e93c191ff..456640f30 100644 --- a/upstream/ocaml_flambda/typing/mtype.ml +++ b/upstream/ocaml_flambda/typing/mtype.ml @@ -458,7 +458,7 @@ let scrape env mty = | _ -> mty let () = - Printtyp.expand_module_type := expand ; + Out_type.expand_module_type := expand ; Env.scrape_alias := scrape_alias_lazy let find_type_of_module ~strengthen ~aliasable env path = @@ -546,14 +546,7 @@ and nondep_sig_item env va ids = function 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_modtype(id, nondep_modtype_decl env ids d, vis) | 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) -> diff --git a/upstream/ocaml_flambda/typing/oprint.ml b/upstream/ocaml_flambda/typing/oprint.ml index fd413e2b8..f01435edf 100644 --- a/upstream/ocaml_flambda/typing/oprint.ml +++ b/upstream/ocaml_flambda/typing/oprint.ml @@ -39,28 +39,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 @@ -143,16 +124,6 @@ let escape_string s = Bytes.to_string s' end -let rec 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 - let print_label_type ppf = function | Some s -> @@ -210,6 +181,9 @@ let print_constr ppf name = (* despite being keywords, these are constructor names and should not be escaped *) fprintf ppf "%s" c + | Oide_dot (id, ("true"|"false" as s)) -> + (* Similarly, M.true is invalid *) + fprintf ppf "%a.(%s)" print_ident id s | _ -> print_ident ppf name let print_out_value ppf tree = @@ -289,10 +263,19 @@ let print_out_value ppf tree = | Oval_ellipsis -> raise Ellipsis | Oval_printer f -> f ppf | Oval_tuple tree_list -> - fprintf ppf "@[<1>(%a)@]" (print_labeled_tree_list print_tree_1 ",") tree_list + let print_elem ppf (lbl, item) = + print_label ppf lbl; print_tree_1 ppf item + in + fprintf ppf "@[<1>(%a)@]" (print_tree_list print_elem ",") tree_list | Oval_unboxed_tuple tree_list -> - fprintf ppf "@[<1>#(%a)@]" (print_labeled_tree_list print_tree_1 ",") - tree_list + let print_elem ppf (lbl, item) = + print_label ppf lbl; print_tree_1 ppf item + in + fprintf ppf "@[<1>#(%a)@]" (print_tree_list print_elem ",") tree_list + | Oval_floatarray arr -> + fprintf ppf "@[<2>[|%a|]@]" + (pp_print_seq ~pp_sep:semicolon pp_print_float) + (Float.Array.to_seq arr) | Oval_code e -> deprecated_printer (fun fmt -> CamlinternalQuote.Code.print fmt e) ppf | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree @@ -304,7 +287,8 @@ let print_out_value ppf tree = 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 = + and print_tree_list : 'a . (_ -> 'a -> _) -> _ -> _ -> 'a list -> unit = + fun print_item sep ppf tree_list -> let rec print_list first ppf = function [] -> () @@ -314,17 +298,6 @@ let print_out_value ppf tree = print_list false ppf tree_list in cautious (print_list true) ppf tree_list - and print_labeled_tree_list print_item sep ppf labeled_tree_list = - let rec print_list first ppf = - function - [] -> () - | (label, tree) :: labeled_tree_list -> - if not first then fprintf ppf "%s@ " sep; - print_label ppf label; - print_item ppf tree; - print_list false ppf labeled_tree_list - in - cautious (print_list true) ppf labeled_tree_list in cautious print_tree_1 ppf tree @@ -365,12 +338,6 @@ let print_out_modes ppf l = | _ -> pp_print_string ppf " @ "); pp_print_list ~pp_sep:pp_print_space print_out_mode ppf l -(* Labeled tuples with the first element labeled sometimes require parens. *) -let is_initially_labeled_tuple ty = - match ty with - | Otyp_tuple ((Some _, _) :: _) -> true - | _ -> false - let print_out_modality = pp_print_string let print_out_modalities ppf l = @@ -416,19 +383,8 @@ let rec print_out_type_0 ppf = | ty -> print_out_type_1 ppf ty -(* We must parenthesize a labeled tuple with the first element labeled when: - - It is an argument to a function ([~arg]) - - Or, there is at least one mode to print. - *) and print_out_type_mode ~arg mode ppf ty = - let parens = - is_initially_labeled_tuple ty && arg - in - if parens then - pp_print_char ppf '('; - print_out_type_2 ppf ty; - if parens then - pp_print_char ppf ')'; + print_out_type_2 ~arg ppf ty; print_out_modes ppf mode and print_out_type_1 ppf = @@ -440,7 +396,7 @@ and print_out_type_1 ppf = pp_print_space ppf (); print_out_ret ppf ty2; pp_close_box ppf () - | ty -> print_out_type_2 ppf ty + | ty -> print_out_type_2 ~arg:false ppf ty and print_out_arg am ppf ty = print_out_type_mode ~arg:true am ppf ty @@ -460,13 +416,27 @@ and print_out_ret ppf = | Otyp_ret (Orm_any rm, ty) -> print_out_type_mode ~arg:false rm ppf ty | _ -> assert false -and print_out_type_2 ppf = +and print_out_type_2 ~arg ppf = function - | Otyp_tuple tyl -> - fprintf - ppf "@[<0>%a@]" (print_labeled_typlist print_simple_out_type " *") tyl - | ty -> print_out_type_3 ppf ty -and print_out_type_3 ppf = + Otyp_tuple tyl -> + (* Tuples require parens in argument function argument position (~arg) + when the first element has a label. *) + let parens = + match tyl with + | (Some _, _) :: _ -> arg + | _ -> false + in + if parens then pp_print_char ppf '('; + let print_elem ppf (label, ty) = + pp_open_box ppf 0; + print_label_type ppf label; + print_simple_out_type ppf ty; + pp_close_box ppf () + in + fprintf ppf "@[<0>%a@]" (print_typlist print_elem " *") tyl; + if parens then pp_print_char ppf ')' + | 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 @@ -519,16 +489,8 @@ and print_out_type_3 ppf = | Otyp_sum _ | Otyp_manifest (_, _) -> () | Otyp_record lbls -> print_record_decl ~unboxed:false ppf lbls | Otyp_record_unboxed_product lbls -> print_record_decl ~unboxed:true 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_module pack -> + fprintf ppf "@[<1>(module %a)@]" print_package pack | Otyp_attribute (t, attr) -> fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type_0 t attr.oattr_name @@ -543,8 +505,15 @@ and print_out_type_3 ppf = | Otyp_splice t -> fprintf ppf "@[<1>$@,(%a)@]" print_out_type_0 t and print_out_type ppf typ = print_out_type_0 ppf typ -and print_simple_out_type ppf typ = - print_out_type_3 ppf typ +and print_package ppf pack = + fprintf ppf "%a" print_ident pack.opack_path; + 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 + ) + pack.opack_cstrs and print_record_decl ~unboxed ppf lbls = let hash = if unboxed then "#" else "" in fprintf ppf "%s{%a@;<1 -2>}" @@ -568,6 +537,16 @@ and print_row_field ppf (l, opt_amp, tyl) = fprintf ppf "@[`%a%t%a@]" print_lident l pr_of (print_typlist print_out_type " &") tyl +and print_typlist : 'a . (_ -> 'a -> _) -> _ -> _ -> 'a list -> _ = + fun print_elem sep ppf tyl -> + match tyl with + [] -> () + | [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 [] -> () @@ -579,23 +558,24 @@ and print_typargs ppf = pp_print_char ppf ')'; pp_close_box ppf (); pp_print_space ppf () -and print_out_label ppf (name, mut, arg, gbl) = +and print_out_label ppf + { olab_name; olab_mut; olab_type; olab_modalities } = (* See the notes [NON-LEGACY MODES] *) let mut, atomic = - match mut with + match olab_mut with | Om_immutable -> "", Nonatomic | Om_mutable (None, atomic) -> "mutable ", atomic | Om_mutable (Some s, atomic) -> "mutable(" ^ s ^ ") ", atomic in - let print_atomic ppf atomic = match atomic with + let print_atomic ppf = function | Nonatomic -> () | Atomic -> fprintf ppf " [@@atomic]" in fprintf ppf "@[<2>%s%a :@ %a%a%a@];" mut - print_lident name - print_out_type arg - print_out_modalities gbl + print_lident olab_name + print_out_type olab_type + print_out_modalities olab_modalities print_atomic atomic and print_out_jkind_const ppf ojkind = @@ -734,7 +714,11 @@ let type_parameter ~in_parens ppf | _ -> format_string in fprintf ppf format_string - (match var with Covariant -> "+" | Contravariant -> "-" | NoVariance -> "") + (match var with + | Covariant -> "+" + | Contravariant -> "-" + | NoVariance -> "" + | Bivariant -> "+-") (match inj with Injective -> "!" | NoInjectivity -> "") (print_type_parameter ~non_gen) ty print_out_jkind_annot lay @@ -759,7 +743,7 @@ let rec print_out_class_type ppf = in fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id | Octy_arrow (lab, ty, cty) -> - let print_type = print_out_type_2 in + let print_type = print_out_type_2 ~arg:true in fprintf ppf "@[%t ->@ %a@]" (fun ppf -> print_arg_label_and_out_type ppf lab ty ~print_type) print_out_class_type cty diff --git a/upstream/ocaml_flambda/typing/oprint.mli b/upstream/ocaml_flambda/typing/oprint.mli index 85218e793..e6ac3dd35 100644 --- a/upstream/ocaml_flambda/typing/oprint.mli +++ b/upstream/ocaml_flambda/typing/oprint.mli @@ -20,7 +20,7 @@ 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 : (string * out_mutability * out_type * out_modality list) printer +val out_label : out_label printer val out_modality : out_modality printer val out_modes : out_mode list printer val out_jkind_const : out_jkind_const printer diff --git a/upstream/ocaml_flambda/typing/out_type.ml b/upstream/ocaml_flambda/typing/out_type.ml new file mode 100644 index 000000000..fe68b8a66 --- /dev/null +++ b/upstream/ocaml_flambda/typing/out_type.ml @@ -0,0 +1,2880 @@ +(**************************************************************************) +(* *) +(* 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 +open Mode + +module String = Misc.Stdlib.String +module Int = Misc.Stdlib.Int +module Sig_component_kind = Shape.Sig_component_kind +module Style = Misc.Style + +(* Note [When to print jkind annotations] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Jkind annotations are only occasionally necessary to write + (compilation can often infer jkinds), so when should we print + them? This Note addresses all the cases. + + Case (C1). The jkind on a type declaration, like + [type 'a t : <> = ...]. + + We print the jkind when it cannot be inferred from the rest of what is + printed. Specifically, we print the user-written jkind in any of these + cases: + + (C1.1) The type declaration is abstract, has no manifest (i.e., + it's written without any [=]-signs), and the annotation is not equivalent to value. + + In this case, there is no way to know the jkind without the annotation. + + (C1.2) The type has unsafe mode crossings. In this case, the jkind is overridden by the + user rather than being inferred from the definition. + + Case (C2). The jkind on a type parameter to a type, like + [type ('a : <>) t = ...]. + + This jkind is printed if both of the following are true: + + (C2.1) The jkind is something other than the default [value]. + (* CR layouts reisenberg: update when the default changes *) + + (C2.2) The variable has no constraints on it. (If there is a constraint, + the constraint determines the jkind, so printing the jkind is + redundant.) + + We *could*, in theory, print this only when it cannot be inferred. + But this amounts to repeating inference. The heuristic also runs into + trouble when considering the possibility of a recursive type. So, in + order to keep the pretty-printer simple, we just always print the + (non-default) annotation. + + Another design possibility is to pass in verbosity level as some kind + of flag. + + Case (C3). The jkind on a universal type variable, like + [val f : ('a : <>). 'a -> 'a]. + + We should print this jkind annotation whenever it is neither the + default [value] nor an unfilled sort variable. (But see (X1) below.) + (* CR layouts reisenberg: update when the default changes *) + This is a challenge, though, because the type in a [val] does not + explicitly quantify its free variables. So we must collect the free + variables, look to see whether any have interesting jkinds, and + print the whole set of variables if any of them do. This is all + implemented in [extract_qtvs], used also in a number of other places + we do quantification (e.g. gadt-syntax constructors). + + Exception (X1). When we are still in the process of inferring a type, + there may be an unfilled sort variable. Here is an example: + + {[ + module M : sig + val f : int -> bool -> char + end = struct + let f true _ = () + end + ]} + + The problem is that [f]'s first parameter is conflicted between being + [int] and [bool]. But the second parameter in the [struct] will have + type ['a : <>]. We generally do not want to print this, + however, and so we don't -- except when [-verbose-types] is set. + + We imagine that merlin, when run verbosely, will set [-verbose-types]. + This will allow an informative type to be printed for e.g. [let f x = x], + which can work with any sort. +*) + +(* Print a long identifier *) + +module Fmt = Format_doc +open Format_doc + +(* Print an identifier avoiding name collisions *) + +module Out_name = struct + let create x = { printed_name = x } + let print x = x.printed_name + let set out_name x = out_name.printed_name <- x +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 + +let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n + + type namespace = Sig_component_kind.t = + | Value + | Type + | Constructor + | Label + | Unboxed_label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + | Jkind + + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value | Constructor | Label -> 5 + | Unboxed_label -> 6 + | Jkind -> 7 + (* we do not handle those component *) + + let size = 1 + id Jkind + + + 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_lazy + | Some Module_type -> to_lookup Env.find_modtype_by_name_lazy + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | Some Jkind -> to_lookup Env.find_jkind_by_name + | None + | Some(Value|Extension_constructor|Constructor|Label|Unboxed_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_lazy path).md_loc + | Some Module_type -> + (in_printing_env @@ Env.find_modtype_lazy 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 Jkind -> (in_printing_env @@ Env.find_jkind path).jkind_loc + | Some (Extension_constructor|Value|Constructor|Label|Unboxed_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 collect_explanation namespace n id = + let name = human_unique n id in + let root_name = Ident.name id in + if not (M.mem name !explanations) then + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = { kind = namespace; location; name; root_name } in + explanations := M.add name explanation !explanations + + let pp_explanation ppf r= + Fmt.fprintf ppf "@[%a:@,Definition of %s %a@]" + (Location.Doc.loc ~capitalize_first:true) 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 + +(** Name mapping *) +type mapping = + | Need_unique_name of int Ident.Map.t + (** The same name has already been attributed to multiple types. + The [map] argument contains the specific binding time attributed to each + types. + *) + | Uniquely_associated_to of Ident.t * out_name + (** For now, the name [Ident.name id] has been attributed to [id], + [out_name] is used to expand this name if a conflict arises + at a later point + *) + | Associated_to_pervasives of out_name + (** [Associated_to_pervasives out_name] is used when the item + [Stdlib.$name] has been associated to the name [$name]. + Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *) + +let hid_start = 0 + +let add_hid_id id map = + let new_id = 1 + Ident.Map.fold (fun _ -> Int.max) map hid_start in + new_id, Ident.Map.add id new_id map + +let find_hid id map = + try Ident.Map.find id map, map with + Not_found -> add_hid_id id map + +let pervasives name = "Stdlib." ^ name + +let map = Array.make Namespace.size M.empty +let get namespace = map.(Namespace.id namespace) +let set namespace x = map.(Namespace.id namespace) <- x + +(* Names used in recursive definitions are not considered when determining + if a name is already attributed in the current environment. + This is a complementary version of hidden_rec_items used by short-path. *) +let protected = ref S.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 = S.add (Ident.name id.ident) m in + protect_refs [ R(protected, List.fold_left update !protected ids)] f + +let pervasives_name namespace name = + match namespace, !enabled with + | None, _ | _, true -> Out_name.create name + | Some namespace, false -> + match M.find name (get namespace) with + | Associated_to_pervasives r -> r + | Need_unique_name _ -> Out_name.create (pervasives name) + | Uniquely_associated_to (id',r) -> + let hid, map = add_hid_id id' Ident.Map.empty in + Out_name.set r (human_unique hid id'); + Ident_conflicts.collect_explanation namespace hid id'; + set namespace @@ M.add name (Need_unique_name map) (get namespace); + Out_name.create (pervasives name) + | exception Not_found -> + let r = Out_name.create name in + set namespace @@ M.add name (Associated_to_pervasives r) (get namespace); + r + +(** Lookup for preexisting named item within the current {!printing_env} *) +let env_ident namespace name = + if S.mem name !protected then None else + match Namespace.lookup namespace name with + | Pident id -> Some id + | _ -> None + | exception Not_found -> None + +(** Associate a name to the identifier [id] within [namespace] *) +let ident_name_simple 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 = Ident.name id in + match M.find name (get namespace) with + | Uniquely_associated_to (id',r) when Ident.same id id' -> + r + | Need_unique_name map -> + let hid, m = find_hid id map in + Ident_conflicts.collect_explanation namespace hid id; + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | Uniquely_associated_to (id',r) -> + let hid', m = find_hid id' Ident.Map.empty in + let hid, m = find_hid id m in + Out_name.set r (human_unique hid' id'); + List.iter (fun (id,hid) -> Ident_conflicts.collect_explanation namespace hid id) + [id, hid; id', hid' ]; + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | Associated_to_pervasives r -> + Out_name.set r ("Stdlib." ^ Out_name.print r); + let hid, m = find_hid id Ident.Map.empty in + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | exception Not_found -> + let r = Out_name.create name in + set namespace + @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace); + r + +(** Same as {!ident_name_simple} but lookup to existing named identifiers + in the current {!printing_env} *) +let ident_name namespace id = + begin match env_ident namespace (Ident.name id) with + | Some id' -> ignore (ident_name_simple namespace id') + | None -> () + end; + ident_name_simple namespace id + +let reset () = + Array.iteri ( fun i _ -> map.(i) <- M.empty ) map + +let with_ctx f = + let old = Array.copy map in + try_finally f + ~always:(fun () -> Array.blit old 0 map 0 (Array.length map)) + +end +let ident_name = Ident_names.ident_name +let reset_naming_context = Ident_names.reset + +(* let ident ppf id = pp_print_string ppf + * (Out_name.print (Ident_names.ident_name_simple None id)) *) + +(* let namespaced_ident namespace id = + * Out_name.print (Ident_names.ident_name (Some namespace) id) *) + +let instance_name global = + (* Construct the stopgap syntax and then shove it in a string with the + attribute after it. *) + (* CR lmaurer: This is hacky and it loses the state of the [out_name]s that + comprise the [out_ident]. Should presumably have a new constructor for + [out_ident] instead? *) + let rec string_of_global global = + (* We can avoid calling [ident_name_simple] here because instance names are + always global (which is bad - but the syntax is currently bad anyway) *) + let ({ head; args } : Global_module.Name.t) = global in + String.concat "" (head :: List.map string_of_arg args) + and string_of_arg arg = + let ({ param; value } : Global_module.Name.argument) = arg in + Printf.sprintf "(%s)(%s)" + (Global_module.Parameter_name.to_string param) (string_of_global value) + in + let printed_name = + string_of_global global ^ " [@jane.non_erasable.instances]" + in + { printed_name } + + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_pervasive = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match in_printing_env (Env.find_type_by_name (Lident 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 + +let expand_longident_head name = + match find_double_underscore name with + | None -> None + | Some i -> + Some + (Ldot + (Location.mknoloc (Lident (String.sub name 0 i)), + (Location.mknoloc (Unit_info.modulize + (String.sub name (i + 2) (String.length name - i - 2)))))) + +(* 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_impl env p = + match p with + | Pdot (p, s) -> + Pdot (rewrite_double_underscore_paths_impl env p, s) + | Papply (a, b) -> + Papply (rewrite_double_underscore_paths_impl env a, + rewrite_double_underscore_paths_impl env b) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths_impl env p, extra) + | Pident id -> + let name = Ident.name id in + match expand_longident_head name with + | None -> p + | Some better_lid -> + match Env.find_module_by_name_lazy 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_impl env p + +let rec rewrite_double_underscore_longidents env (l : Longident.t) = + match l with + | Ldot (l, s) -> + Ldot (Location.map (rewrite_double_underscore_longidents env) l, s) + | Lapply (a, b) -> + Lapply + ( Location.map (rewrite_double_underscore_longidents env) a, + Location.map (rewrite_double_underscore_longidents env) b ) + | Lident name -> + begin + match find_double_underscore name with + | None -> l + | Some i -> + let l' = + Ldot + ( Location.mknoloc (Lident (String.sub name 0 i)), + Location.mknoloc + (Unit_info.modulize + (String.sub name (i + 2) + (String.length name - i - 2))) ) + in + begin + match + (Env.find_module_by_name_lazy l env, + Env.find_module_by_name_lazy l' env) + with + | exception Not_found -> l + | (p, _), (p', _) -> + if module_path_is_an_alias_of env p' ~alias_of:p then l' + else l + end + end + +let rec tree_of_path namespace = function + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_pervasive path -> + Oide_ident (Ident_names.pervasives_name namespace s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + Oide_apply (tree_of_path (Some Module) p1, tree_of_path (Some Module) p2) + | 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 + | Punboxed_ty -> + Oide_hash (tree_of_path namespace p) + end + +let tree_of_path namespace = function + | Pident id when Ident.is_instance id -> + (* Only when the instance name is the entire path (which is the only place + a human could write it) is it worth printing the human-writable stopgap + syntax for instance names *) + Oide_ident (instance_name (Ident.to_global_exn id)) + | p -> tree_of_path namespace p + +let tree_of_path namespace p = + tree_of_path 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 + +(* In the [Paths] constructor, more preferred paths are stored later in the + list. *) + +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 Compilation_unit.Name.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 same_printing_env env = + let used_pers = Env.used_persistent () in + Env.same_types !printing_old env + && Compilation_unit.Name.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 -> + (* Jane Street: Often the best choice for printing [p1] is + [p1] itself. And often [p1] is a path whose "penalty" + would be reduced if the double-underscore rewrite + applied. + *) + let rewritten_p1 = rewrite_double_underscore_paths env p1 in + printing_map := Path.Map.add p1 (ref (Paths [ p; rewritten_p1 ])) !printing_map) + env in + printing_cont := [cont]; + end + +(* CR-soon zqian: Currently we immediately backtrack each mutation, which might +cause incoherent types/modes in a single printing. Instead, we should move +backtrack logic into [wrap_printing_env], which is called for each "printing +request". Unfortunately, that seems to interfere with type naming context. The +later is cleaned up in Ocaml 5.3, so we should retry once we merge 5.3. *) +let wrap_mutation f = + let snap = Btype.snapshot () in + try_finally f ~always:(fun () -> Btype.backtrack snap) + +let wrap_printing_env ~reset_names env f = + let old_env = !printing_env in + set_printing_env env; + if reset_names then reset_naming_context (); + try_finally f ~always:(fun () -> set_printing_env old_env) + +let wrap_printing_env ~error env f = + if error then Env.without_cmis (wrap_printing_env ~reset_names:true env) f + else wrap_printing_env ~reset_names:true env f + +and wrap_printing_env_unguarded env f = + wrap_printing_env ~reset_names:false 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 (Location.mknoloc (lid_of_path p1), Location.mknoloc s) + | Path.Papply (p1, p2) -> + Longident.Lapply + (Location.mknoloc (lid_of_path p1), Location.mknoloc (lid_of_path p2)) + | Path.Pextra_ty (p, Pext_ty) -> lid_of_path p + | Path.Pextra_ty (p, Punboxed_ty) -> + match p with + | Pident id -> Longident.Lident (Ident.name id ^ "#") + | Pdot (p, s) -> + Longident.Ldot (Location.mknoloc (lid_of_path p), + Location.mknoloc(s ^ "#")) + | Papply _ | Pextra_ty _ -> assert false + +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 -> Longident.same (lid_of_path p) id) rem && + Path.same p (fst (Env.find_type_by_name id env)) + +let penalty_size = 20 + +let name_penalty s = + if s <> "" && s.[0] = '_' then + penalty_size + else + match find_double_underscore s with + | None -> 2 + | Some _ -> penalty_size + +let ambiguity_penalty path env = + if is_unambiguous path env then 0 else penalty_size + +let path_size path env = + let rec size = function + Pident id -> + name_penalty (Ident.name id), -Ident.scope id + | Pdot (p, id) | Pextra_ty (p, Pcstr_ty id) -> + let (l, b) = size p in (name_penalty id + l, b) + | Papply (p1, p2) -> + let (l, b) = size p1 in + (l + fst (size p2), b) + | Pextra_ty (p, Pext_ty) -> + size p + | Pextra_ty (p, Punboxed_ty) -> + let (l, b) = size p in (1 + l, b) + in + let l, s = size path in + l + ambiguity_penalty path env, s + +let rec get_best_path r env = + 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 env >= path_size p' env -> () + | _ -> r := Best p) + (List.rev l); + get_best_path r env + +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 () = + try + get_best_path (Path.Map.find p' !printing_map) !printing_env + with Not_found -> rewrite_double_underscore_paths !printing_env p' + in + while !printing_cont <> [] && + fst (path_size (get_path ()) !printing_env) > !printing_depth + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth; + done; + let p'' = get_path () in + (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) + (p'', s) + +(* 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 { name = Some name } | Tunivar { name = 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 { name = Some name } | Tunivar { name = 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 _ | Trepr _ -> 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 + +(* Whether to expand [eval] in types for reductions before printing. + Disabled when printing errors, as they usually contain an expansion trace. *) +let print_reduced_evals = ref true + +let out_jkind_of_const_jkind env jkind = + Ojkind_const (Jkind.Const.to_out_jkind_const env jkind) + +(* CR layouts v2.8: This is just like [Jkind.format], and likely needs to + be overhauled with [with]-types. Internal ticket 5096. *) +let rec out_jkind_of_desc env (desc : 'd Jkind.Desc.t) = + match desc.base with + | Layout (Sort (Var n, sa)) -> + Ojkind_var ("'_representable_layout_" ^ + Int.to_string (Jkind.Sort.Var.get_print_number n), + Jkind.Scannable_axes.to_string_list sa) + (* Analyze a product before calling [get_const]: the machinery in + [Jkind.Const.to_out_jkind_const] works better for atomic layouts, not + products. *) + | Layout (Product lays) -> + Ojkind_product + (List.map + (fun layout -> + out_jkind_of_desc env { desc with base = Layout layout }) + lays) + | _ -> match Jkind.Desc.get_const desc with + | Some c -> out_jkind_of_const_jkind env c + | None -> assert false (* handled above *) + +(* returns None for [value], according to (C2.1) from + Note [When to print jkind annotations] *) +(* CR layouts v2.8: This should use the annotation in the jkind, if there + is one. But first that annotation needs to be in Typedtree, not in + Parsetree. Internal ticket 4435. *) +let out_jkind_option_of_jkind ~ignore_null env jkind = + let desc = Jkind.get jkind in + let elide = + Jkind.is_value_for_printing ~ignore_null env jkind (* C2.1 *) + || (match desc.base with + | Layout (Sort (Var _, _)) -> not !Clflags.verbose_types (* X1 *) + | _ -> false) + in + if elide then None else Some (out_jkind_of_desc env desc) + +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 outcome_label : Types.arg_label -> Outcometree.arg_label = function + | Nolabel -> Nolabel + | Labelled l -> Labelled l + | Optional l -> Optional l + | Position l -> Position l + +(** Un-interpret modalities back to outcome tree. Takes the mutability and + attributes on the field and removes mutable-implied modalities + accordingly. *) +let tree_of_modalities mut t = + t + |> Typemode.least_modalities ~include_implied:false ~mut + |> Typemode.sort_dedup_modalities + |> List.map (fun (Atom (ax, m) : Modality.atom) -> + Fmt.asprintf "%a" (Modality.Per_axis.print ax) m) + +let tree_of_modes (modes : Mode.Alloc.Const.t) = + (* Step 1: Compute the modes to print *) + let diff = + + (* [forkable] has implied defaults depending on [areality]: *) + let forkable = + match modes.areality, modes.forkable with + | Local, Unforkable | Global, Forkable -> None + | _, _ -> Some modes.forkable + in + + (* [yielding] has implied defaults depending on [areality]: *) + let yielding = + match modes.areality, modes.yielding with + | Local, Yielding | Global, Unyielding -> None + | _, _ -> Some modes.yielding + in + + (* [contention] has implied defaults based on [visibility]: *) + let contention = + match modes.visibility, modes.contention with + | Immutable, Contended + | Read, Shared + | Write, Corrupted + | Read_write, Uncontended -> None + | _, _ -> Some modes.contention + in + + (* [portability] has implied defaults based on [statefulness]: *) + let portability = + match modes.statefulness, modes.portability with + | Stateless, Portable + | Reading, Shareable + | Writing, Corruptible + | Stateful, Nonportable -> None + | _, _ -> Some modes.portability + in + + let diff = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy in + { diff with forkable; yielding; contention; portability } + in + (* Step 2: Print the modes *) + let print_to_string_opt print a = Option.map (Fmt.asprintf "%a" print) a in + let modes = + [ print_to_string_opt Mode.Locality.Const.print diff.areality + ; print_to_string_opt Mode.Uniqueness.Const.print diff.uniqueness + ; print_to_string_opt Mode.Linearity.Const.print diff.linearity + ; print_to_string_opt Mode.Portability.Const.print diff.portability + ; print_to_string_opt Mode.Contention.Const.print diff.contention + ; print_to_string_opt Mode.Forkable.Const.print diff.forkable + ; print_to_string_opt Mode.Yielding.Const.print diff.yielding + ; print_to_string_opt Mode.Statefulness.Const.print diff.statefulness + ; print_to_string_opt Mode.Visibility.Const.print diff.visibility ] + in + List.filter_map (fun x -> x) modes + +(** The modal context on a type when printing it. This is to reproduce the mode + currying logic in [typetexp.ml], so that parsing and printing roundtrip. *) +type modal = + | Arrow_return of + { acc : Mode.Alloc.Const.t; + mode : Mode.Alloc.lr; } + (** This is the RHS (say [r]) of an arrow type, where [mode] is the real + mode of [r]. and: + - If [r] is also an arrow type, then [acc] is how users would interpret + [r]'s mode, if [r] doesn't have any parens aound it. + - If [r] is not an arrow type, in which case [acc] is meaningless. + + The callee is responsible for printing the type with the modes, with parens + if needed. + + Note that if [r] is an aliased type (e.g., [(int -> 'r) as 'r]), it will be + treated as NOT an arrow type, to align with the currying logic in + [typetexp.ml]. + + If [r] is [Tpoly (Tarrow_, [])], it will be treated as NOT an arrow type. + This gives tedious (but still correct) printing. *) + + | Other of Mode.Alloc.Const.t + (** In other cases, the caller has already printed the modes (as the + constructor argument) on the type. *) + +type typobject_repr = { fields : (string * type_expr) list; open_row : bool } + +type typvariant_repr = { + fields : (string * bool * type_expr list) list; + name : (Path.t * type_expr list) option; + closed : bool; + present : (string * row_field) list; + all_present : bool; + tags : string list option +} + +let rec tree_of_modal_typexp mode modal ty = + let not_arrow tree = + match modal with + | Arrow_return {mode; _} -> + let mode = Alloc.zap_to_legacy mode in + Otyp_ret (Orm_any (tree_of_modes mode), tree) + | Other _ -> tree + in + let ty = + Ctype.reduce_head ~expand_eval:!print_reduced_evals !printing_env ty + in + 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 + not_arrow (Otyp_var (non_gen, name)) else + + let pr_typ alloc_mode = + 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, marg, mret), ty1, ty2, _) -> + let lab = + if !print_labels || is_omittable l then outcome_label l + else Nolabel + in + (* [marg] will contain undetermined axes. It would be imprecise if we + don't print anything for those axes, since user would interpret that + as legacy. The best we can do is to zap to legacy and if they do land + at legacy, we will be able to omit printing them. *) + let arg_mode = Alloc.zap_to_legacy marg in + let t1 = + if is_optional l then + match + get_desc (Ctype.expand_head !printing_env (tpoly_get_mono ty1)) + with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode arg_mode ty + | _ -> Otyp_stuff "" + else + tree_of_typexp mode arg_mode ty1 + in + let acc_mode = curry_mode alloc_mode arg_mode in + let modal = Arrow_return {acc = acc_mode; mode = mret} in + let t2 = tree_of_modal_typexp mode modal ty2 in + Otyp_arrow (lab, tree_of_modes arg_mode, t1, t2) + | Ttuple labeled_tyl -> + Otyp_tuple (tree_of_labeled_typlist mode labeled_tyl) + | Tunboxed_tuple labeled_tyl -> + Otyp_unboxed_tuple (tree_of_labeled_typlist mode labeled_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 Alloc.Const.legacy (List.hd tyl') + else begin + Internal_names.add p'; + Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') + end + | Tvariant row -> + let { fields; name; closed; present; all_present; tags } = + tree_of_typvariant_repr row + in + begin match name with + | Some(p, tyl) when nameable_row row -> + let (p', s) = best_type_path p in + let id = tree_of_path (Some Type) 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 + (fun (l, c, tyl) -> (l, c, tree_of_typlist mode tyl)) fields + in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tquote ty -> + wrap_printing_env_unguarded + (Env.enter_quotation !printing_env) + (fun () -> Otyp_quote (tree_of_typexp mode alloc_mode ty)) + | Tsplice ty -> + wrap_printing_env_unguarded + (Env.enter_splice ~loc:Location.none !printing_env) + (fun () -> Otyp_splice (tree_of_typexp mode alloc_mode ty)) + | Tquote_eval ty -> + let ty = newgenty (Tquote ty) in + let p', s = best_type_path Predef.path_eval in + let tyl = apply_subst s [ty] in + Internal_names.add p'; + let tyl = + wrap_printing_env_unguarded + (Env.enter_quotation !printing_env) + (fun () -> tree_of_typlist mode tyl) + in + Otyp_constr (tree_of_path (Some Type) p', tyl) + | 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, []) | Trepr (ty, []) -> + tree_of_typexp mode alloc_mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + 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 = tree_of_qtvs tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode alloc_mode ty) in + (* Forget names when we leave scope *) + Variable_names.remove_names tyl; + Aliases.delayed := old_delayed; tr + | Trepr (ty, sort_vars) -> + (* Trepr wraps a Tpoly that contains the type variables + corresponding to the sort variables. Extract them and print. *) + (match get_desc ty with + | Tpoly (inner_ty, (_ :: _ as tyl)) -> + (* Check that the sort_vars match the jkinds of tyl *) + let sorts_match = + match + List.for_all2 + (fun sort_var ty -> + match get_desc ty with + | Tunivar { jkind } -> + (match Jkind.get_layout !printing_env jkind with + | Some layout -> + (match Jkind.Layout.Const.get_sort layout with + | Some (Jkind.Sort.Const.Univar uv) -> + uv == sort_var + | _ -> false) + | None -> false) + | _ -> false) + sort_vars tyl + with + | result -> result + | exception Invalid_argument _ -> false + in + if sorts_match then begin + let tyl = List.map Transient_expr.repr tyl in + let old_delayed = !Aliases.delayed in + List.iter Aliases.add_delayed tyl; + let sort_names = tree_of_qsvs tyl in + let tr = + Otyp_repr (sort_names, tree_of_typexp mode alloc_mode inner_ty) + in + Variable_names.remove_names tyl; + Aliases.delayed := old_delayed; + tr + end else + (* Mismatch: print Trepr and Tpoly separately *) + tree_of_typexp mode alloc_mode ty + | _ -> + (* No type variables, just print the body *) + tree_of_typexp mode alloc_mode ty) + | Tunivar _ -> + Otyp_var (false, Variable_names.(name_of_type new_name) tty) + | Tpackage pack -> + let pack = tree_of_package mode pack in + Otyp_module pack + | Tof_kind jkind -> + Otyp_of_kind (out_jkind_of_desc !printing_env (Jkind.get jkind)) + 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 + let tree = + Otyp_alias {non_gen; aliased = pr_typ Mode.Alloc.Const.legacy; alias } + in + not_arrow tree end + else + match modal with + | Arrow_return {acc; mode} -> + let rm, alloc_mode = tree_of_ret_typ_mutating acc mode ty in + let ty = pr_typ alloc_mode in + Otyp_ret (rm, ty) + | Other m -> pr_typ m + +and tree_of_typexp mode alloc_mode ty = + tree_of_modal_typexp mode (Other alloc_mode) ty + +(* qtvs = quantified type variables *) +(* this silently drops any arguments that are not generic Tvar or Tunivar *) +and tree_of_qtvs qtvs = + let tree_of_qtv v : (string * out_jkind option) option = + (* CR layouts: We ignore nullability here to avoid needlessly printing + ['a : value_or_null] when it's not relevant (most cases). + Unfortunately, this makes error messages really confusing, because + we don't consider jkind annotations. *) + let tree jkind = + Some (Variable_names.name_of_type Variable_names.new_name v, + out_jkind_option_of_jkind ~ignore_null:true !printing_env jkind) + in + match v.desc with + | Tvar { jkind } when v.level = generic_level -> tree jkind + | Tunivar { jkind } -> tree jkind + | _ -> None + in + List.filter_map tree_of_qtv qtvs + +(* qsvs = quantified sort variables (for Trepr) *) +(* Extract names from type variables corresponding to sort variables *) +and tree_of_qsvs qtvs = + List.filter_map + (fun v -> + match v.desc with + | Tvar _ when v.level = generic_level -> + Some (Variable_names.name_of_type Variable_names.new_name v) + | Tunivar _ -> Some (Variable_names.name_of_type Variable_names.new_name v) + | _ -> None) + qtvs + +and tree_of_row_field (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tyl) + else (l, false, tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typvariant_repr 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 + let fields = List.map tree_of_row_field fields in + let tags = + if all_present then None else Some (List.map fst present) in + { fields; name; closed; present; all_present; tags } + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode Alloc.Const.legacy) tyl + +and tree_of_labeled_typlist mode tyl = + List.map (fun (label, ty) -> label, tree_of_typexp mode Alloc.Const.legacy ty) tyl + +and tree_of_typ_gf {ca_type=ty; ca_modalities=gf; _} = + (tree_of_typexp Type Alloc.Const.legacy ty, + tree_of_modalities Immutable gf) + +(** NB: This function might mutate states; the caller is responsible for + reverting them. *) +and tree_of_ret_typ_mutating acc_mode m ty= + match get_desc ty with + | Tarrow _ -> begin + (* We first try to equate [m] with the [acc_mode]; if that succeeds, we + can omit parens and modes. *) + match Alloc.equate (Alloc.of_const acc_mode) m with + | Ok () -> + (Orm_no_parens, acc_mode) + | Error _ -> + (* In this branch we need to print parens. [m] might have undetermined + axes and we adopt a similar logic to the [marg] above. *) + let m = Alloc.zap_to_legacy m in + (Orm_parens (tree_of_modes m), m) + end + | _ -> + let m = Alloc.zap_to_legacy m in + (Orm_any (tree_of_modes m), m) + +and tree_of_typobject_repr 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 + let fields, open_row = tree_of_typfields rest sorted_fields in + { fields; open_row } + +and tree_of_typobject mode fi nm = + match nm with + | None -> + let { fields; open_row } = tree_of_typobject_repr fi in + let fields = + List.map + (fun (s, t) -> (s, tree_of_typexp mode Alloc.Const.legacy t)) + fields + 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_path (Some Type) p', args) + | _ -> fatal_error "Out_type.tree_of_typobject" + +and tree_of_typfields rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | field :: l -> + let (fields, rest) = tree_of_typfields rest l in + (field :: fields, rest) + +and tree_of_package mode {pack_path; pack_cstrs} = + { opack_path = tree_of_path (Some Module_type) pack_path; + opack_cstrs = + List.map + (fun (li, ty) -> + (String.concat "." li, tree_of_typexp mode Alloc.Const.legacy ty)) + pack_cstrs } + +let tree_of_typexp mode ty = + (* [tree_of_typexp] mutates state, which we need to backtrack. *) + wrap_mutation (fun () -> tree_of_typexp mode Alloc.Const.legacy ty) + +let tree_of_typexp mode ty = + (* CR metaprogramming jbachurski: Remove this [Env.enter_future] hack once + errors track their stage, as we should usually print at stage 0. + See ticket 6726. *) + if Ctype.contains_toplevel_splice (Env.stage !printing_env :> int) ty + then + wrap_printing_env_unguarded + (Env.enter_future !printing_env) + (fun () -> tree_of_typexp mode ty) + else + tree_of_typexp mode ty + +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 + +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 [None, 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 args = + List.iter prepare_type (tys_of_constr_args args) + +(* returns an empty list if no variables in the list have a jkind annotation *) +let zap_qtvs_if_boring qtvs = + if List.exists (fun (_v, l) -> Option.is_some l) qtvs + then qtvs + else [] + +(* get the free variables with their jkinds; do this *after* converting the + type itself, so that the type names are available. + This implements Case (C3) from Note [When to print jkind annotations]. *) +let extract_qtvs tyl = + let fvs = Ctype.free_non_row_variables_of_list tyl in + (* The [Ctype.free*variables] family of functions returns the free + variables in reverse order they were encountered in the list of types. + *) + let fvs = List.rev fvs in + let tfvs = List.map Transient_expr.repr fvs in + let vars_jkinds = tree_of_qtvs tfvs in + zap_qtvs_if_boring vars_jkinds + +let param_jkind ty = + match get_desc ty with + | Tvar { jkind; _ } | Tunivar { jkind; _ } -> + out_jkind_option_of_jkind ~ignore_null:false !printing_env jkind + | _ -> None (* this is (C2.2) from Note [When to print jkind annotations] *) + +let tree_of_label l = + let mut = + match l.ld_mutable with + | Mutable { mode; atomic } -> + let atomic = + match atomic with + | Atomic -> Atomic + | Nonatomic -> Nonatomic + in + let mut = + let open Value.Comonadic in + match equate mode legacy with + | Ok () -> Om_mutable (None, atomic) + | Error _ -> Om_mutable (Some "", atomic) + in + mut + | Immutable -> Om_immutable + in + let ld_modalities = tree_of_modalities l.ld_mutable l.ld_modalities in + { + olab_name = Ident.name l.ld_id; + olab_mut = mut; + olab_type = tree_of_typexp Type l.ld_type; + olab_modalities = ld_modalities; + } + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> List.map tree_of_typ_gf l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l), [] ] + +let extension_constructor_args_and_ret_type_subtree args ret_type = + match ret_type with + | None -> (tree_of_constructor_arguments args, None) + | Some res -> + let out_ret = tree_of_typexp Type res in + let out_args = tree_of_constructor_arguments args in + let qtvs = extract_qtvs (res :: tys_of_constr_args args) in + (out_args, Some (qtvs, out_ret)) + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let args, ret = + extension_constructor_args_and_ret_type_subtree cd.cd_args cd.cd_res + 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 -> + match get_desc ty with + | Tvar { name = Some "_"; jkind } + when List.exists (eq_type ty) vars -> + set_type_desc ty (Tvar {name = None; jkind}) + | _ -> ()) + 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,_umc) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep,_umc) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_record_unboxed_product(l, _rep,_umc) -> + 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 ot_jkind = + function + | Otyp_var (ot_non_gen, ot_name) -> + {ot_non_gen; ot_name; ot_variance; ot_jkind} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} + 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_record_unboxed_product _ -> + decl.type_private = Private + | Type_variant (tll, _rep,_umc) -> + 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 !Clflags.print_variance || abstr || not is_var then + let inj = + !Clflags.print_variance && Variance.mem Inj v || + 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 + (match co, cn with + | false, false -> Bivariant + | true, false -> Covariant + | false, true -> Contravariant + | true, true -> NoVariance), + (if inj then Injective else NoInjectivity) + else (NoVariance, NoInjectivity)) + decl.type_params decl.type_variance + in + let mk_param ty variance = + let jkind = param_jkind ty in + type_param variance jkind (tree_of_typexp Type ty) + in + (Ident.name id, + List.map2 mk_param 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, or_null_attribute, unsafe_mode_crossing = + match decl.type_kind with + | Type_abstract _ -> + begin match ty_manifest with + | None -> (Otyp_abstract, Public, false, None, false) + | Some ty -> + tree_of_typexp Type ty, decl.type_private, false, None, false + end + | Type_variant (cstrs, rep, umc) -> + let unboxed = + match rep with + | Variant_unboxed -> true + | Variant_boxed _ | Variant_extensible | Variant_with_null -> false + in + let or_null_attribute = + if Builtin_attributes.has_or_null decl.type_attributes then + Some "or_null" + else if Builtin_attributes.has_or_null_reexport decl.type_attributes + then Some "or_null_reexport" + else None + in + tree_of_manifest (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), + decl.type_private, + unboxed, + or_null_attribute, + (Option.is_some umc) + | Type_record(lbls, rep, umc) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private, + (match rep with Record_unboxed -> true | _ -> false), + None, + (Option.is_some umc) + | Type_record_unboxed_product(lbls, Record_unboxed_product, umc) -> + tree_of_manifest + (Otyp_record_unboxed_product (List.map tree_of_label lbls)), + decl.type_private, + false, + None, + (Option.is_some umc) + | Type_open -> + tree_of_manifest Otyp_open, + decl.type_private, + false, + None, + false + in + (* The algorithm for setting [lay] here is described as Case (C1) in + Note [When to print jkind annotations] *) + let is_value = + Jkind.is_value_for_printing ~ignore_null:false !printing_env decl.type_jkind + in + let otype_jkind = + match ty, is_value, unsafe_mode_crossing with + | (Otyp_abstract, false, _) | (_, _, true) -> + (* The two cases of (C1) from the Note correspond to Otyp_abstract. + Anything but the default must be user-written, so we print the + user-written annotation. *) + (* unsafe_mode_crossing corresponds to C1.2 *) + Some (out_jkind_of_desc !printing_env (Jkind.get decl.type_jkind)) + | _ -> None (* other cases have no jkind annotation *) + in + let otype_attributes = + if unsafe_mode_crossing + then [{ oattr_name = "unsafe_allow_any_mode_crossing" }] + else [] + in + { otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_jkind; + otype_unboxed = unboxed; + otype_or_null_attribute = or_null_attribute; + otype_cstrs = constraints; + otype_attributes } + +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 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 + wrap_mutation (fun () -> + let moda = + if Mode.Modality.is_undefined decl.val_modalities then + Mode.Modality.Const.id + else + Ctype.zap_modalities_to_floor_if_modes_enabled_at Alpha + decl.val_modalities + in + let qsvs, qtvs = + (* Important: process the fvs *after* the type; tree_of_type_scheme + resets the naming context. Both must be inside print_with_genvars + so that sort poly var names are registered when jkinds are printed. *) + Jkind_types.Sort.print_with_genvars (Lpoly.get_exn decl.val_lpoly) + (fun names -> names, extract_qtvs [decl.val_type]) + in + let apparent_arity = + let rec count n typ = + match get_desc typ with + | Tarrow (_,_,typ,_) -> count (n+1) typ + | _ -> n + in + count 0 decl.val_type + in + let attrs = + match Zero_alloc.get decl.val_zero_alloc with + | Default_zero_alloc | Ignore_assert_all -> [] + | Check { strict; opt; arity; custom_error_msg; loc = _; } -> + [{ oattr_name = + String.concat "" + ["zero_alloc"; + if strict then " strict" else ""; + if opt then " opt" else ""; + if arity = apparent_arity then "" else + Printf.sprintf " arity %d" arity; + match custom_error_msg with + | None -> "" + | Some msg -> Printf.sprintf " custom_error_message %S" msg + ] }] + | Assume { strict; never_returns_normally; arity; _ } -> + [{ oattr_name = + String.concat "" + ["zero_alloc assume"; + if strict then " strict" else ""; + if never_returns_normally then " never_returns_normally" else ""; + if arity = apparent_arity then "" else + Printf.sprintf " arity %d" arity; + ] + }] + in + let vd = + { oval_name = id; + oval_type = Otyp_newlayout(qsvs, Otyp_poly(qtvs, ty)); + oval_modalities = tree_of_modalities Immutable moda; + oval_prims = []; + oval_attributes = attrs + } + 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 + let tyl = List.map Transient_expr.repr tyl in + let qtvs = tree_of_qtvs tyl in + let qtvs = zap_qtvs_if_boring qtvs in + Variable_names.remove_names tyl; + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, Otyp_poly(qtvs, 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) + || deep_occur_list 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 = Asttypes.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_omittable l then outcome_label l + else Nolabel + in + let tr = + if is_optional l then + match get_desc (Ctype.expand_head !printing_env 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 + (* CR layouts: fix next line when adding support for jkind + annotations on class type parameters *) + let ot_jkind = param_jkind param in + match tree_of_typexp Type_scheme param with + Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance; ot_jkind} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} + +let class_variance = + let open Variance in let open Asttypes in + List.map (fun v -> + let inj = !Clflags.print_variance && Variance.mem Inj v in + (match mem May_pos v, mem May_neg v with + | false, false -> Bivariant + | true, false -> Covariant + | false, true -> Contravariant + | true, true -> NoVariance), + (if inj then Injective else 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) + +let tree_of_jkind_declaration id decl = + let ojkind = + { ojkind_name = Ident.name id + ; ojkind_jkind = + Option.map + (fun jkind -> + jkind |> Jkind.Desc.of_const |> out_jkind_of_desc !printing_env) + decl.jkind_manifest + } + in + Osig_jkind ojkind + +(* 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_jkind = Jkind.Builtin.any ~why:Dummy_jkind; + type_ikind = Types.ikinds_todo "print dummy"; + 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_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + type_unboxed_version = None; + } + +(** 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_jkind (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.is_global_or_predef 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 expand_module_type = + ref ((fun _env _mty -> assert false) : + Env.t -> module_type -> module_type) + +(** How to abbreviate signatures *) +module Abbrev = struct + (* The code is substantially simpler if [width] is mutable. Strictly speaking, [depth] + doesn't have to be mutable here but mixed mutability would be quite confusing. *) + type t = + { (* To what depth to unfold the module tree *) + mutable depth : int + (* How many signature items to print in total across all signatures *) + ; mutable width : int + } + + (** Standard abbreviation heuristic *) + let abbrev () = + { depth = 4 + ; width = 16 + } + + (** Don't print any signature items *) + let ellipsis () = + { depth = 0 + ; width = 0 + } + + (** Should we print anything in this signature *) + let exhausted = function + | Some {depth; width} -> depth <= 0 || width <= 0 + | None -> false + + (** Run [f] at one deeper unfolding level *) + let deeper t f = + match t with + | Some t -> + let saved = t.depth in + t.depth <- t.depth - 1; + let x = f () in + t.depth <- saved; + x + | None -> f () + + (** Reduce the remaining width by the number of items in [sg] and return the number of + items to print in [sg] and a flag that inidicates whether [sg] is being trimmed. *) + let items t sg = + match t with + | Some t -> + let n = List.length sg in + let k = min t.width n in + t.width <- t.width - n; + Some k, (k < n) + | None -> + None, false +end + +let rec tree_of_modtype ?abbrev = function + | Mty_ident p -> + Omty_ident (tree_of_path (Some Module_type) p) + | Mty_signature sg -> + Omty_signature (tree_of_signature ?abbrev sg) + | Mty_functor(param, ty_res, m_res) -> + wrap_mutation (fun () -> + let param, env = + tree_of_functor_parameter ?abbrev param + in + let res = wrap_env env (tree_of_modtype ?abbrev) ty_res in + let mres = m_res |> Mode.Alloc.zap_to_legacy |> tree_of_modes in + Omty_functor (param, res, mres)) + | Mty_alias p -> + Omty_alias (tree_of_path (Some Module) p) + | Mty_strengthen _ as mty -> + begin match !expand_module_type !printing_env mty with + | Mty_strengthen (mty,p,a) -> + let unaliasable = + not (Aliasability.is_aliasable a) + && not (Env.is_functor_arg p !printing_env) + in + Omty_strengthen + (tree_of_modtype ?abbrev mty, tree_of_path (Some Module) p, unaliasable) + | mty -> tree_of_modtype ?abbrev mty + end + +and tree_of_functor_parameter ?abbrev = function + | Unit -> + None, fun k -> k + | Named (param, ty_arg, m_arg) -> + let name, env = + match param with + | None -> None, fun env -> env + | Some id -> + Some (Ident.name id), + fun k -> Env.add_module ~arg:true id Mp_present ty_arg k + in + let marg = m_arg |> Mode.Alloc.zap_to_legacy |> tree_of_modes in + Some (name, tree_of_modtype ?abbrev ty_arg, marg), env + +and tree_of_signature ?abbrev = function + | [] -> [] + | _ when Abbrev.exhausted abbrev -> [Osig_ellipsis] + | sg -> + Abbrev.deeper abbrev (fun () -> + wrap_env (fun env -> env)(fun sg -> + (* Only expand signatures to 'abbrev.depth' depth and print at most 'abbrev.width' + items overall. We just keep decreasing 'abbrev.width' during the traversal but + make sure that we expand the current signature up to 'abbrev.width' before + expanding it's components. Below, 'max_items' is the number of items we should + print in the current signature and 'abbrev.width' is then be the remaining + number of items. This is simpler to implement than proper breadth-first. *) + let max_items, trimmed = Abbrev.items abbrev sg in + let tree_groups = tree_of_signature_rec ?abbrev ?max_items !printing_env sg in + let items = List.concat_map (fun (_env,l) -> List.map snd l) tree_groups in + if trimmed then items @ [Osig_ellipsis] else items + ) sg + ) + +and tree_of_signature_rec ?abbrev ?max_items env' sg = + let structured = List.of_seq (Signature_group.seq sg) in + (* Don't descent into more than 'max_items' (if set) elements to save time. *) + let collect_trees_of_rec_group max_items group = + match max_items with + | Some n when n <= 0 -> (max_items, (!printing_env, [])) + | Some _ | None -> + let env = !printing_env in + let env', group_trees = + Ident_names.with_ctx + (fun () -> trees_of_recursive_sigitem_group ?abbrev env group) + in + set_printing_env env'; + let max_items, group_trees = match max_items with + | None -> None, group_trees + | Some n -> + let rec take n acc xs = + match n, xs with + | 0, _ | _, [] -> n, List.rev acc + | n, x :: xs -> take (n-1) (x :: acc) xs + in + let n, group_trees = take n [] group_trees in + Some n, group_trees + in + max_items, (env, group_trees) + in + set_printing_env env'; + snd (List.fold_left_map collect_trees_of_rec_group max_items structured) + +and trees_of_recursive_sigitem_group ?abbrev env + (syntactic_group: Signature_group.rec_group) = + let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem ?abbrev 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 ?abbrev = 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 abbrev = + if List.exists (function + | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true + | _ -> false) + md.md_attributes + then Some (Abbrev.ellipsis ()) + else abbrev + in + tree_of_module ?abbrev id md rs + | Sig_modtype(id, decl, _) -> + tree_of_modtype_declaration ?abbrev 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 + | Sig_jkind(id, decl, _) -> + tree_of_jkind_declaration id decl + +and tree_of_modtype_declaration ?abbrev id decl = + let mty = + match decl.mtd_type with + | None -> Omty_abstract + | Some mty -> tree_of_modtype ?abbrev mty + in + Osig_modtype (Ident.name id, mty) + +and tree_of_module ?abbrev id md rs = wrap_mutation (fun () -> + let moda = + if Mode.Modality.is_undefined md.md_modalities then + Mode.Modality.Const.id + else + Ctype.zap_modalities_to_floor_if_at_least Alpha md.md_modalities + in + Osig_module (Ident.name id, tree_of_modtype ?abbrev md.md_type, + tree_of_modalities Immutable moda, + 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' + ~var_jkinds mode Errortrace.{ty = t; expanded = t'} = + let tree_of_typexp' ty = + let out = tree_of_typexp mode ty in + if var_jkinds then + match get_desc ty with + | Tvar { jkind; _ } | Tunivar { jkind; _ } -> + let okind = out_jkind_of_desc !printing_env (Jkind.get jkind) in + Otyp_jkind_annot (out, okind) + | _ -> + out + else + out + in + Aliases.reset (); + Aliases.mark_loops t; + if same_path t t' + then begin Aliases.add_delayed (proxy t); Same (tree_of_typexp' 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 *) + print_reduced_evals := false; (* preserve unreduced eval in types *) + let first = tree_of_typexp' t in + print_reduced_evals := true; + let second = tree_of_typexp' t' in + if first = second then Same first + else Diff(first,second) + end + +let trees_of_type_expansion = + trees_of_type_expansion' ~var_jkinds:false + +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) + (Jkind.Builtin.value ~why:Row_variable)))) + | _ -> 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 abbreviate ~abbrev f = + f ?abbrev:(if abbrev then Some (Abbrev.abbrev ()) else None) + +(* let tree_of_path = tree_of_path None *) +let tree_of_module ident ?(ellipsis = false) = + tree_of_module ident ?abbrev:(if ellipsis then Some (Abbrev.ellipsis ()) else None) +let tree_of_signature sg = tree_of_signature sg +let tree_of_modtype ?(abbrev = false) ty = + abbreviate ~abbrev tree_of_modtype ty +let namespaced_tree_of_path n = tree_of_path (Some n) +let tree_of_path p = tree_of_path None p +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_modtype_declaration ?(abbrev = false) id md = + abbreviate ~abbrev tree_of_modtype_declaration id md + +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 () = + try + get_best_path (Path.Map.find p' !printing_map) !printing_env + with Not_found -> rewrite_double_underscore_paths !printing_env p' + in + while !printing_cont <> [] && + fst (path_size (get_path ()) !printing_env) > !printing_depth + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth; + done; + let p'' = get_path () in + (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) + (p'', s) + +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_path p'' diff --git a/upstream/ocaml_flambda/typing/out_type.mli b/upstream/ocaml_flambda/typing/out_type.mli new file mode 100644 index 000000000..1c9a2a70d --- /dev/null +++ b/upstream/ocaml_flambda/typing/out_type.mli @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* 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: 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 tree_of_type_scheme: type_expr -> out_type + +val tree_of_modalities: + Types.mutability -> Mode.Modality.Const.t -> Outcometree.out_mode list + + +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 trees_of_type_expansion': + var_jkinds:bool -> 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 * out_modality list) 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 * out_modality list) list * (out_vars_jkinds * out_type) option +val add_extension_constructor_to_preparation : + extension_constructor -> unit +val prepared_extension_constructor: + Ident.t -> extension_constructor printer + + +val rewrite_double_underscore_longidents: Env.t -> Longident.t -> Longident.t + +(** {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: + ?abbrev:bool -> 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 + +val tree_of_jkind_declaration: + Ident.t -> jkind_declaration -> out_sig_item + +(** {1 Module types }*) + +val tree_of_module: + Ident.t -> ?ellipsis:bool -> module_declaration -> rec_status -> + out_sig_item +val tree_of_modtype: ?abbrev:bool -> 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 + +val expand_module_type: (Env.t -> module_type -> module_type) ref +(* Forward declaration to be filled in Mtype. We want to be able to print types + in Mtype for debugging purposes and hence don't want to depend on Mtype + here. *) + +(** {1 For [Translquote] *) +type typobject_repr = { fields : (string * type_expr) list; open_row : bool } +type typvariant_repr = { + fields : (string * bool * type_expr list) list; + name : (Path.t * type_expr list) option; + closed : bool; + present : (string * row_field) list; + all_present : bool; + tags : string list option +} +val tree_of_typobject_repr : type_expr -> typobject_repr +val tree_of_typvariant_repr : row_desc -> typvariant_repr + +(** {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 + + val reset: unit -> unit +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_flambda/typing/outcometree.mli b/upstream/ocaml_flambda/typing/outcometree.mli index 1fd27cbdd..9aae14f04 100644 --- a/upstream/ocaml_flambda/typing/outcometree.mli +++ b/upstream/ocaml_flambda/typing/outcometree.mli @@ -63,6 +63,7 @@ type out_value = | Oval_variant of string * out_value option | Oval_lazy of out_value | Oval_code of CamlinternalQuote.Code.t + | Oval_floatarray of floatarray type out_modality = string @@ -74,8 +75,6 @@ type out_mutability = | Om_immutable | Om_mutable of string option * out_atomicity - - (** This definition avoids a cyclic dependency between Outcometree and Types. *) type arg_label = | Nolabel @@ -134,11 +133,8 @@ and 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 * out_mutability * out_type * out_modality list) list - | Otyp_record_unboxed_product of - (string * out_mutability * out_type * out_modality list) list - (* INVARIANT: [out_mutability] is included for uniformity with [Otyp_record], - but it is always [Omm_immutable] *) + | Otyp_record of out_label list + | Otyp_record_unboxed_product of out_label list | Otyp_stuff of string | Otyp_sum of out_constructor list | Otyp_tuple of (string option * out_type) list @@ -150,7 +146,7 @@ and out_type = | Otyp_poly of out_vars_jkinds * out_type | Otyp_repr of string list * out_type | Otyp_newlayout of out_sort_genvar list * out_type - | Otyp_module of out_ident * (string * out_type) list + | Otyp_module of out_package | Otyp_attribute of out_type * out_attribute | Otyp_jkind_annot of out_type * out_jkind (* Currently only introduced with very explicit code in [Printtyp] and not @@ -159,12 +155,24 @@ and out_type = | Otyp_ret of out_ret_mode * out_type (** INVARIANT: See [out_ret_mode]. *) +and out_label = { + olab_name: string; + olab_mut: out_mutability; + olab_type: out_type; + olab_modalities: out_modality list; +} + and out_constructor = { ocstr_name: string; ocstr_args: (out_type * out_modality list) list; ocstr_return_type: (out_vars_jkinds * out_type) option; } +and out_package = { + opack_path: out_ident; + opack_cstrs: (string * out_type) list; +} + and out_variant = | Ovar_fields of (string * bool * out_type list) list | Ovar_typ of out_type diff --git a/upstream/ocaml_flambda/typing/parmatch.ml b/upstream/ocaml_flambda/typing/parmatch.ml index 3c3098718..454f0fafd 100644 --- a/upstream/ocaml_flambda/typing/parmatch.ml +++ b/upstream/ocaml_flambda/typing/parmatch.ml @@ -18,6 +18,7 @@ open Misc open Asttypes open Types +open Data_types open Typedtree type error = Float32_match @@ -348,8 +349,8 @@ let records_args l1 l2 = module Compat (Constr:sig val equal : - Types.constructor_description -> - Types.constructor_description -> + Data_types.constructor_description -> + Data_types.constructor_description -> bool end) = struct @@ -412,12 +413,13 @@ module Compat Option.equal String.equal p_label q_label && compat p q && unboxed_tuple_compat labeled_ps labeled_qs | _,_ -> false + end module SyntacticCompat = Compat (struct - let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag + let equal = Data_types.equal_constr end) let compat = SyntacticCompat.compat @@ -452,7 +454,7 @@ 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 + Data_types.equal_constr c1 c2 | Variant { tag = t1; _ }, Variant { tag = t2 } -> t1 = t2 | Constant c1, Constant c2 -> const_compare c1 c2 = 0 @@ -613,13 +615,11 @@ 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 -| {pat_desc = Tpat_tuple omegas} -> - let args,rest = read_args (List.map snd omegas) r in - make_pat - (Tpat_tuple - (List.map2 (fun (lbl, _) arg -> lbl, arg) omegas args)) - q.pat_type q.pat_env::rest +let set_args q r = match q with +| {pat_desc = Tpat_tuple lbls_omegas} -> + let lbls, omegas = List.split lbls_omegas in + let args, rest = read_args omegas r in + make_pat (Tpat_tuple (List.combine lbls args)) q.pat_type q.pat_env :: rest | {pat_desc = Tpat_unboxed_tuple omegas} -> let args,rest = read_args (List.map (fun (_, pat, _) -> pat) omegas) r @@ -627,33 +627,18 @@ let do_set_args ~erase_mutable q r = match q with make_pat (Tpat_unboxed_tuple (List.map2 (fun (lbl, _, sort) arg -> lbl, arg, sort) omegas args)) - q.pat_type q.pat_env::rest + 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 && Types.is_mutable lbl.lbl_mut - 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_record_unboxed_product (omegas,closed)} -> let args,rest = read_args omegas r in - make_pat - (Tpat_record_unboxed_product - (List.map2 (fun (lid, lbl,_) arg -> - if Types.is_mutable lbl.lbl_mut then - fatal_error - "Parmatch.do_set_args: unboxed record labels are never mutable" - 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_unboxed_product (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 @@ -678,19 +663,14 @@ let do_set_args ~erase_mutable q r = match q with end | {pat_desc = Tpat_array (am, arg_sort, omegas)} -> let args,rest = read_args omegas r in - let args = if erase_mutable then omegas else args in make_pat - (Tpat_array (am, arg_sort, args)) q.pat_type q.pat_env:: - rest + (Tpat_array (am, arg_sort, args)) q.pat_type q.pat_env :: rest | {pat_desc=Tpat_constant _|Tpat_any|Tpat_unboxed_unit|Tpat_unboxed_bool _} -> q::r (* case any is used in matching.ml *) | {pat_desc = (Tpat_var _ | Tpat_fun_layout _ | 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... @@ -1501,8 +1481,8 @@ let print_pat pat = Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) | Tpat_variant (_, _, _) -> "variant" | Tpat_record (_, _) -> "record" - | Tpat_array _ -> "array" - | Tpat_immutable_array _ -> "immutable array" + | Tpat_array (Mutable, _) -> "array" + | Tpat_array (Immutable, _) -> "immutable array" in Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) *) @@ -1935,7 +1915,7 @@ let rec le_pat p q = | _, Tpat_alias { pattern = 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 + Data_types.equal_constr c1 c2 && 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,_) -> @@ -2009,7 +1989,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with 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 -> + when Data_types.equal_constr c1 c2 -> let rs = lubs ps1 ps2 in make_pat (Tpat_construct (lid, c1, rs, None)) p.pat_type p.pat_env @@ -2022,8 +2002,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with 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 + make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env | Tpat_array (am1, arg_sort, ps), Tpat_array (am2, _, qs) when am1 = am2 && List.length ps = List.length qs -> let rs = lubs ps qs in @@ -2161,27 +2140,27 @@ let do_check_partial ~pred loc casel pss = match pss with match counter_examples () with | Seq.Nil -> Total | 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.Compat.pretty_pat v; + if Warnings.is_active (Warnings.Partial_match Format_doc.Doc.empty) then + begin + let errmsg = + let doc = ref Format_doc.Doc.empty in + let fmt = Format_doc.formatter doc in + Format_doc.fprintf fmt "@[%a" + (Misc.Style.as_inline_code Printpat.top_pretty) v; if do_match (initial_only_guarded casel) [v] then - Buffer.add_string buf - "\n(However, some guarded clause may match this value.)"; + Format_doc.fprintf fmt + "@,(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." + 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.@]" ; - Buffer.contents buf - with _ -> - "" - in - Location.prerr_warning loc (Warnings.Partial_match errmsg) - end; + Format_doc.fprintf fmt "@]"; + !doc + in + Location.prerr_warning loc (Warnings.Partial_match errmsg) + end; Partial (*****************) diff --git a/upstream/ocaml_flambda/typing/parmatch.mli b/upstream/ocaml_flambda/typing/parmatch.mli index 6ac2ac4bc..b28a5670c 100644 --- a/upstream/ocaml_flambda/typing/parmatch.mli +++ b/upstream/ocaml_flambda/typing/parmatch.mli @@ -18,6 +18,7 @@ open Asttypes open Typedtree open Types +open Data_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 @@ -55,8 +56,8 @@ module Compat : functor (_ : sig val equal : - Types.constructor_description -> - Types.constructor_description -> + Data_types.constructor_description -> + Data_types.constructor_description -> bool end) -> sig val compat : pattern -> pattern -> bool @@ -75,13 +76,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/upstream/ocaml_flambda/typing/path.ml b/upstream/ocaml_flambda/typing/path.ml index dda19ce59..96b71328b 100644 --- a/upstream/ocaml_flambda/typing/path.ml +++ b/upstream/ocaml_flambda/typing/path.ml @@ -160,6 +160,10 @@ let flatten = in fun t -> flatten [] t +let rec scrape_extra_ty = function + | Pextra_ty (t, _) -> scrape_extra_ty t + | t -> t + let heads p = let rec heads p acc = match p with | Pident id -> id :: acc diff --git a/upstream/ocaml_flambda/typing/path.mli b/upstream/ocaml_flambda/typing/path.mli index b62ae3f2e..e9a05d495 100644 --- a/upstream/ocaml_flambda/typing/path.mli +++ b/upstream/ocaml_flambda/typing/path.mli @@ -73,6 +73,9 @@ val exists_free: Ident.t list -> t -> bool val scope: t -> int val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ] +val scrape_extra_ty: t -> t +(** Removes surrounding `Pext_ty` constructors from a path *) + val name: ?paren:(string -> bool) -> t -> string (* [paren] tells whether a path suffix needs parentheses *) val head: t -> Ident.t diff --git a/upstream/ocaml_flambda/typing/patterns.ml b/upstream/ocaml_flambda/typing/patterns.ml index 05fdb413c..69de86d35 100644 --- a/upstream/ocaml_flambda/typing/patterns.ml +++ b/upstream/ocaml_flambda/typing/patterns.ml @@ -16,6 +16,7 @@ open Asttypes open Types +open Data_types open Typedtree (* useful pattern auxiliary functions *) diff --git a/upstream/ocaml_flambda/typing/patterns.mli b/upstream/ocaml_flambda/typing/patterns.mli index ffa0ce531..4090273eb 100644 --- a/upstream/ocaml_flambda/typing/patterns.mli +++ b/upstream/ocaml_flambda/typing/patterns.mli @@ -17,6 +17,7 @@ open Asttypes open Typedtree open Types +open Data_types val omega : pattern (** aka. "Tpat_any" or "_" *) diff --git a/upstream/ocaml_flambda/typing/predef.ml b/upstream/ocaml_flambda/typing/predef.ml index 444bf3998..11fe9086d 100644 --- a/upstream/ocaml_flambda/typing/predef.ml +++ b/upstream/ocaml_flambda/typing/predef.ml @@ -33,6 +33,143 @@ let wrap create s = in `lambda.ml`). *) let ident_create = wrap Ident.create_predef +type abstract_type_constr = [ + | `Int + | `Char + | `String + | `Bytes + | `Float + | `Continuation + | `Array + | `Nativeint + | `Int32 + | `Int64 + | `Lazy_t + | `Extension_constructor + | `Floatarray + | `Iarray + | `Atomic_loc + | `Lexing_position + | `Code + | `Float32 + | `Int8 + | `Int16 +] +type abstract_non_value_type_constr = [ + | `Idx_imm + | `Idx_mut + | `Int8x16 + | `Int16x8 + | `Int32x4 + | `Int64x2 + | `Float16x8 + | `Float32x4 + | `Float64x2 + | `Int8x32 + | `Int16x16 + | `Int32x8 + | `Int64x4 + | `Float16x16 + | `Float32x8 + | `Float64x4 + | `Int8x64 + | `Int16x32 + | `Int32x16 + | `Int64x8 + | `Float16x32 + | `Float32x16 + | `Float64x8 +] +type data_type_constr = [ + | `Bool + | `Unit + | `Exn + | `Eff + | `List + | `Option + | `Or_null +] +type type_constr = [ + | abstract_type_constr + | abstract_non_value_type_constr + | data_type_constr +] + +let base_type_constrs : type_constr list = [ + `Int; + `Char; + `String; + `Bytes; + `Float; + `Bool; + `Unit; + `Exn; + `Eff; + `Continuation; + `Array; + `List; + `Option; + `Nativeint; + `Int32; + `Int64; + `Lazy_t; + `Extension_constructor; + `Floatarray; + `Iarray; + `Atomic_loc; + `Lexing_position; + `Idx_imm; + `Idx_mut; +] + +let or_null_extension_type_constrs : type_constr list = [ + `Or_null; +] + +let simd_stable_extension_type_constrs : type_constr list = [ + `Int8x16; + `Int16x8; + `Int32x4; + `Int64x2; + `Float16x8; + `Float32x4; + `Float64x2; + `Int8x32; + `Int16x16; + `Int32x8; + `Int64x4; + `Float16x16; + `Float32x8; + `Float64x4; +] + +let simd_beta_extension_type_constrs : type_constr list = [] + +let simd_alpha_extension_type_constrs : type_constr list = [ + `Int8x64; + `Int16x32; + `Int32x16; + `Int64x8; + `Float16x32; + `Float32x16; + `Float64x8; +] + +let small_number_extension_type_constrs : type_constr list = [ + `Float32; + `Int8; + `Int16; +] + +let all_type_constrs = ( + base_type_constrs + @ or_null_extension_type_constrs + @ small_number_extension_type_constrs + @ simd_stable_extension_type_constrs + @ simd_beta_extension_type_constrs + @ simd_alpha_extension_type_constrs +) + let ident_int = ident_create "int" and ident_char = ident_create "char" and ident_bytes = ident_create "bytes" @@ -41,8 +178,9 @@ and ident_float32 = ident_create "float32" 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_iarray = ident_create "iarray" and ident_list = ident_create "list" and ident_option = ident_create "option" and ident_nativeint = ident_create "nativeint" @@ -54,8 +192,9 @@ 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" -and ident_lexing_position = ident_create "lexing_position" +and ident_iarray = ident_create "iarray" and ident_atomic_loc = ident_create "atomic_loc" +and ident_lexing_position = ident_create "lexing_position" (* CR metaprogramming aivaskovic: there is a question about naming; keep `expr` for now instead of `code` *) and ident_code = ident_create "expr" @@ -87,6 +226,58 @@ and ident_float16x32 = ident_create "float16x32" and ident_float32x16 = ident_create "float32x16" and ident_float64x8 = ident_create "float64x8" +let ident_of_type_constr : type_constr -> Ident.t = function + | `Int -> ident_int + | `Char -> ident_char + | `String -> ident_string + | `Bytes -> ident_bytes + | `Float -> ident_float + | `Bool -> ident_bool + | `Unit -> ident_unit + | `Exn -> ident_exn + | `Eff -> ident_eff + | `Continuation -> ident_continuation + | `Array -> ident_array + | `List -> ident_list + | `Option -> ident_option + | `Nativeint -> ident_nativeint + | `Int32 -> ident_int32 + | `Int64 -> ident_int64 + | `Lazy_t -> ident_lazy_t + | `Extension_constructor -> ident_extension_constructor + | `Floatarray -> ident_floatarray + | `Iarray -> ident_iarray + | `Atomic_loc -> ident_atomic_loc + | `Lexing_position -> ident_lexing_position + | `Code -> ident_code + | `Float32 -> ident_float32 + | `Int8 -> ident_int8 + | `Int16 -> ident_int16 + | `Idx_imm -> ident_idx_imm + | `Idx_mut -> ident_idx_mut + | `Int8x16 -> ident_int8x16 + | `Int16x8 -> ident_int16x8 + | `Int32x4 -> ident_int32x4 + | `Int64x2 -> ident_int64x2 + | `Float16x8 -> ident_float16x8 + | `Float32x4 -> ident_float32x4 + | `Float64x2 -> ident_float64x2 + | `Int8x32 -> ident_int8x32 + | `Int16x16 -> ident_int16x16 + | `Int32x8 -> ident_int32x8 + | `Int64x4 -> ident_int64x4 + | `Float16x16 -> ident_float16x16 + | `Float32x8 -> ident_float32x8 + | `Float64x4 -> ident_float64x4 + | `Int8x64 -> ident_int8x64 + | `Int16x32 -> ident_int16x32 + | `Int32x16 -> ident_int32x16 + | `Int64x8 -> ident_int64x8 + | `Float16x32 -> ident_float16x32 + | `Float32x16 -> ident_float32x16 + | `Float64x8 -> ident_float64x8 + | `Or_null -> ident_or_null + let path_int = Pident ident_int and path_char = Pident ident_char and path_bytes = Pident ident_bytes @@ -95,8 +286,9 @@ and path_float32 = Pident ident_float32 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_iarray = Pident ident_iarray and path_list = Pident ident_list and path_option = Pident ident_option and path_nativeint = Pident ident_nativeint @@ -108,10 +300,11 @@ 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 +and path_iarray = Pident ident_iarray +and path_atomic_loc = Pident ident_atomic_loc and path_lexing_position = Pident ident_lexing_position and path_idx_imm = Pident ident_idx_imm and path_idx_mut = Pident ident_idx_mut -and path_atomic_loc = Pident ident_atomic_loc and path_code = Pident ident_code and path_eval = Pident ident_eval @@ -173,113 +366,104 @@ and path_unboxed_float16x32 = Path.unboxed_version path_float16x32 and path_unboxed_float32x16 = Path.unboxed_version path_float32x16 and path_unboxed_float64x8 = Path.unboxed_version path_float64x8 -let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) -and type_int8 = newgenty (Tconstr(path_int8, [], ref Mnil)) -and type_int16 = newgenty (Tconstr(path_int16, [], 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_float32 = newgenty (Tconstr(path_float32, [], 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_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) -and type_iarray t = newgenty (Tconstr(path_iarray, [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)) -and type_lexing_position = newgenty (Tconstr(path_lexing_position, [], ref Mnil)) -and type_atomic_loc t = newgenty (Tconstr(path_atomic_loc, [t], ref Mnil)) -and type_code t = newgenty (Tconstr(path_code, [t], ref Mnil)) +let path_of_type_constr typ = + Pident (ident_of_type_constr typ) + +let tconstr p args = newgenty (Tconstr(p, args, ref Mnil)) +let type_int = tconstr path_int [] +and type_int8 = tconstr path_int8 [] +and type_int16 = tconstr path_int16 [] +and type_char = tconstr path_char [] +and type_bytes = tconstr path_bytes [] +and type_float = tconstr path_float [] +and type_float32 = tconstr path_float32 [] +and type_bool = tconstr path_bool [] +and type_unit = tconstr path_unit [] +and type_exn = tconstr path_exn [] +and type_eff t = tconstr path_eff [t] +and type_continuation t1 t2 = tconstr path_continuation [t1; t2] +and type_array t = tconstr path_array [t] +and type_list t = tconstr path_list [t] +and type_option t = tconstr path_option [t] +and type_nativeint = tconstr path_nativeint [] +and type_int32 = tconstr path_int32 [] +and type_int64 = tconstr path_int64 [] +and type_lazy_t t = tconstr path_lazy_t [t] +and type_string = tconstr path_string [] +and type_extension_constructor = tconstr path_extension_constructor [] +and type_floatarray = tconstr path_floatarray [] +and type_iarray t = tconstr path_iarray [t] +and type_atomic_loc t = tconstr path_atomic_loc [t] +and type_lexing_position = tconstr path_lexing_position [] +and type_code t = tconstr path_code [t] and type_eval t = newgenty (Tquote_eval (newgenty (Tsplice t))) -and type_unboxed_unit = newgenty (Tconstr(path_unboxed_unit, [], ref Mnil)) -and type_unboxed_bool = newgenty (Tconstr(path_unboxed_bool, [], ref Mnil)) -and type_unboxed_float = newgenty (Tconstr(path_unboxed_float, [], ref Mnil)) -and type_unboxed_float32 = newgenty (Tconstr(path_unboxed_float32, [], ref Mnil)) -and type_unboxed_nativeint = - newgenty (Tconstr(path_unboxed_nativeint, [], ref Mnil)) -and type_unboxed_int32 = newgenty (Tconstr(path_unboxed_int32, [], ref Mnil)) -and type_unboxed_int64 = newgenty (Tconstr(path_unboxed_int64, [], ref Mnil)) -and type_unboxed_char = newgenty (Tconstr(path_unboxed_char, [], ref Mnil)) -and type_unboxed_int = newgenty (Tconstr(path_unboxed_int, [], ref Mnil)) -and type_unboxed_int8 = newgenty (Tconstr(path_unboxed_int8, [], ref Mnil)) -and type_unboxed_int16 = newgenty (Tconstr(path_unboxed_int16, [], ref Mnil)) -and type_or_null t = newgenty (Tconstr(path_or_null, [t], ref Mnil)) -and type_idx_imm t1 t2 = newgenty (Tconstr(path_idx_imm, [t1; t2], ref Mnil)) -and type_idx_mut t1 t2 = newgenty (Tconstr(path_idx_mut, [t1; t2], ref Mnil)) - -and type_int8x16 = newgenty (Tconstr(path_int8x16, [], ref Mnil)) -and type_int16x8 = newgenty (Tconstr(path_int16x8, [], ref Mnil)) -and type_int32x4 = newgenty (Tconstr(path_int32x4, [], ref Mnil)) -and type_int64x2 = newgenty (Tconstr(path_int64x2, [], ref Mnil)) -and type_float16x8 = newgenty (Tconstr(path_float16x8, [], ref Mnil)) -and type_float32x4 = newgenty (Tconstr(path_float32x4, [], ref Mnil)) -and type_float64x2 = newgenty (Tconstr(path_float64x2, [], ref Mnil)) -and type_int8x32 = newgenty (Tconstr(path_int8x32, [], ref Mnil)) -and type_int16x16 = newgenty (Tconstr(path_int16x16, [], ref Mnil)) -and type_int32x8 = newgenty (Tconstr(path_int32x8, [], ref Mnil)) -and type_int64x4 = newgenty (Tconstr(path_int64x4, [], ref Mnil)) -and type_float16x16 = newgenty (Tconstr(path_float16x16, [], ref Mnil)) -and type_float32x8 = newgenty (Tconstr(path_float32x8, [], ref Mnil)) -and type_float64x4 = newgenty (Tconstr(path_float64x4, [], ref Mnil)) -and type_int8x64 = newgenty (Tconstr(path_int8x64, [], ref Mnil)) -and type_int16x32 = newgenty (Tconstr(path_int16x32, [], ref Mnil)) -and type_int32x16 = newgenty (Tconstr(path_int32x16, [], ref Mnil)) -and type_int64x8 = newgenty (Tconstr(path_int64x8, [], ref Mnil)) -and type_float16x32 = newgenty (Tconstr(path_float16x32, [], ref Mnil)) -and type_float32x16 = newgenty (Tconstr(path_float32x16, [], ref Mnil)) -and type_float64x8 = newgenty (Tconstr(path_float64x8, [], ref Mnil)) - -and type_unboxed_int8x16 = - newgenty (Tconstr(path_unboxed_int8x16, [], ref Mnil)) -and type_unboxed_int16x8 = - newgenty (Tconstr(path_unboxed_int16x8, [], ref Mnil)) -and type_unboxed_int32x4 = - newgenty (Tconstr(path_unboxed_int32x4, [], ref Mnil)) -and type_unboxed_int64x2 = - newgenty (Tconstr(path_unboxed_int64x2, [], ref Mnil)) -and type_unboxed_float16x8 = - newgenty (Tconstr(path_unboxed_float16x8, [], ref Mnil)) -and type_unboxed_float32x4 = - newgenty (Tconstr(path_unboxed_float32x4, [], ref Mnil)) -and type_unboxed_float64x2 = - newgenty (Tconstr(path_unboxed_float64x2, [], ref Mnil)) -and type_unboxed_int8x32 = - newgenty (Tconstr(path_unboxed_int8x32, [], ref Mnil)) -and type_unboxed_int16x16 = - newgenty (Tconstr(path_unboxed_int16x16, [], ref Mnil)) -and type_unboxed_int32x8 = - newgenty (Tconstr(path_unboxed_int32x8, [], ref Mnil)) -and type_unboxed_int64x4 = - newgenty (Tconstr(path_unboxed_int64x4, [], ref Mnil)) -and type_unboxed_float16x16 = - newgenty (Tconstr(path_unboxed_float16x16, [], ref Mnil)) -and type_unboxed_float32x8 = - newgenty (Tconstr(path_unboxed_float32x8, [], ref Mnil)) -and type_unboxed_float64x4 = - newgenty (Tconstr(path_unboxed_float64x4, [], ref Mnil)) -and type_unboxed_int8x64 = - newgenty (Tconstr(path_unboxed_int8x64, [], ref Mnil)) -and type_unboxed_int16x32 = - newgenty (Tconstr(path_unboxed_int16x32, [], ref Mnil)) -and type_unboxed_int32x16 = - newgenty (Tconstr(path_unboxed_int32x16, [], ref Mnil)) -and type_unboxed_int64x8 = - newgenty (Tconstr(path_unboxed_int64x8, [], ref Mnil)) -and type_unboxed_float16x32 = - newgenty (Tconstr(path_unboxed_float16x32, [], ref Mnil)) -and type_unboxed_float32x16 = - newgenty (Tconstr(path_unboxed_float32x16, [], ref Mnil)) -and type_unboxed_float64x8 = - newgenty (Tconstr(path_unboxed_float64x8, [], ref Mnil)) +and type_unboxed_unit = tconstr path_unboxed_unit [] +and type_unboxed_bool = tconstr path_unboxed_bool [] +and type_unboxed_float = tconstr path_unboxed_float [] +and type_unboxed_float32 = tconstr path_unboxed_float32 [] +and type_unboxed_nativeint = tconstr path_unboxed_nativeint [] +and type_unboxed_int32 = tconstr path_unboxed_int32 [] +and type_unboxed_int64 = tconstr path_unboxed_int64 [] +and type_unboxed_char = tconstr path_unboxed_char [] +and type_unboxed_int = tconstr path_unboxed_int [] +and type_unboxed_int8 = tconstr path_unboxed_int8 [] +and type_unboxed_int16 = tconstr path_unboxed_int16 [] +and type_or_null t = tconstr path_or_null [t] +and type_idx_imm t1 t2 = tconstr path_idx_imm [t1; t2] +and type_idx_mut t1 t2 = tconstr path_idx_mut [t1; t2] + +and type_int8x16 = tconstr path_int8x16 [] +and type_int16x8 = tconstr path_int16x8 [] +and type_int32x4 = tconstr path_int32x4 [] +and type_int64x2 = tconstr path_int64x2 [] +and type_float16x8 = tconstr path_float16x8 [] +and type_float32x4 = tconstr path_float32x4 [] +and type_float64x2 = tconstr path_float64x2 [] +and type_int8x32 = tconstr path_int8x32 [] +and type_int16x16 = tconstr path_int16x16 [] +and type_int32x8 = tconstr path_int32x8 [] +and type_int64x4 = tconstr path_int64x4 [] +and type_float16x16 = tconstr path_float16x16 [] +and type_float32x8 = tconstr path_float32x8 [] +and type_float64x4 = tconstr path_float64x4 [] +and type_int8x64 = tconstr path_int8x64 [] +and type_int16x32 = tconstr path_int16x32 [] +and type_int32x16 = tconstr path_int32x16 [] +and type_int64x8 = tconstr path_int64x8 [] +and type_float16x32 = tconstr path_float16x32 [] +and type_float32x16 = tconstr path_float32x16 [] +and type_float64x8 = tconstr path_float64x8 [] + +and type_unboxed_int8x16 = tconstr path_unboxed_int8x16 [] +and type_unboxed_int16x8 = tconstr path_unboxed_int16x8 [] +and type_unboxed_int32x4 = tconstr path_unboxed_int32x4 [] +and type_unboxed_int64x2 = tconstr path_unboxed_int64x2 [] +and type_unboxed_float16x8 = tconstr path_unboxed_float16x8 [] +and type_unboxed_float32x4 = tconstr path_unboxed_float32x4 [] +and type_unboxed_float64x2 = tconstr path_unboxed_float64x2 [] +and type_unboxed_int8x32 = tconstr path_unboxed_int8x32 [] +and type_unboxed_int16x16 = tconstr path_unboxed_int16x16 [] +and type_unboxed_int32x8 = tconstr path_unboxed_int32x8 [] +and type_unboxed_int64x4 = tconstr path_unboxed_int64x4 [] +and type_unboxed_float16x16 = tconstr path_unboxed_float16x16 [] +and type_unboxed_float32x8 = tconstr path_unboxed_float32x8 [] +and type_unboxed_float64x4 = tconstr path_unboxed_float64x4 [] +and type_unboxed_int8x64 = tconstr path_unboxed_int8x64 [] +and type_unboxed_int16x32 = tconstr path_unboxed_int16x32 [] +and type_unboxed_int32x16 = tconstr path_unboxed_int32x16 [] +and type_unboxed_int64x8 = tconstr path_unboxed_int64x8 [] +and type_unboxed_float16x32 = tconstr path_unboxed_float16x32 [] +and type_unboxed_float32x16 = tconstr path_unboxed_float32x16 [] +and type_unboxed_float64x8 = tconstr path_unboxed_float64x8 [] + +let find_type_constr = + let all_predef_paths = + all_type_constrs + |> List.map (fun tconstr -> path_of_type_constr tconstr, tconstr) + |> Path.Map.of_list + in + fun p -> Path.Map.find_opt p all_predef_paths let ident_match_failure = ident_create "Match_failure" and ident_out_of_memory = ident_create "Out_of_memory" @@ -295,6 +479,7 @@ 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; @@ -310,6 +495,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 @@ -317,16 +503,6 @@ and path_invalid_argument = Pident ident_invalid_argument 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 "()" @@ -342,6 +518,24 @@ let option_argument_sort = Jkind_types.Sort.Const.scannable let option_argument_jkind = Jkind.Builtin.value_or_null ~why:( Type_argument {parent_path = path_option; position = 1; arity = 1}) +let unrestricted tvar ca_sort = + { + ca_type=tvar; + ca_sort; + ca_modalities=Mode.Modality.Const.id; + ca_loc=Location.none + } + +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 list_jkind param = Jkind.Builtin.immutable_data ~why:Boxed_variant |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param |> @@ -374,14 +568,30 @@ let add_predef_jkinds add_jkind env = List.fold_left (fun env (id, jkind) -> add_jkind id jkind env) env predef_jkinds -let mk_add_type add_type = - let add_type_with_jkind - ?manifest type_ident - ?(kind=Type_abstract Definition) - ~jkind - ?unboxed_jkind - env = - let type_uid = Uid.of_predef_id type_ident in + +let or_null_argument_sort = Jkind_types.Sort.Const.scannable + +let or_null_jkind param = + Jkind.Const.Builtin.value_or_null_mod_everything + |> Jkind.of_builtin ~why:(Primitive ident_or_null) + |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param + |> Jkind.mark_best + +let or_null_kind tvar = + let cstrs = + [ cstr ident_null []; + cstr ident_this [unrestricted tvar or_null_argument_sort]] in + Type_variant (cstrs, Variant_with_null, None) + +let decl_of_type_constr tconstr = + let type_ident = ident_of_type_constr tconstr in + let type_uid = Uid.of_predef_id type_ident in + let decl0 + ?(kind = Type_abstract Definition) + ~(jkind : jkind_l) + ?(unboxed_jkind : Jkind.Const.Builtin.t option) + () + = let type_unboxed_version = match unboxed_jkind with | None -> None | Some unboxed_jkind -> @@ -394,12 +604,6 @@ let mk_add_type add_type = abstract, as they are special cased. Other unboxed versions are automatically derived. *) let type_kind = Type_abstract Definition in - let type_manifest = - match manifest with - | None -> None - | Some _ -> - Misc.fatal_error "Predef.mk_add_type: non-[None] unboxed manifest" - in Some { type_params = []; type_arity = 0; @@ -408,7 +612,7 @@ let mk_add_type add_type = type_ikind; type_loc = Location.none; type_private = Asttypes.Public; - type_manifest; + type_manifest = None; type_variance = []; type_separability = []; type_is_newtype = false; @@ -421,282 +625,244 @@ let mk_add_type add_type = in let type_jkind = Jkind.mark_best jkind in let type_ikind = ikind_of_jkind ~params:[] type_jkind in - let decl = - {type_params = []; - type_arity = 0; - type_kind = kind; - type_jkind; - type_ikind; - 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_unboxed_default = false; - type_uid; - type_unboxed_version; - } - in - add_type type_ident decl env - in - let add_type ?manifest type_ident ?kind ~jkind ?unboxed_jkind env = - let jkind = Jkind.of_builtin ~why:(Primitive type_ident) jkind in - add_type_with_jkind ?manifest type_ident ?kind ~jkind ?unboxed_jkind env + {type_params = []; + type_arity = 0; + type_kind = kind; + type_jkind; + type_ikind; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_unboxed_default = false; + type_uid; + type_unboxed_version; + } in - add_type_with_jkind, add_type - -let mk_add_type1 add_type type_ident - ?manifest - ?(kind=fun _ -> Type_abstract Definition) + let decl1 + ~variance + ~(param_jkind : jkind_lr) ~jkind - ?(param_jkind=Jkind.Builtin.value ~why:( - Type_argument { - parent_path = Path.Pident type_ident; - position = 1; - arity = 1} - )) - ~variance ~separability env = - let param = newgenvar param_jkind in - let type_jkind = Jkind.mark_best (jkind param) in - let type_ikind = ikind_of_jkind ~params:[param] type_jkind in - let decl = - {type_params = [param]; + ?(separability = Separability.Ind) + ?(kind = fun _ -> Type_abstract Definition) + () + = + let param = newgenvar param_jkind in + let base = decl0 ~jkind:(jkind param) ~kind:(kind param) () in + { base with + type_params = [param]; type_arity = 1; - type_kind = kind param; - type_jkind; - type_ikind; - type_loc = Location.none; - type_private = Asttypes.Public; - type_manifest = Option.map (fun f -> f param) manifest; + type_ikind = ikind_of_jkind ~params:[param] base.type_jkind; type_variance = [variance]; type_separability = [separability]; - type_is_newtype = false; - type_expansion_scope = lowest_level; - type_attributes = []; - type_unboxed_default = false; - type_uid = Uid.of_predef_id type_ident; - type_unboxed_version = None; } in - add_type type_ident decl env - -let mk_add_type2 add_type type_ident ~jkind ~param1_jkind ~param2_jkind - ~type_variance ~type_separability env = - let param1 = newgenvar param1_jkind in - let param2 = newgenvar param2_jkind in - let type_jkind = Jkind.mark_best jkind in - let type_ikind = ikind_of_jkind ~params:[param1; param2] type_jkind in - let decl = - { type_params = [param1; param2]; + let decl2 + ~variance:(var1, var2) + ~param_jkinds:(param_jkind1, param_jkind2) + ~jkind + ?separability:((sep1, sep2) = (Separability.Ind, Separability.Ind)) + ?(kind = fun _ _ -> Type_abstract Definition) + () + = + let param1, param2 = newgenvar param_jkind1, newgenvar param_jkind2 in + let base = + decl0 ~kind:(kind param1 param2) ~jkind:(jkind param1 param2) () + in + { base with + type_params = [param1; param2]; type_arity = 2; - type_kind = Type_abstract Definition; - type_jkind; - type_ikind; - type_loc = Location.none; - type_private = Asttypes.Public; - type_manifest = None; - type_variance; - type_separability; - type_is_newtype = false; - type_expansion_scope = lowest_level; - type_attributes = []; - type_unboxed_default = false; - type_uid = Uid.of_predef_id type_ident; - type_unboxed_version = None; + type_ikind = ikind_of_jkind ~params:[param1; param2] base.type_jkind; + type_variance = [var1; var2]; + type_separability = [sep1; sep2]; } in - add_type type_ident decl env - -let mk_add_extension add_extension id args = - List.iter (fun (_, sort) -> - let raise_error () = Misc.fatal_error - "sanity check failed: non-value jkind in predef extension \ - constructor; should this have Constructor_mixed shape?" in - match (sort : Jkind_types.Sort.Const.t) with - | Base Scannable -> () - | Base (Void | Untagged_immediate | Float32 | Float64 | Word | Bits8 | - Bits16 | Bits32 | Bits64 | Vec128 | Vec256 | Vec512) - | Univar _ | Genvar _ | Product _ -> raise_error ()) - args; - add_extension id - { ext_type_path = path_exn; - ext_type_params = []; - ext_args = - Cstr_tuple - (List.map - (fun (ca_type, ca_sort) -> - { - ca_type; - ca_sort; - ca_modalities=Mode.Modality.Const.id; - ca_loc=Location.none - }) - args); - ext_shape = Constructor_uniform_value; - ext_constant = args = []; - 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; - } - -let mk_add_jkind add_jkind = - let add_jkind id jkind env = - let decl = - { jkind_manifest = Some jkind; - jkind_attributes = []; - jkind_uid = Uid.of_predef_id id; - jkind_loc = Location.none } + let variant constrs = + let mk_elt { cd_args } = + let sorts = match cd_args with + | Cstr_tuple args -> + Misc.Stdlib.Array.of_list_map (fun { ca_sort } -> ca_sort) args + | Cstr_record lbls -> + Misc.Stdlib.Array.of_list_map (fun { ld_sort } -> ld_sort) lbls + in + Constructor_uniform_value, sorts in - add_jkind id decl env + Type_variant ( + constrs, + Variant_boxed (Misc.Stdlib.Array.of_list_map mk_elt constrs), + None) in - add_jkind - -let variant constrs = - let mk_elt { cd_args } = - let sorts = match cd_args with - | Cstr_tuple args -> - Misc.Stdlib.Array.of_list_map (fun { ca_sort } -> ca_sort) args - | Cstr_record lbls -> - Misc.Stdlib.Array.of_list_map (fun { ld_sort } -> ld_sort) lbls - in - Constructor_uniform_value, sorts + let builtin jkind = Jkind.of_builtin ~why:(Primitive type_ident) jkind in + let builtin1 jkind _param1 = builtin jkind in + let builtin2 jkind _param1 _param2 = builtin jkind in + let value_param_jkind = + Jkind.Builtin.value ~why:( + Type_argument { + parent_path = Path.Pident type_ident; + position = 1; + arity = 1}) in - Type_variant ( - constrs, - Variant_boxed (Misc.Stdlib.Array.of_list_map mk_elt constrs), - None) - -let unrestricted tvar ca_sort = - {ca_type=tvar; - ca_sort; - ca_modalities=Mode.Modality.Const.id; - ca_loc=Location.none} - -(* CR layouts: Changes will be needed here as we add support for the built-ins - to work with non-values, and as we relax the mixed block restriction. *) -let build_initial_env add_type add_extension add_jkind empty_env = - let add_type_with_jkind, add_type = mk_add_type add_type - and add_type1 = mk_add_type1 add_type - and add_type2 = mk_add_type2 add_type - and add_extension = mk_add_extension add_extension - and add_jkind = mk_add_jkind add_jkind + let value_params_jkind_2 = ( + Jkind.Builtin.value + ~why:(Type_argument {parent_path = Path.Pident type_ident; + position = 1; arity = 2}), + Jkind.Builtin.value + ~why:(Type_argument {parent_path = Path.Pident type_ident; + position = 2; arity = 2})) in - empty_env - (* Predefined types *) - |> add_type1 ident_array - ~variance:Variance.full - ~separability:Separability.Ind - ~param_jkind:Jkind.for_array_argument + match tconstr with + | `Int -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_untagged_int () + | `Char -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int8 () + | `String -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) () + | `Bytes -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.mutable_data) () + | `Float -> + decl0 + ~jkind:(Jkind.for_float ident_float) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_float + () + | `Floatarray -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.mutable_data) () + | `Nativeint -> + decl0 + ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_nativeint + () + | `Int32 -> + decl0 + ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int32 + () + | `Int64 -> + decl0 + ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int64 + () + | `Extension_constructor -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) () + | `Bool -> + let kind = variant [cstr ident_false []; + cstr ident_true []] in + decl0 ~kind + ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_bool + () + | `Unit -> + let kind = variant [cstr ident_void []] in + decl0 ~kind + ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_unit + () + | `Exn -> decl0 ~kind:Type_open ~jkind:(builtin Jkind.Const.Builtin.exn) () + | `Eff -> + let kind _ = Type_open in + decl1 ~variance:Variance.full ~kind + ~jkind:(builtin1 Jkind.Const.Builtin.value) + ~param_jkind:(Jkind.for_effect_arg ident_eff) + () + | `Continuation -> + let variance = Variance.(contravariant, covariant) in + decl2 ~variance ~param_jkinds:value_params_jkind_2 + ~jkind:(builtin2 Jkind.Const.Builtin.value) () + | `Array -> + decl1 ~variance:Variance.full ~param_jkind:Jkind.for_array_argument ~jkind:(fun param -> Jkind.Builtin.mutable_data ~why:(Primitive ident_array) |> + Jkind.add_with_bounds + ~modality:Mode.Modality.Const.id + ~type_expr:param) () + | `Atomic_loc + -> + decl1 ~variance:Variance.full + ~param_jkind:( + Jkind.Builtin.value_or_null ~why:(Primitive ident_atomic_loc)) + ~jkind:(fun param -> + Jkind.Builtin.sync_data ~why:(Primitive ident_atomic_loc) |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param) - |> add_type1 ident_iarray - ~variance:Variance.covariant - ~separability:Separability.Ind + () + | `Iarray -> + decl1 ~variance:Variance.covariant ~param_jkind:Jkind.for_array_argument ~jkind:(fun param -> Jkind.Builtin.immutable_data ~why:(Primitive ident_iarray) |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param) - |> add_type ident_bool - ~kind:(variant [ cstr ident_false []; cstr ident_true []]) - ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_bool - |> add_type ident_char ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int8 - |> add_type ident_exn ~kind:Type_open ~jkind:Jkind.Const.Builtin.exn - |> add_type ident_extension_constructor - ~jkind:Jkind.Const.Builtin.immutable_data - |> add_type_with_jkind ident_float ~jkind:(Jkind.for_float ident_float) - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_float - |> add_type ident_floatarray ~jkind:Jkind.Const.Builtin.mutable_data - |> add_type ident_int - ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_untagged_int - |> add_type ident_int32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int32 - |> add_type ident_int64 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int64 - |> add_type1 ident_lazy_t - ~variance:Variance.covariant - ~separability:Separability.Ind - (* CR layouts v2.8: Can [lazy_t] mode-cross at all? According to Zesen: - It can at least cross locality, because it's always heap-allocated. - It might also cross portability, linearity, uniqueness subject to its - parameter. But I'm also fine not doing that for now (and wait until - users complains). Internal ticket 5103. *) - ~jkind:(fun _ -> Jkind.for_non_float ~why:(Primitive ident_lazy_t)) - |> add_type1 ident_list - ~variance:Variance.covariant - ~separability:Separability.Ind - ~kind:(fun tvar -> - variant [cstr ident_nil []; - cstr ident_cons [unrestricted tvar list_argument_sort; - unrestricted (type_list tvar) list_sort]]) + () + | `List -> + let kind tvar = + variant [cstr ident_nil []; + cstr ident_cons [unrestricted tvar list_argument_sort; + unrestricted (type_list tvar) list_sort]] in + decl1 ~variance:Variance.covariant ~kind ~param_jkind:list_argument_jkind ~jkind:list_jkind - |> add_type ident_nativeint - ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_nativeint - |> add_type1 ident_option - ~variance:Variance.covariant - ~separability:Separability.Ind - ~kind:(fun tvar -> - variant [cstr ident_none []; - cstr ident_some [unrestricted tvar option_argument_sort]]) + () + | `Option -> + let kind tvar = + variant [cstr ident_none []; + cstr ident_some [unrestricted tvar option_argument_sort]] in + decl1 ~variance:Variance.covariant ~kind ~param_jkind:option_argument_jkind ~jkind:(fun param -> Jkind.Builtin.immutable_data ~why:Boxed_variant |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param) - |> add_type2 ident_idx_imm - ~param1_jkind:( + () + | `Lazy_t -> + decl1 ~variance:Variance.covariant + (* CR layouts v2.8: Can [lazy_t] mode-cross at all? According to Zesen: + It can at least cross locality, because it's always heap-allocated. + It might also cross portability, linearity, uniqueness subject to its + parameter. But I'm also fine not doing that for now (and wait until + users complains). Internal ticket 5103. *) + ~param_jkind:value_param_jkind + ~jkind:(fun _ -> Jkind.for_non_float ~why:(Primitive ident_lazy_t)) + () + | `Idx_imm -> + decl2 ~variance:(Variance.full, Variance.covariant) + ~param_jkinds:( Jkind.Builtin.value_or_null ~why:(Type_argument { parent_path = Path.Pident ident_idx_imm; position = 1; arity = 2; - })) - ~param2_jkind:( + }), Jkind.Builtin.any ~why:(Type_argument { parent_path = Path.Pident ident_idx_imm; position = 2; arity = 2; })) - ~jkind:( - Jkind.of_builtin ~why:(Primitive ident_idx_imm) - Jkind.Const.Builtin.kind_of_idx) - ~type_variance:[Variance.full; Variance.covariant] - ~type_separability:[Separability.Ind; Separability.Ind] - |> add_type2 ident_idx_mut - ~param1_jkind:( + ~jkind:(builtin2 Jkind.Const.Builtin.kind_of_idx) + () + | `Idx_mut -> + decl2 ~variance:(Variance.full, Variance.full) + ~param_jkinds:( Jkind.Builtin.value_or_null ~why:(Type_argument { parent_path = Path.Pident ident_idx_mut; position = 1; arity = 2; - })) - ~param2_jkind:( + }), Jkind.Builtin.any ~why:(Type_argument { parent_path = Path.Pident ident_idx_mut; position = 2; arity = 2; })) - ~jkind:( - Jkind.of_builtin ~why:(Primitive ident_idx_mut) - Jkind.Const.Builtin.kind_of_idx) - ~type_variance:[Variance.full; Variance.full] - ~type_separability:[Separability.Ind; Separability.Ind] - |> add_type_with_jkind ident_lexing_position + ~jkind:(builtin2 Jkind.Const.Builtin.kind_of_idx) + () + | `Lexing_position -> + decl0 ~kind:( let lbl (field, field_type) = let id = Ident.create_predef field in @@ -728,23 +894,169 @@ let build_initial_env add_type add_extension add_jkind empty_env = constructor lookups when deriving ikinds from jkinds. *) ~jkind:Jkind.( of_builtin Const.Builtin.immutable_data - ~why:(Primitive ident_lexing_position)) - |> add_type1 ident_atomic_loc - ~variance:Variance.full + ~why:(Primitive ident_lexing_position) |> + add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:type_int |> + add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:type_int |> + add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:type_int |> + add_with_bounds ~modality:Mode.Modality.Const.id + ~type_expr:type_string) + () + | `Code -> + decl1 + ~variance:Variance.covariant ~separability:Separability.Ind ~param_jkind:( - Jkind.Builtin.value_or_null ~why:(Primitive ident_atomic_loc)) + Jkind.Builtin.any ~why:(Type_argument { + parent_path = Path.Pident type_ident; + position = 1; + arity = 1; + })) ~jkind:(fun param -> - Jkind.Builtin.sync_data ~why:(Primitive ident_atomic_loc) |> - Jkind.add_with_bounds - ~modality:Mode.Modality.Const.id - ~type_expr:param) - |> add_type ident_string ~jkind:Jkind.Const.Builtin.immutable_data - |> add_type ident_bytes ~jkind:Jkind.Const.Builtin.mutable_data - |> add_type ident_unit - ~kind:(variant [cstr ident_void []]) - ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_unit + Jkind.for_expr |> + Jkind.add_with_bounds + ~modality:Mode.Modality.Const.id + ~type_expr:param) + () + | `Int8x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Int16x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Int32x4 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Int64x2 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Float16x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Float32x4 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Float64x2 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors () + | `Int8x32 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Int16x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Int32x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Int64x4 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Float16x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Float32x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Float64x4 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors () + | `Int8x64 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Int16x32 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Int32x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Int64x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Float16x32 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Float32x16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Float64x8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors () + | `Float32 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immutable_data) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_float32 () + | `Int8 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int8 () + | `Int16 -> + decl0 ~jkind:(builtin Jkind.Const.Builtin.immediate) + ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int16 () + | `Or_null -> + decl1 + ~variance:Variance.covariant + (* CR layouts v3: [or_null] is separable only if the argument type + is non-float. The current separability system can't track that. + We also want to allow [float or_null] despite it being non-separable. + + For now, we mark the type argument as [Separability.Ind] to permit + the most argument types, and forbid arrays from accepting [or_null]s. + In the future, we will track separability in the jkind system. *) + ~kind:or_null_kind + ~param_jkind:(Jkind.for_or_null_argument ident_or_null) + ~jkind:or_null_jkind + () + +let mk_add_jkind add_jkind = + let add_jkind id jkind env = + let decl = + { jkind_manifest = Some jkind; + jkind_attributes = []; + jkind_uid = Uid.of_predef_id id; + jkind_loc = Location.none } + in + add_jkind id decl env + in + add_jkind + +let build_initial_env add_type add_extension add_jkind empty_env = + let add_jkind = mk_add_jkind add_jkind in + let add_extension id l = + List.iter (fun (_, sort) -> + let raise_error () = Misc.fatal_error + "sanity check failed: non-value jkind in predef extension \ + constructor; should this have Constructor_mixed shape?" in + match (sort : Jkind_types.Sort.Const.t) with + | Base Scannable -> () + | Base (Void | Untagged_immediate | Float32 | Float64 | Word | Bits8 | + Bits16 | Bits32 | Bits64 | Vec128 | Vec256 | Vec512) + | Univar _ | Genvar _ | Product _ -> raise_error ()) + l; + add_extension id + { ext_type_path = path_exn; + ext_type_params = []; + ext_args = + Cstr_tuple + (List.map + (fun (ca_type, ca_sort) -> + { + ca_type; + ca_sort; + ca_modalities=Mode.Modality.Const.id; + ca_loc=Location.none + }) + l); + ext_shape = Constructor_uniform_value; + ext_constant = 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 + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) empty_env base_type_constrs (* Predefined exceptions - alphabetical order *) |> add_extension ident_assert_failure [newgenty (Ttuple[None, type_string; None, type_int; None, type_int]), @@ -768,138 +1080,65 @@ let build_initial_env add_type add_extension add_jkind empty_env = |> add_extension ident_undefined_recursive_module [newgenty (Ttuple[None, type_string; None, type_int; None, type_int]), Jkind_types.Sort.Const.scannable] + |> add_extension ident_continuation_already_taken [] (* Predefined jkinds *) |> add_predef_jkinds add_jkind +let add_or_null add_type env = + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) env or_null_extension_type_constrs + let add_simd_stable_extension_types add_type env = - let _, add_type = mk_add_type add_type in - env - |> add_type ident_int8x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_int16x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_int32x4 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_int64x2 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_float16x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_float32x4 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_float64x2 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_128bit_vectors - |> add_type ident_int8x32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_int16x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_int32x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_int64x4 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_float16x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_float32x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors - |> add_type ident_float64x4 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_256bit_vectors + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) env simd_stable_extension_type_constrs let add_simd_beta_extension_types _add_type env = env let add_simd_alpha_extension_types add_type env = - let _, add_type = mk_add_type add_type in - env - |> add_type ident_int8x64 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_int16x32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_int32x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_int64x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_float16x32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_float32x16 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors - |> add_type ident_float64x8 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_512bit_vectors + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) env simd_alpha_extension_type_constrs let add_small_number_extension_types add_type env = - let _, add_type = mk_add_type add_type in - env - |> add_type ident_float32 ~jkind:Jkind.Const.Builtin.immutable_data - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_float32 - |> add_type ident_int8 ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int8 - |> add_type ident_int16 ~jkind:Jkind.Const.Builtin.immediate - ~unboxed_jkind:Jkind.Const.Builtin.kind_of_unboxed_int16 - -let add_small_number_beta_extension_types _add_type env = - env + List.fold_left (fun env tconstr -> + add_type (ident_of_type_constr tconstr) (decl_of_type_constr tconstr) env + ) env small_number_extension_type_constrs -let or_null_argument_sort = Jkind_types.Sort.Const.scannable - -let or_null_kind tvar = - let cstrs = - [ cstr ident_null []; - cstr ident_this [unrestricted tvar or_null_argument_sort]] - in - Type_variant (cstrs, Variant_with_null, None) - -let or_null_jkind param = - Jkind.Const.Builtin.value_or_null_mod_everything - |> Jkind.of_builtin ~why:(Primitive ident_or_null) - |> Jkind.add_with_bounds ~modality:Mode.Modality.Const.id ~type_expr:param - |> Jkind.mark_best - -let add_or_null add_type env = - let add_type1 = mk_add_type1 add_type in - env - |> add_type1 ident_or_null - ~variance:Variance.covariant - ~separability:Separability.Ind - (* CR layouts v3: [or_null] is separable only if the argument type - is non-float. The current separability system can't track that. - We also want to allow [float or_null] despite it being non-separable. - - For now, we mark the type argument as [Separability.Ind] to permit - the most argument types, and forbid arrays from accepting [or_null]s. - In the future, we will track separability in the jkind system. *) - ~kind:or_null_kind - ~param_jkind:(Jkind.for_or_null_argument ident_or_null) - ~jkind:or_null_jkind +let add_small_number_beta_extension_types _add_type env = env let add_runtime_metaprogramming_types add_type env = - let add_type1 = mk_add_type1 add_type in - env - |> add_type1 ident_code - ~variance:Variance.covariant - ~separability:Separability.Ind - ~jkind:(fun param -> - Jkind.for_expr |> - Jkind.add_with_bounds - ~modality:Mode.Modality.Const.id - ~type_expr:param) - ~param_jkind:( - Jkind.Builtin.any ~why:(Type_argument { - parent_path = Path.Pident ident_code; - position = 1; - arity = 1; - })) - |> add_type1 ident_eval - ~variance:Variance.covariant - ~separability:Separability.Ind - ~manifest:type_eval - ~jkind:(fun param -> - Jkind.Builtin.any ~why:Evaluated_quote |> - Jkind.add_with_bounds - ~modality:Mode.Modality.Const.id - ~type_expr:param) - ~param_jkind:( - Jkind.Builtin.any ~why:(Type_argument { - parent_path = Path.Pident ident_eval; - position = 1; - arity = 1; - })) + let env = add_type ident_code (decl_of_type_constr `Code) env in + let param = newgenvar ( + Jkind.Builtin.any ~why:(Type_argument { + parent_path = Path.Pident ident_eval; + position = 1; arity = 1 })) + in + let type_jkind = Jkind.mark_best ( + Jkind.Builtin.any ~why:Evaluated_quote |> + Jkind.add_with_bounds + ~modality:Mode.Modality.Const.id ~type_expr:param) + in + let type_ikind = ikind_of_jkind ~params:[param] type_jkind in + add_type ident_eval { + type_params = [param]; + type_arity = 1; + type_kind = Type_abstract Definition; + type_jkind; + type_ikind; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = Some (type_eval param); + type_variance = [Variance.covariant]; + type_separability = [Separability.Ind]; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_unboxed_default = false; + type_uid = Uid.of_predef_id ident_eval; + type_unboxed_version = None; + } env let builtin_values = List.map (fun id -> (Ident.name id, id)) all_predef_exns diff --git a/upstream/ocaml_flambda/typing/predef.mli b/upstream/ocaml_flambda/typing/predef.mli index 3b3124c16..33ee1e934 100644 --- a/upstream/ocaml_flambda/typing/predef.mli +++ b/upstream/ocaml_flambda/typing/predef.mli @@ -17,6 +17,70 @@ open Types +type abstract_type_constr = [ + | `Int + | `Char + | `String + | `Bytes + | `Float + | `Continuation + | `Array + | `Nativeint + | `Int32 + | `Int64 + | `Lazy_t + | `Extension_constructor + | `Floatarray + | `Iarray + | `Atomic_loc + | `Lexing_position + | `Code + | `Float32 + | `Int8 + | `Int16 +] +type abstract_non_value_type_constr = [ + | `Idx_imm + | `Idx_mut + | `Int8x16 + | `Int16x8 + | `Int32x4 + | `Int64x2 + | `Float16x8 + | `Float32x4 + | `Float64x2 + | `Int8x32 + | `Int16x16 + | `Int32x8 + | `Int64x4 + | `Float16x16 + | `Float32x8 + | `Float64x4 + | `Int8x64 + | `Int16x32 + | `Int32x16 + | `Int64x8 + | `Float16x32 + | `Float32x16 + | `Float64x8 +] +type data_type_constr = [ + | `Bool + | `Unit + | `Exn + | `Eff + | `List + | `Option + | `Or_null +] +type type_constr = [ + | abstract_type_constr + | abstract_non_value_type_constr + | data_type_constr +] + +val find_type_constr : Path.t -> type_constr option + val type_int: type_expr val type_char: type_expr val type_string: type_expr @@ -26,6 +90,8 @@ val type_float32: 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_iarray: type_expr -> type_expr val type_list: type_expr -> type_expr @@ -110,6 +176,7 @@ val path_float32: 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_iarray: Path.t val path_list: Path.t @@ -122,6 +189,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_lexing_position: Path.t val path_code: Path.t val path_eval: Path.t diff --git a/upstream/ocaml_flambda/typing/printpat.ml b/upstream/ocaml_flambda/typing/printpat.ml index 3a946ed2f..60e144580 100644 --- a/upstream/ocaml_flambda/typing/printpat.ml +++ b/upstream/ocaml_flambda/typing/printpat.ml @@ -17,7 +17,7 @@ open Asttypes open Typedtree -open Types +open Data_types open Format_doc let is_cons = function diff --git a/upstream/ocaml_flambda/typing/printtyp.ml b/upstream/ocaml_flambda/typing/printtyp.ml index e6c41fe6a..74233f620 100644 --- a/upstream/ocaml_flambda/typing/printtyp.ml +++ b/upstream/ocaml_flambda/typing/printtyp.ml @@ -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,3705 +13,184 @@ (* *) (**************************************************************************) -(* Printing functions *) - -open Misc -open Ctype -open Longident -open Path -open Asttypes -open Types -open Mode -open Btype -open Outcometree - -module String = Misc.Stdlib.String -module Int = Misc.Stdlib.Int -module Sig_component_kind = Shape.Sig_component_kind -module Style = Misc.Style - -(* Note [When to print jkind annotations] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Jkind annotations are only occasionally necessary to write - (compilation can often infer jkinds), so when should we print - them? This Note addresses all the cases. - - Case (C1). The jkind on a type declaration, like - [type 'a t : <> = ...]. - - We print the jkind when it cannot be inferred from the rest of what is - printed. Specifically, we print the user-written jkind in any of these - cases: - - (C1.1) The type declaration is abstract, has no manifest (i.e., - it's written without any [=]-signs), and the annotation is not equivalent to value. - - In this case, there is no way to know the jkind without the annotation. - - (C1.2) The type has unsafe mode crossings. In this case, the jkind is overridden by the - user rather than being inferred from the definition. - - Case (C2). The jkind on a type parameter to a type, like - [type ('a : <>) t = ...]. - - This jkind is printed if both of the following are true: - - (C2.1) The jkind is something other than the default [value]. - (* CR layouts reisenberg: update when the default changes *) - - (C2.2) The variable has no constraints on it. (If there is a constraint, - the constraint determines the jkind, so printing the jkind is - redundant.) - - We *could*, in theory, print this only when it cannot be inferred. - But this amounts to repeating inference. The heuristic also runs into - trouble when considering the possibility of a recursive type. So, in - order to keep the pretty-printer simple, we just always print the - (non-default) annotation. - - Another design possibility is to pass in verbosity level as some kind - of flag. - - Case (C3). The jkind on a universal type variable, like - [val f : ('a : <>). 'a -> 'a]. - - We should print this jkind annotation whenever it is neither the - default [value] nor an unfilled sort variable. (But see (X1) below.) - (* CR layouts reisenberg: update when the default changes *) - This is a challenge, though, because the type in a [val] does not - explicitly quantify its free variables. So we must collect the free - variables, look to see whether any have interesting jkinds, and - print the whole set of variables if any of them do. This is all - implemented in [extract_qtvs], used also in a number of other places - we do quantification (e.g. gadt-syntax constructors). - - Exception (X1). When we are still in the process of inferring a type, - there may be an unfilled sort variable. Here is an example: - - {[ - module M : sig - val f : int -> bool -> char - end = struct - let f true _ = () - end - ]} - - The problem is that [f]'s first parameter is conflicted between being - [int] and [bool]. But the second parameter in the [struct] will have - type ['a : <>]. We generally do not want to print this, - however, and so we don't -- except when [-verbose-types] is set. - - We imagine that merlin, when run verbosely, will set [-verbose-types]. - This will allow an informative type to be printed for e.g. [let f x = x], - which can work with any sort. -*) - -(* Print a long identifier *) - +open Out_type module Fmt = Format_doc -open Format_doc - -let longident = Pprintast.Doc.longident - -let () = Env.print_longident := longident; Mode.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 - let set out_name x = out_name.printed_name <- x -end -(** Some identifiers may require hiding when printing *) -type bound_ident = { hide:bool; ident:Ident.t } +let namespaced_ident namespace id = + Out_name.print (ident_name (Some namespace) id) -(* printing environment for path shortening and naming *) -let printing_env = ref Env.empty +module Doc = struct + let wrap_printing_env = wrap_printing_env -(* 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 + let longident = Pprintast.Doc.longident -let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n + let ident ppf id = Fmt.pp_print_string ppf + (Out_name.print (ident_name None id)) - type namespace = Sig_component_kind.t = - | Value - | Type - | Constructor - | Label - | Unboxed_label - | Module - | Module_type - | Extension_constructor - | Class - | Class_type - | Jkind -module Namespace = struct - let id = function - | Type -> 0 - | Module -> 1 - | Module_type -> 2 - | Class -> 3 - | Class_type -> 4 - | Extension_constructor | Value | Constructor | Label -> 5 - | Unboxed_label -> 6 - | Jkind -> 7 - (* we do not handle those component *) + let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) - let size = 1 + id Jkind + let modality ?(id = fun _ppf () -> ()) ax ppf modality = + if Mode.Modality.Per_axis.is_id ax modality then + id ppf () + else + Fmt.asprintf "%a" (Mode.Modality.Per_axis.print ax) modality + |> !Oprint.out_modality ppf + let type_expansion k ppf e = + pp_type_expansion ppf (trees_of_type_expansion k e) - let pp ppf x = - Fmt.pp_print_string ppf (Shape.Sig_component_kind.to_string x) + let type_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) - (** 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_lazy - | Some Module_type -> to_lookup Env.find_modtype_by_name_lazy - | Some Class -> to_lookup Env.find_class_by_name - | Some Class_type -> to_lookup Env.find_cltype_by_name - | Some Jkind -> to_lookup Env.find_jkind_by_name - | None - | Some(Value|Extension_constructor|Constructor|Label|Unboxed_label) -> - fun _ -> raise Not_found + 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 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_lazy path).md_loc - | Some Module_type -> - (in_printing_env @@ Env.find_modtype_lazy 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 Jkind -> (in_printing_env @@ Env.find_jkind path).jkind_loc - | Some (Extension_constructor|Value|Constructor|Label|Unboxed_label) - | None -> - Location.none - ) with Not_found -> None + let shared_type_scheme ppf ty = + add_type_to_preparation ty; + typexp Type_scheme ppf ty - 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 type_scheme ppf ty = + prepare_for_printing [ty]; + prepared_type_scheme ppf ty -end + let path ppf p = + !Oprint.out_ident ppf (tree_of_path p) -(** {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 collect_explanation namespace n id = - let name = human_unique n id in - let root_name = Ident.name id in - if not (M.mem name !explanations) then - match Namespace.location (Some namespace) id with - | None -> () - | Some location -> - let explanation = { kind = namespace; location; name; root_name } in - explanations := M.add name explanation !explanations + let () = Env.print_path := path + let () = Env.print_type_expr := type_expr - let pp_explanation ppf r= - Fmt.fprintf ppf "@[%a:@,Definition of %s %a@]" - (Location.Doc.loc ~capitalize_first:true) r.location - (Sig_component_kind.to_string r.kind) - Style.inline_code r.name + let type_path ppf p = !Oprint.out_ident ppf (tree_of_type_path p) - let print_located_explanations ppf l = - Fmt.fprintf ppf "@[%a@]" - (Fmt.pp_print_list pp_explanation) l + let value_description id ppf decl = + !Oprint.out_sig_item ppf (tree_of_value_description id decl) - let reset () = explanations := M.empty - let list_explanations () = - let c = !explanations in + let class_type ppf cty = 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 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 -> Fmt.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 exists () = M.cardinal !explanations >0 -end - -module Naming_context = struct - -module M = String.Map -module S = String.Set + prepare_class_type cty; + !Oprint.out_class_type ppf (tree_of_class_type Type cty) -let enabled = ref true -let enable b = enabled := b + let class_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) -(** Name mapping *) -type mapping = - | Need_unique_name of int Ident.Map.t - (** The same name has already been attributed to multiple types. - The [map] argument contains the specific binding time attributed to each - types. - *) - | Uniquely_associated_to of Ident.t * out_name - (** For now, the name [Ident.name id] has been attributed to [id], - [out_name] is used to expand this name if a conflict arises - at a later point - *) - | Associated_to_pervasives of out_name - (** [Associated_to_pervasives out_name] is used when the item - [Stdlib.$name] has been associated to the name [$name]. - Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *) + let cltype_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) -let hid_start = 0 + 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 add_hid_id id map = - let new_id = 1 + Ident.Map.fold (fun _ -> Int.max) map hid_start in - new_id, Ident.Map.add id new_id map + let constructor ppf c = + reset_except_conflicts (); + add_constructor_to_preparation c; + prepared_constructor ppf c -let find_hid id map = - try Ident.Map.find id map, map with - Not_found -> add_hid_id id map + let constructor_arguments ppf a = + !Oprint.out_constr_args ppf (tree_of_constructor_arguments a) -let pervasives name = "Stdlib." ^ name - -let map = Array.make Namespace.size M.empty -let get namespace = map.(Namespace.id namespace) -let set namespace x = map.(Namespace.id namespace) <- x - -(* Names used in recursive definitions are not considered when determining - if a name is already attributed in the current environment. - This is a complementary version of hidden_rec_items used by short-path. *) -let protected = ref S.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 = S.add (Ident.name id.ident) m in - protect_refs [ R(protected, List.fold_left update !protected ids)] f - -let pervasives_name namespace name = - match namespace, !enabled with - | None, _ | _, true -> Out_name.create name - | Some namespace, false -> - match M.find name (get namespace) with - | Associated_to_pervasives r -> r - | Need_unique_name _ -> Out_name.create (pervasives name) - | Uniquely_associated_to (id',r) -> - let hid, map = add_hid_id id' Ident.Map.empty in - Out_name.set r (human_unique hid id'); - Conflicts.collect_explanation namespace hid id'; - set namespace @@ M.add name (Need_unique_name map) (get namespace); - Out_name.create (pervasives name) - | exception Not_found -> - let r = Out_name.create name in - set namespace @@ M.add name (Associated_to_pervasives r) (get namespace); - r - -(** Lookup for preexisting named item within the current {!printing_env} *) -let env_ident namespace name = - if S.mem name !protected then None else - match Namespace.lookup namespace name with - | Pident id -> Some id - | _ -> None - | exception Not_found -> None - -(** Associate a name to the identifier [id] within [namespace] *) -let ident_name_simple 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 = Ident.name id in - match M.find name (get namespace) with - | Uniquely_associated_to (id',r) when Ident.same id id' -> - r - | Need_unique_name map -> - let hid, m = find_hid id map in - Conflicts.collect_explanation namespace hid id; - set namespace @@ M.add name (Need_unique_name m) (get namespace); - Out_name.create (human_unique hid id) - | Uniquely_associated_to (id',r) -> - let hid', m = find_hid id' Ident.Map.empty in - let hid, m = find_hid id m in - Out_name.set r (human_unique hid' id'); - List.iter (fun (id,hid) -> Conflicts.collect_explanation namespace hid id) - [id, hid; id', hid' ]; - set namespace @@ M.add name (Need_unique_name m) (get namespace); - Out_name.create (human_unique hid id) - | Associated_to_pervasives r -> - Out_name.set r ("Stdlib." ^ Out_name.print r); - let hid, m = find_hid id Ident.Map.empty in - set namespace @@ M.add name (Need_unique_name m) (get namespace); - Out_name.create (human_unique hid id) - | exception Not_found -> - let r = Out_name.create name in - set namespace - @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace); - r - -(** Same as {!ident_name_simple} but lookup to existing named identifiers - in the current {!printing_env} *) -let ident_name namespace id = - begin match env_ident namespace (Ident.name id) with - | Some id' -> ignore (ident_name_simple namespace id') - | None -> () - end; - ident_name_simple namespace id - -let reset () = - Array.iteri ( fun i _ -> map.(i) <- M.empty ) map - -let with_ctx f = - let old = Array.copy map in - try_finally f - ~always:(fun () -> Array.blit old 0 map 0 (Array.length map)) - -end -let ident_name = Naming_context.ident_name -let reset_naming_context = Naming_context.reset + let label ppf l = + prepare_for_printing [l.Types.ld_type]; + !Oprint.out_label ppf (tree_of_label l) -let ident ppf id = pp_print_string ppf - (Out_name.print (Naming_context.ident_name_simple None id)) + let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) -let namespaced_ident namespace id = - Out_name.print (Naming_context.ident_name (Some namespace) id) - -let instance_name global = - (* Construct the stopgap syntax and then shove it in a string with the - attribute after it. *) - (* CR lmaurer: This is hacky and it loses the state of the [out_name]s that - comprise the [out_ident]. Should presumably have a new constructor for - [out_ident] instead? *) - let rec string_of_global global = - (* We can avoid calling [ident_name_simple] here because instance names are - always global (which is bad - but the syntax is currently bad anyway) *) - let ({ head; args } : Global_module.Name.t) = global in - String.concat "" (head :: List.map string_of_arg args) - and string_of_arg arg = - let ({ param; value } : Global_module.Name.argument) = arg in - Printf.sprintf "(%s)(%s)" - (Global_module.Parameter_name.to_string param) (string_of_global value) - in - let printed_name = - string_of_global global ^ " [@jane.non_erasable.instances]" - in - { printed_name } - - -(* Print a path *) - -let ident_stdlib = Ident.create_persistent "Stdlib" - -let non_shadowed_pervasive = function - | Pdot(Pident id, s) as path -> - Ident.same id ident_stdlib && - (match in_printing_env (Env.find_type_by_name (Lident 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 - -let expand_longident_head name = - match find_double_underscore name with - | None -> None - | Some i -> - Some - (Ldot - (Lident (String.sub name 0 i), - Unit_info.modulize - (String.sub name (i + 2) (String.length name - i - 2)))) - -(* 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 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 - match expand_longident_head name with - | None -> p - | Some better_lid -> - match Env.find_module_by_name_lazy 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 rewrite_double_underscore_longidents env (l : Longident.t) = - match l with - | Ldot (l, s) -> - Ldot (rewrite_double_underscore_longidents env l, s) - | Lapply (a, b) -> - Lapply (rewrite_double_underscore_longidents env a, - rewrite_double_underscore_longidents env b) - | Lident name -> - match expand_longident_head name with - | None -> l - | Some l' -> - match - (Env.find_module_by_name_lazy l env, - Env.find_module_by_name_lazy l' env) - with - | exception Not_found -> l - | (p, _), (p', _) -> - if module_path_is_an_alias_of env p' ~alias_of:p then - l' - else - l - -let rec tree_of_path namespace = function - | Pident id -> - Oide_ident (ident_name namespace id) - | Pdot(_, s) as path when non_shadowed_pervasive path -> - Oide_ident (Naming_context.pervasives_name namespace s) - | Pdot(p, s) -> - Oide_dot (tree_of_path (Some Module) p, s) - | Papply(p1, p2) -> - Oide_apply (tree_of_path (Some Module) p1, tree_of_path (Some Module) p2) - | 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 - | Punboxed_ty -> - Oide_hash (tree_of_path namespace p) - end + 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; + } -let tree_of_path namespace = function - | Pident id when Ident.is_instance id -> - (* Only when the instance name is the entire path (which is the only place - a human could write it) is it worth printing the human-writable stopgap - syntax for instance names *) - Oide_ident (instance_name (Ident.to_global_exn id)) - | p -> tree_of_path namespace p + (* Print a signature body (used by -i when compiling a .ml) *) -let tree_of_path namespace p = - tree_of_path namespace (rewrite_double_underscore_paths !printing_env p) + let print_signature ppf tree = + Fmt.fprintf ppf "@[%a@]" !Oprint.out_signature tree -let path ppf p = !Oprint.out_ident ppf (tree_of_path None p) + let signature ppf sg = + Fmt.fprintf ppf "%a" print_signature (tree_of_signature sg) -let string_of_path p = - Format.asprintf "%a" (Fmt.compat path) p +end +open Doc +let string_of_path p = Fmt.asprintf "%a" path p let strings_of_paths namespace p = - reset_naming_context (); - let trees = List.map (tree_of_path namespace) p in + let trees = List.map (namespaced_tree_of_path namespace) p in List.map (Fmt.asprintf "%a" !Oprint.out_ident) trees -let () = Env.print_path := path -let () = Jkind.set_printtyp_path path - -(* Print a recursive annotation *) +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 tree_of_rec = function - | Trec_not -> Orec_not - | Trec_first -> Orec_first - | Trec_next -> Orec_next +let modality ?id ax = + Fmt.compat (modality ?id:(Option.map Fmt.deprecated id) ax) -(* Print a raw type expression, with sharing *) +let type_scheme = Fmt.compat type_scheme +let shared_type_scheme = Fmt.compat shared_type_scheme -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 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 kind_vars = ref [] -let kind_count = ref 0 +let modtype = Fmt.compat modtype +let modtype_declaration = Fmt.compat1 modtype_declaration +let signature = Fmt.compat signature -let string_of_field_kind v = - match field_kind_repr v with - | Fpublic -> "Fpublic" - | Fabsent -> "Fabsent" - | Fprivate -> "Fprivate" +let class_declaration = Fmt.compat1 class_declaration +let class_type = Fmt.compat class_type +let cltype_declaration = Fmt.compat1 cltype_declaration -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 +(* 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 let string_of_label : Types.arg_label -> string = function - Nolabel -> "" + | Nolabel -> "" | Labelled s | Position 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;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 labeled_type ppf (label, ty) = - begin match label with - | Some s -> fprintf ppf "label=\"%s\" " s - | None -> () - end; - raw_type ppf ty - -and raw_type_list tl = raw_list raw_type tl -and labeled_type_list tl = raw_list labeled_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_row_desc ppf 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) -and raw_type_desc ppf = function - Tvar { name; jkind } -> - fprintf ppf "Tvar (@,%a,@,%a)" - print_name name (Jkind.format !printing_env) jkind - | Tarrow((l,arg,ret),t1,t2,c) -> - fprintf ppf "@[Tarrow((\"%s\",%a,%a),@,%a,@,%a,@,%s)@]" - (string_of_label l) - (Alloc.print ~verbose:true ()) arg - (Alloc.print ~verbose:true ()) ret - raw_type t1 raw_type t2 - (if is_commu_ok c then "Cok" else "Cunknown") - | Ttuple tl -> - fprintf ppf "@[<1>Ttuple@,%a@]" labeled_type_list tl - | Tunboxed_tuple tl -> - fprintf ppf "@[<1>Tunboxed_tuple@,%a@]" labeled_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) - | Tquote t -> - fprintf ppf "@[Tquote@ %a@]" raw_type t - | Tsplice t -> - fprintf ppf "@[Tsplice@ %a@]" raw_type t - | Tquote_eval t -> - fprintf ppf "@[Tquote_eval@ %a@]" raw_type t - | 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; jkind } -> - fprintf ppf "Tunivar (@,%a,@,%a)" - print_name name (Jkind.format !printing_env) jkind - | Tpoly (t, tl) -> - fprintf ppf "@[Tpoly(@,%a,@,%a)@]" - raw_type t - raw_type_list tl - | Trepr (t, sort_vars) -> - let print_sort_univar ppf uv = - fprintf ppf "%s" (Option.value uv.Jkind_types.Sort.name ~default:"_") - in - fprintf ppf "@[Trepr(@,%a,@,[@[%a@]])@]" - raw_type t - (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@ ") - print_sort_univar) sort_vars - | Tvariant row -> - raw_row_desc ppf row - | Tpackage (p, fl) -> - fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p - raw_lid_type_list fl - | Tof_kind jkind -> - fprintf ppf "Tof_kind@ %a" (Jkind.format !printing_env) jkind -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 -| Some Types.Fixed_existential -> fprintf ppf "Some Fixed_existential" - -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 := compat 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 - -(* In the [Paths] constructor, more preferred paths are stored later in the - list. *) - -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 Compilation_unit.Name.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 same_printing_env env = - let used_pers = Env.used_persistent () in - Env.same_types !printing_old env - && Compilation_unit.Name.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 -> - (* Jane Street: Often the best choice for printing [p1] is - [p1] itself. And often [p1] is a path whose "penalty" - would be reduced if the double-underscore rewrite - applied. - *) - let rewritten_p1 = rewrite_double_underscore_paths env p1 in - printing_map := Path.Map.add p1 (ref (Paths [ p; rewritten_p1 ])) !printing_map) - env in - printing_cont := [cont]; - end - -(* CR-soon zqian: Currently we immediately backtrack each mutation, which might -cause incoherent types/modes in a single printing. Instead, we should move -backtrack logic into [wrap_printing_env], which is called for each "printing -request". Unfortunately, that seems to interfere with type naming context. The -later is cleaned up in Ocaml 5.3, so we should retry once we merge 5.3. *) -let wrap_mutation f = - let snap = Btype.snapshot () in - try_finally f ~always:(fun () -> Btype.backtrack snap) - -let wrap_printing_env ~reset_names env f = - let old_env = !printing_env in - set_printing_env env; - if reset_names then reset_naming_context (); - try_finally f ~always:(fun () -> set_printing_env old_env) - -let wrap_printing_env ~error env f = - if error then Env.without_cmis (wrap_printing_env ~reset_names:true env) f - else wrap_printing_env ~reset_names:true env f -and wrap_printing_env_unguarded env f = - wrap_printing_env ~reset_names:false 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 - | Path.Pextra_ty (p, Punboxed_ty) -> - match p with - | Pident id -> Longident.Lident (Ident.name id ^ "#") - | Pdot (p, s) -> Longident.Ldot (lid_of_path p, s ^ "#") - | Papply _ | Pextra_ty _ -> assert false - -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 penalty_size = 20 - -let name_penalty s = - if s <> "" && s.[0] = '_' then - penalty_size - else - match find_double_underscore s with - | None -> 2 - | Some _ -> penalty_size - -let ambiguity_penalty path env = - if is_unambiguous path env then 0 else penalty_size - -let path_size path env = - let rec size = function - Pident id -> - name_penalty (Ident.name id), -Ident.scope id - | Pdot (p, id) | Pextra_ty (p, Pcstr_ty id) -> - let (l, b) = size p in (name_penalty id + l, b) - | Papply (p1, p2) -> - let (l, b) = size p1 in - (l + fst (size p2), b) - | Pextra_ty (p, Pext_ty) -> - size p - | Pextra_ty (p, Punboxed_ty) -> - let (l, b) = size p in (1 + l, b) - in - let l, s = size path in - l + ambiguity_penalty path env, s - -let rec get_best_path r env = - 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 env >= path_size p' env -> () - | _ -> r := Best p) - (List.rev l); - get_best_path r env - -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 () = - try - get_best_path (Path.Map.find p' !printing_map) !printing_env - with Not_found -> rewrite_double_underscore_paths !printing_env p' - in - while !printing_cont <> [] && - fst (path_size (get_path ()) !printing_env) > !printing_depth - do - printing_cont := List.map snd (Env.run_iter_cont !printing_cont); - incr printing_depth; - done; - let p'' = get_path () in - (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) - (p'', s) - -(* 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 Names : sig - val reset_names : unit -> unit - - val add_named_vars : type_expr -> 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 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 { name = Some name } | Tunivar { name = 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 { name = Some name } | Tunivar { name = 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 _ | Trepr _ -> 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 () = - reset_naming_context (); 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 - -(* Whether to expand [eval] in types for reductions before printing. - Disabled when printing errors, as they usually contain an expansion trace. *) -let print_reduced_evals = ref true - -let out_jkind_of_const_jkind env jkind = - Ojkind_const (Jkind.Const.to_out_jkind_const env jkind) - -(* CR layouts v2.8: This is just like [Jkind.format], and likely needs to - be overhauled with [with]-types. Internal ticket 5096. *) -let rec out_jkind_of_desc env (desc : 'd Jkind.Desc.t) = - match desc.base with - | Layout (Sort (Var n, sa)) -> - Ojkind_var ("'_representable_layout_" ^ - Int.to_string (Jkind.Sort.Var.get_print_number n), - Jkind.Scannable_axes.to_string_list sa) - (* Analyze a product before calling [get_const]: the machinery in - [Jkind.Const.to_out_jkind_const] works better for atomic layouts, not - products. *) - | Layout (Product lays) -> - Ojkind_product - (List.map - (fun layout -> - out_jkind_of_desc env { desc with base = Layout layout }) - lays) - | _ -> match Jkind.Desc.get_const desc with - | Some c -> out_jkind_of_const_jkind env c - | None -> assert false (* handled above *) - -(* returns None for [value], according to (C2.1) from - Note [When to print jkind annotations] *) -(* CR layouts v2.8: This should use the annotation in the jkind, if there - is one. But first that annotation needs to be in Typedtree, not in - Parsetree. Internal ticket 4435. *) -let out_jkind_option_of_jkind ~ignore_null env jkind = - let desc = Jkind.get jkind in - let elide = - Jkind.is_value_for_printing ~ignore_null env jkind (* C2.1 *) - || (match desc.base with - | Layout (Sort (Var _, _)) -> not !Clflags.verbose_types (* X1 *) - | _ -> false) - in - if elide then None else Some (out_jkind_of_desc env desc) - -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 outcome_label : Types.arg_label -> Outcometree.arg_label = function - | Nolabel -> Nolabel - | Labelled l -> Labelled l - | Optional l -> Optional l - | Position l -> Position l - -(** Un-interpret modalities back to outcome tree. Takes the mutability and - attributes on the field and removes mutable-implied modalities - accordingly. *) -let tree_of_modalities mut t = - t - |> Typemode.least_modalities ~include_implied:false ~mut - |> Typemode.sort_dedup_modalities - |> List.map (fun (Atom (ax, m) : Modality.atom) -> - Fmt.asprintf "%a" (Modality.Per_axis.print ax) m) - -let tree_of_modes (modes : Mode.Alloc.Const.t) = - (* Step 1: Compute the modes to print *) - let diff = - - (* [forkable] has implied defaults depending on [areality]: *) - let forkable = - match modes.areality, modes.forkable with - | Local, Unforkable | Global, Forkable -> None - | _, _ -> Some modes.forkable - in - - (* [yielding] has implied defaults depending on [areality]: *) - let yielding = - match modes.areality, modes.yielding with - | Local, Yielding | Global, Unyielding -> None - | _, _ -> Some modes.yielding - in - - (* [contention] has implied defaults based on [visibility]: *) - let contention = - match modes.visibility, modes.contention with - | Immutable, Contended - | Read, Shared - | Write, Corrupted - | Read_write, Uncontended -> None - | _, _ -> Some modes.contention - in - - (* [portability] has implied defaults based on [statefulness]: *) - let portability = - match modes.statefulness, modes.portability with - | Stateless, Portable - | Reading, Shareable - | Writing, Corruptible - | Stateful, Nonportable -> None - | _, _ -> Some modes.portability - in - - let diff = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy in - { diff with forkable; yielding; contention; portability } - in - (* Step 2: Print the modes *) - let print_to_string_opt print a = Option.map (Fmt.asprintf "%a" print) a in - let modes = - [ print_to_string_opt Mode.Locality.Const.print diff.areality - ; print_to_string_opt Mode.Uniqueness.Const.print diff.uniqueness - ; print_to_string_opt Mode.Linearity.Const.print diff.linearity - ; print_to_string_opt Mode.Portability.Const.print diff.portability - ; print_to_string_opt Mode.Contention.Const.print diff.contention - ; print_to_string_opt Mode.Forkable.Const.print diff.forkable - ; print_to_string_opt Mode.Yielding.Const.print diff.yielding - ; print_to_string_opt Mode.Statefulness.Const.print diff.statefulness - ; print_to_string_opt Mode.Visibility.Const.print diff.visibility ] - in - List.filter_map (fun x -> x) modes - -(** The modal context on a type when printing it. This is to reproduce the mode - currying logic in [typetexp.ml], so that parsing and printing roundtrip. *) -type modal = - | Arrow_return of - { acc : Mode.Alloc.Const.t; - mode : Mode.Alloc.lr; } - (** This is the RHS (say [r]) of an arrow type, where [mode] is the real - mode of [r]. and: - - If [r] is also an arrow type, then [acc] is how users would interpret - [r]'s mode, if [r] doesn't have any parens aound it. - - If [r] is not an arrow type, in which case [acc] is meaningless. - - The callee is responsible for printing the type with the modes, with parens - if needed. - - Note that if [r] is an aliased type (e.g., [(int -> 'r) as 'r]), it will be - treated as NOT an arrow type, to align with the currying logic in - [typetexp.ml]. - - If [r] is [Tpoly (Tarrow_, [])], it will be treated as NOT an arrow type. - This gives tedious (but still correct) printing. *) - - | Other of Mode.Alloc.Const.t - (** In other cases, the caller has already printed the modes (as the - constructor argument) on the type. *) - -type typobject_repr = { fields : (string * type_expr) list; open_row : bool } - -type typvariant_repr = { - fields : (string * bool * type_expr list) list; - name : (Path.t * type_expr list) option; - closed : bool; - present : (string * row_field) list; - all_present : bool; - tags : string list option -} - -let rec tree_of_modal_typexp mode modal ty = - let not_arrow tree = - match modal with - | Arrow_return {mode; _} -> - let mode = Alloc.zap_to_legacy mode in - Otyp_ret (Orm_any (tree_of_modes mode), tree) - | Other _ -> tree - in - let ty = - Ctype.reduce_head ~expand_eval:!print_reduced_evals !printing_env ty - in - 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 - not_arrow (Otyp_var (non_gen, name)) else - - let pr_typ alloc_mode = - 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, marg, mret), ty1, ty2, _) -> - let lab = - if !print_labels || is_omittable l then outcome_label l - else Nolabel - in - (* [marg] will contain undetermined axes. It would be imprecise if we - don't print anything for those axes, since user would interpret that - as legacy. The best we can do is to zap to legacy and if they do land - at legacy, we will be able to omit printing them. *) - let arg_mode = Alloc.zap_to_legacy marg in - let t1 = - if is_optional l then - match - get_desc (Ctype.expand_head !printing_env (tpoly_get_mono ty1)) - with - | Tconstr(path, [ty], _) - when Path.same path Predef.path_option -> - tree_of_typexp mode arg_mode ty - | _ -> Otyp_stuff "" - else - tree_of_typexp mode arg_mode ty1 - in - let acc_mode = curry_mode alloc_mode arg_mode in - let modal = Arrow_return {acc = acc_mode; mode = mret} in - let t2 = tree_of_modal_typexp mode modal ty2 in - Otyp_arrow (lab, tree_of_modes arg_mode, t1, t2) - | Ttuple labeled_tyl -> - Otyp_tuple (tree_of_labeled_typlist mode labeled_tyl) - | Tunboxed_tuple labeled_tyl -> - Otyp_unboxed_tuple (tree_of_labeled_typlist mode labeled_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 Alloc.Const.legacy (List.hd tyl') - else begin - Internal_names.add p'; - Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') - end - | Tvariant row -> - let { fields; name; closed; present; all_present; tags } = - tree_of_typvariant_repr row - in - begin match name with - | Some(p, tyl) when nameable_row row -> - let (p', s) = best_type_path p in - let id = tree_of_path (Some Type) 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 - (fun (l, c, tyl) -> (l, c, tree_of_typlist mode tyl)) fields - in - Otyp_variant (Ovar_fields fields, closed, tags) - end - | Tobject (fi, nm) -> - tree_of_typobject mode fi !nm - | Tquote ty -> - wrap_printing_env_unguarded - (Env.enter_quotation !printing_env) - (fun () -> Otyp_quote (tree_of_typexp mode alloc_mode ty)) - | Tsplice ty -> - wrap_printing_env_unguarded - (Env.enter_splice ~loc:Location.none !printing_env) - (fun () -> Otyp_splice (tree_of_typexp mode alloc_mode ty)) - | Tquote_eval ty -> - (* We use [Predef]'s [eval] as the syntax, so we need to quote [ty]. *) - let ty = newgenty (Tquote ty) in - let p', s = best_type_path Predef.path_eval in - let tyl = apply_subst s [ty] in - Internal_names.add p'; - let tyl = - wrap_printing_env_unguarded - (Env.enter_quotation !printing_env) - (fun () -> tree_of_typlist mode tyl) - in - Otyp_constr (tree_of_path (Some Type) p', tyl) - | 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, []) | Trepr (ty, []) -> - tree_of_typexp mode alloc_mode ty - | Tpoly (ty, tyl) -> - (*let print_names () = - List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; - prerr_string "; " in *) - 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 = tree_of_qtvs tyl in - let tr = Otyp_poly (tl, tree_of_typexp mode alloc_mode ty) in - (* Forget names when we leave scope *) - Names.remove_names tyl; - delayed := old_delayed; tr - | Trepr (ty, sort_vars) -> - (* Trepr wraps a Tpoly that contains the type variables - corresponding to the sort variables. Extract them and print. *) - (match get_desc ty with - | Tpoly (inner_ty, (_ :: _ as tyl)) -> - (* Check that the sort_vars match the jkinds of tyl *) - let sorts_match = - match - List.for_all2 - (fun sort_var ty -> - match get_desc ty with - | Tunivar { jkind } -> - (match Jkind.get_layout !printing_env jkind with - | Some layout -> - (match Jkind.Layout.Const.get_sort layout with - | Some (Jkind.Sort.Const.Univar uv) -> - uv == sort_var - | _ -> false) - | None -> false) - | _ -> false) - sort_vars tyl - with - | result -> result - | exception Invalid_argument _ -> false - in - if sorts_match then begin - let tyl = List.map Transient_expr.repr tyl in - let old_delayed = !delayed in - List.iter add_delayed tyl; - let sort_names = tree_of_qsvs tyl in - let tr = - Otyp_repr (sort_names, tree_of_typexp mode alloc_mode inner_ty) - in - Names.remove_names tyl; - delayed := old_delayed; - tr - end else - (* Mismatch: print Trepr and Tpoly separately *) - tree_of_typexp mode alloc_mode ty - | _ -> - (* No type variables, just print the body *) - tree_of_typexp mode alloc_mode ty) - | 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 Alloc.Const.legacy ty - )) fl in - Otyp_module (tree_of_path (Some Module_type) p, fl) - | Tof_kind jkind -> - Otyp_of_kind (out_jkind_of_desc !printing_env (Jkind.get jkind)) - 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 - let tree = - Otyp_alias {non_gen; aliased = pr_typ Mode.Alloc.Const.legacy; alias } - in - not_arrow tree end - else - match modal with - | Arrow_return {acc; mode} -> - let rm, alloc_mode = tree_of_ret_typ_mutating acc mode ty in - let ty = pr_typ alloc_mode in - Otyp_ret (rm, ty) - | Other m -> pr_typ m - -and tree_of_typexp mode alloc_mode ty = - tree_of_modal_typexp mode (Other alloc_mode) ty - -(* qtvs = quantified type variables *) -(* this silently drops any arguments that are not generic Tvar or Tunivar *) -and tree_of_qtvs qtvs = - let tree_of_qtv v : (string * out_jkind option) option = - (* CR layouts: We ignore nullability here to avoid needlessly printing - ['a : value_or_null] when it's not relevant (most cases). - Unfortunately, this makes error messages really confusing, because - we don't consider jkind annotations. *) - let tree jkind = - Some (Names.name_of_type Names.new_name v, - out_jkind_option_of_jkind ~ignore_null:true !printing_env jkind) - in - match v.desc with - | Tvar { jkind } when v.level = generic_level -> tree jkind - | Tunivar { jkind } -> tree jkind - | _ -> None - in - List.filter_map tree_of_qtv qtvs - -(* qsvs = quantified sort variables (for Trepr) *) -(* Extract names from type variables corresponding to sort variables *) -and tree_of_qsvs qtvs = - List.filter_map - (fun v -> - match v.desc with - | Tvar _ when v.level = generic_level -> - Some (Names.name_of_type Names.new_name v) - | Tunivar _ -> Some (Names.name_of_type Names.new_name v) - | _ -> None) - qtvs - -and tree_of_row_field (l, f) = - match row_field_repr f with - | Rpresent None | Reither(true, [], _) -> (l, false, []) - | Rpresent(Some ty) -> (l, false, [ty]) - | Reither(c, tyl, _) -> - if c (* contradiction: constant constructor with an argument *) - then (l, true, tyl) - else (l, false, tyl) - | Rabsent -> (l, false, [] (* actually, an error *)) - -and tree_of_typvariant_repr 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 - let fields = List.map tree_of_row_field fields in - let tags = - if all_present then None else Some (List.map fst present) in - { fields; name; closed; present; all_present; tags } - -and tree_of_typlist mode tyl = - List.map (tree_of_typexp mode Alloc.Const.legacy) tyl - -and tree_of_labeled_typlist mode tyl = - List.map (fun (label, ty) -> label, tree_of_typexp mode Alloc.Const.legacy ty) tyl - -and tree_of_typ_gf {ca_type=ty; ca_modalities=gf; _} = - (tree_of_typexp Type Alloc.Const.legacy ty, - tree_of_modalities Immutable gf) - -(** NB: This function might mutate states; the caller is responsible for - reverting them. *) -and tree_of_ret_typ_mutating acc_mode m ty= - match get_desc ty with - | Tarrow _ -> begin - (* We first try to equate [m] with the [acc_mode]; if that succeeds, we - can omit parens and modes. *) - match Alloc.equate (Alloc.of_const acc_mode) m with - | Ok () -> - (Orm_no_parens, acc_mode) - | Error _ -> - (* In this branch we need to print parens. [m] might have undetermined - axes and we adopt a similar logic to the [marg] above. *) - let m = Alloc.zap_to_legacy m in - (Orm_parens (tree_of_modes m), m) - end - | _ -> - let m = Alloc.zap_to_legacy m in - (Orm_any (tree_of_modes m), m) - -and tree_of_typobject_repr 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 - let fields, open_row = tree_of_typfields rest sorted_fields in - { fields; open_row } - -and tree_of_typobject mode fi nm = - begin match nm with - | None -> - let { fields; open_row } = tree_of_typobject_repr fi in - let fields = - List.map - (fun (s, t) -> (s, tree_of_typexp mode Alloc.Const.legacy t)) - fields - 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_path (Some Type) p', args) - | _ -> - fatal_error "Printtyp.tree_of_typobject" - end - -and tree_of_typfields rest = function - | [] -> - let open_row = - match get_desc rest with - | Tvar _ | Tunivar _ | Tconstr _-> true - | Tnil -> false - | _ -> fatal_error "typfields (1)" - in - ([], open_row) - | field :: l -> - let (fields, rest) = tree_of_typfields rest l in - (field :: fields, rest) - -let tree_of_typexp mode ty = - (* [tree_of_typexp] mutates state, which we need to backtrack. *) - wrap_mutation (fun () -> tree_of_typexp mode Alloc.Const.legacy ty) - -let tree_of_typexp mode ty = - (* CR metaprogramming jbachurski: Remove this [Env.enter_future] hack once - errors track their stage, as we should usually print at stage 0. - See ticket 6726. *) - if Ctype.contains_toplevel_splice (Env.stage !printing_env :> int) ty - then - wrap_printing_env_unguarded - (Env.enter_future !printing_env) - (fun () -> tree_of_typexp mode ty) - else - tree_of_typexp mode ty - -let typexp mode ppf ty = - !Oprint.out_type ppf (tree_of_typexp mode ty) - -(* Only used for printing a single modality in error message *) -let modality ?(id = fun _ppf -> ()) ax ppf modality = - if Mode.Modality.Per_axis.is_id ax modality then id ppf - else - Fmt.asprintf "%a" (Mode.Modality.Per_axis.print ax) modality - |> !Oprint.out_modality ppf - -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_path (Some Type) p'' in - !Oprint.out_ident ppf t - -let tree_of_type_scheme ty = - prepare_for_printing [ty]; - tree_of_typexp Type_scheme ty + | Optional s -> "?" ^ s +let () = Jkind.set_printtyp_path Doc.path +let () = Mode.print_longident := Doc.longident let () = - Env.print_type_expr := type_expr; Env.report_jkind_violation_with_offender := Jkind.Violation.report_with_offender; Jkind.set_outcometrees_of_types (fun tys -> prepare_for_printing tys; List.map (tree_of_typexp Type) tys); Jkind.set_outcometree_of_modalities tree_of_modalities; - Jkind.set_print_type_expr type_expr; - Jkind.set_raw_type_expr (compat raw_type_expr) - -(* 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 [None, 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 args = - List.iter prepare_type (tys_of_constr_args args) - -(* returns an empty list if no variables in the list have a jkind annotation *) -let zap_qtvs_if_boring qtvs = - if List.exists (fun (_v, l) -> Option.is_some l) qtvs - then qtvs - else [] - -(* get the free variables with their jkinds; do this *after* converting the - type itself, so that the type names are available. - This implements Case (C3) from Note [When to print jkind annotations]. *) -let extract_qtvs tyl = - let fvs = Ctype.free_non_row_variables_of_list tyl in - (* The [Ctype.free*variables] family of functions returns the free - variables in reverse order they were encountered in the list of types. - *) - let fvs = List.rev fvs in - let tfvs = List.map Transient_expr.repr fvs in - let vars_jkinds = tree_of_qtvs tfvs in - zap_qtvs_if_boring vars_jkinds - -let param_jkind ty = - match get_desc ty with - | Tvar { jkind; _ } | Tunivar { jkind; _ } -> - out_jkind_option_of_jkind ~ignore_null:false !printing_env jkind - | _ -> None (* this is (C2.2) from Note [When to print jkind annotations] *) - -let tree_of_label l = - let mut = - match l.ld_mutable with - | Mutable { mode; atomic } -> - let atomic = - match atomic with - | Atomic -> Atomic - | Nonatomic -> Nonatomic - in - let mut = - let open Value.Comonadic in - match equate mode legacy with - | Ok () -> Om_mutable (None, atomic) - | Error _ -> Om_mutable (Some "", atomic) - in - mut - | Immutable -> Om_immutable - in - let ld_modalities = tree_of_modalities l.ld_mutable l.ld_modalities in - (Ident.name l.ld_id, mut, tree_of_typexp Type l.ld_type, ld_modalities) - -let tree_of_constructor_arguments = function - | Cstr_tuple l -> List.map tree_of_typ_gf l - | Cstr_record l -> [ Otyp_record (List.map tree_of_label l), [] ] - -let tree_of_constructor_args_and_ret_type args ret_type = - match ret_type with - | None -> (tree_of_constructor_arguments args, None) - | Some res -> - let out_ret = tree_of_typexp Type res in - let out_args = tree_of_constructor_arguments args in - let qtvs = extract_qtvs (res :: tys_of_constr_args args) in - (out_args, Some (qtvs, out_ret)) - -let tree_of_single_constructor cd = - let name = Ident.name cd.cd_id in - let args, ret = tree_of_constructor_args_and_ret_type cd.cd_args cd.cd_res 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 -> - match get_desc ty with - | Tvar { name = Some "_"; jkind } - when List.exists (eq_type ty) vars -> - set_type_desc ty (Tvar {name = None; jkind}) - | _ -> ()) - 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,_umc) -> - List.iter - (fun c -> - prepare_type_constructor_arguments c.cd_args; - Option.iter prepare_type c.cd_res) - cstrs - | Type_record(l, _rep,_umc) -> - List.iter (fun l -> prepare_type l.ld_type) l - | Type_record_unboxed_product(l, _rep,_umc) -> - 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 ot_jkind = - function - | Otyp_var (ot_non_gen, ot_name) -> - {ot_non_gen; ot_name; ot_variance; ot_jkind} - | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} - 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_record_unboxed_product _ -> - decl.type_private = Private - | Type_variant (tll, _rep,_umc) -> - 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 - let mk_param ty variance = - let jkind = param_jkind ty in - type_param variance jkind (tree_of_typexp Type ty) - in - (Ident.name id, - List.map2 mk_param 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, or_null_attribute, unsafe_mode_crossing = - match decl.type_kind with - | Type_abstract _ -> - begin match ty_manifest with - | None -> (Otyp_abstract, Public, false, None, false) - | Some ty -> - tree_of_typexp Type ty, decl.type_private, false, None, false - end - | Type_variant (cstrs, rep, umc) -> - let unboxed = - match rep with - | Variant_unboxed -> true - | Variant_boxed _ | Variant_extensible | Variant_with_null -> false - in - let or_null_attribute = - if Builtin_attributes.has_or_null decl.type_attributes then - Some "or_null" - else if Builtin_attributes.has_or_null_reexport decl.type_attributes - then Some "or_null_reexport" - else None - in - tree_of_manifest (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), - decl.type_private, - unboxed, - or_null_attribute, - (Option.is_some umc) - | Type_record(lbls, rep, umc) -> - tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), - decl.type_private, - (match rep with Record_unboxed -> true | _ -> false), - None, - (Option.is_some umc) - | Type_record_unboxed_product(lbls, Record_unboxed_product, umc) -> - tree_of_manifest - (Otyp_record_unboxed_product (List.map tree_of_label lbls)), - decl.type_private, - false, - None, - (Option.is_some umc) - | Type_open -> - tree_of_manifest Otyp_open, - decl.type_private, - false, - None, - false - in - (* The algorithm for setting [lay] here is described as Case (C1) in - Note [When to print jkind annotations] *) - let is_value = - Jkind.is_value_for_printing ~ignore_null:false !printing_env decl.type_jkind - in - let otype_jkind = - match ty, is_value, unsafe_mode_crossing with - | (Otyp_abstract, false, _) | (_, _, true) -> - (* The two cases of (C1) from the Note correspond to Otyp_abstract. - Anything but the default must be user-written, so we print the - user-written annotation. *) - (* unsafe_mode_crossing corresponds to C1.2 *) - Some (out_jkind_of_desc !printing_env (Jkind.get decl.type_jkind)) - | _ -> None (* other cases have no jkind annotation *) - in - let attrs = - if unsafe_mode_crossing - then [{ oattr_name = "unsafe_allow_any_mode_crossing" }] - else [] - in - { otype_name = name; - otype_params = args; - otype_type = ty; - otype_private = priv; - otype_jkind; - otype_unboxed = unboxed; - otype_or_null_attribute = or_null_attribute; - otype_cstrs = constraints; - otype_attributes = attrs } - -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_constr_args ppf tys - -(* Print an extension declaration *) - -(* 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 = - tree_of_constructor_args_and_ret_type - 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 = - tree_of_constructor_args_and_ret_type - ext.ext_args - ext.ext_ret_type - in - Fmt.fprintf ppf "@[%a@]" - !Oprint.out_constr { - ocstr_name = name; - ocstr_args = args; - ocstr_return_type = ret; - } - -(* 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 ty = tree_of_type_scheme decl.val_type in - (* Important: process the fvs *after* the type; tree_of_type_scheme - resets the naming context *) - wrap_mutation (fun () -> - let moda = - if Mode.Modality.is_undefined decl.val_modalities then - Mode.Modality.Const.id - else - Ctype.zap_modalities_to_floor_if_modes_enabled_at Alpha - decl.val_modalities - in - let qsvs, qtvs = - (* Important: process the fvs *after* the type; tree_of_type_scheme - resets the naming context. Both must be inside print_with_genvars - so that sort poly var names are registered when jkinds are printed. *) - Jkind_types.Sort.print_with_genvars (Lpoly.get_exn decl.val_lpoly) - (fun names -> names, extract_qtvs [decl.val_type]) - in - let apparent_arity = - let rec count n typ = - match get_desc typ with - | Tarrow (_,_,typ,_) -> count (n+1) typ - | _ -> n - in - count 0 decl.val_type - in - let attrs = - match Zero_alloc.get decl.val_zero_alloc with - | Default_zero_alloc | Ignore_assert_all -> [] - | Check { strict; opt; arity; custom_error_msg; loc = _; } -> - [{ oattr_name = - String.concat "" - ["zero_alloc"; - if strict then " strict" else ""; - if opt then " opt" else ""; - if arity = apparent_arity then "" else - Printf.sprintf " arity %d" arity; - match custom_error_msg with - | None -> "" - | Some msg -> Printf.sprintf " custom_error_message %S" msg - ] }] - | Assume { strict; never_returns_normally; arity; _ } -> - [{ oattr_name = - String.concat "" - ["zero_alloc assume"; - if strict then " strict" else ""; - if never_returns_normally then " never_returns_normally" else ""; - if arity = apparent_arity then "" else - Printf.sprintf " arity %d" arity; - ] - }] - in - let vd = - { oval_name = id; - oval_type = Otyp_newlayout(qsvs, Otyp_poly(qtvs, ty)); - oval_modalities = tree_of_modalities Immutable moda; - oval_prims = []; - oval_attributes = attrs - } - 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 - let tyl = List.map Transient_expr.repr tyl in - let qtvs = tree_of_qtvs tyl in - let qtvs = zap_qtvs_if_boring qtvs in - Names.remove_names tyl; - let priv = priv <> Mpublic in - let virt = virt = Virtual in - Ocsg_method (lab, priv, virt, Otyp_poly(qtvs, 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) - || deep_occur_list 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 = Asttypes.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_omittable l then outcome_label l - else Nolabel - in - let tr = - if is_optional l then - match get_desc (Ctype.expand_head !printing_env 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 - (* CR layouts: fix next line when adding support for jkind - annotations on class type parameters *) - let ot_jkind = param_jkind param in - match tree_of_typexp Type_scheme param with - Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance; ot_jkind} - | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} - -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_jkind = Jkind.Builtin.any ~why:Dummy_jkind; - type_ikind = Types.ikinds_todo "print dummy"; - 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_unboxed_default = false; - type_uid = Uid.internal_not_actually_unique; - type_unboxed_version = None; - } - -(** 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_jkind (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.is_global_or_predef 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 expand_module_type = - ref ((fun _env _mty -> assert false) : - Env.t -> module_type -> module_type) - -(** How to abbreviate signatures *) -module Abbrev = struct - (* The code is substantially simpler if [width] is mutable. Strictly speaking, [depth] - doesn't have to be mutable here but mixed mutability would be quite confusing. *) - type t = - { (* To what depth to unfold the module tree *) - mutable depth : int - (* How many signature items to print in total across all signatures *) - ; mutable width : int - } - - (** Standard abbreviation heuristic *) - let abbrev () = - { depth = 4 - ; width = 16 - } - - (** Don't print any signature items *) - let ellipsis () = - { depth = 0 - ; width = 0 - } - - (** Should we print anything in this signature *) - let exhausted = function - | Some {depth; width} -> depth <= 0 || width <= 0 - | None -> false - - (** Run [f] at one deeper unfolding level *) - let deeper t f = - match t with - | Some t -> - let saved = t.depth in - t.depth <- t.depth - 1; - let x = f () in - t.depth <- saved; - x - | None -> f () - - (** Reduce the remaining width by the number of items in [sg] and return the number of - items to print in [sg] and a flag that inidicates whether [sg] is being trimmed. *) - let items t sg = - match t with - | Some t -> - let n = List.length sg in - let k = min t.width n in - t.width <- t.width - n; - Some k, (k < n) - | None -> - None, false -end - -let tree_of_jkind_declaration id decl = - let ojkind = - { ojkind_name = Ident.name id - ; ojkind_jkind = - Option.map - (fun jkind -> - jkind |> Jkind.Desc.of_const |> out_jkind_of_desc !printing_env) - decl.jkind_manifest - } - in - Osig_jkind ojkind - -let rec tree_of_modtype ?abbrev = function - | Mty_ident p -> - Omty_ident (tree_of_path (Some Module_type) p) - | Mty_signature sg -> - Omty_signature (tree_of_signature ?abbrev sg) - | Mty_functor(param, ty_res, m_res) -> - wrap_mutation (fun () -> - let param, env = - tree_of_functor_parameter ?abbrev param - in - let res = wrap_env env (tree_of_modtype ?abbrev) ty_res in - let mres = m_res |> Mode.Alloc.zap_to_legacy |> tree_of_modes in - Omty_functor (param, res, mres)) - | Mty_alias p -> - Omty_alias (tree_of_path (Some Module) p) - | Mty_strengthen _ as mty -> - begin match !expand_module_type !printing_env mty with - | Mty_strengthen (mty,p,a) -> - let unaliasable = - not (Aliasability.is_aliasable a) - && not (Env.is_functor_arg p !printing_env) - in - Omty_strengthen - (tree_of_modtype ?abbrev mty, tree_of_path (Some Module) p, unaliasable) - | mty -> tree_of_modtype ?abbrev mty - end - -and tree_of_functor_parameter ?abbrev = function - | Unit -> - None, fun k -> k - | Named (param, ty_arg, m_arg) -> - let name, env = - match param with - | None -> None, fun env -> env - | Some id -> - Some (Ident.name id), - fun k -> Env.add_module ~arg:true id Mp_present ty_arg k - in - let marg = m_arg |> Mode.Alloc.zap_to_legacy |> tree_of_modes in - Some (name, tree_of_modtype ?abbrev ty_arg, marg), env - -and tree_of_signature ?abbrev = function - | [] -> [] - | _ when Abbrev.exhausted abbrev -> [Osig_ellipsis] - | sg -> - Abbrev.deeper abbrev (fun () -> - wrap_env (fun env -> env)(fun sg -> - (* Only expand signatures to 'abbrev.depth' depth and print at most 'abbrev.width' - items overall. We just keep decreasing 'abbrev.width' during the traversal but - make sure that we expand the current signature up to 'abbrev.width' before - expanding it's components. Below, 'max_items' is the number of items we should - print in the current signature and 'abbrev.width' is then be the remaining - number of items. This is simpler to implement than proper breadth-first. *) - let max_items, trimmed = Abbrev.items abbrev sg in - let tree_groups = tree_of_signature_rec ?abbrev ?max_items !printing_env sg in - let items = List.concat_map (fun (_env,l) -> List.map snd l) tree_groups in - if trimmed then items @ [Osig_ellipsis] else items - ) sg - ) - -and tree_of_signature_rec ?abbrev ?max_items env' sg = - let structured = List.of_seq (Signature_group.seq sg) in - (* Don't descent into more than 'max_items' (if set) elements to save time. *) - let collect_trees_of_rec_group max_items group = - match max_items with - | Some n when n <= 0 -> (max_items, (!printing_env, [])) - | Some _ | None -> - let env = !printing_env in - let env', group_trees = - Naming_context.with_ctx - (fun () -> trees_of_recursive_sigitem_group ?abbrev env group) - in - set_printing_env env'; - let max_items, group_trees = match max_items with - | None -> None, group_trees - | Some n -> - let rec take n acc xs = - match n, xs with - | 0, _ | _, [] -> n, List.rev acc - | n, x :: xs -> take (n-1) (x :: acc) xs - in - let n, group_trees = take n [] group_trees in - Some n, group_trees - in - max_items, (env, group_trees) - in - set_printing_env env'; - snd (List.fold_left_map collect_trees_of_rec_group max_items structured) - -and trees_of_recursive_sigitem_group ?abbrev env - (syntactic_group: Signature_group.rec_group) = - let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem ?abbrev 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 ?abbrev = 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 abbrev = - if List.exists (function - | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true - | _ -> false) - md.md_attributes - then Some (Abbrev.ellipsis ()) - else abbrev - in - tree_of_module ?abbrev id md rs - | Sig_modtype(id, decl, _) -> - tree_of_modtype_declaration ?abbrev 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 - | Sig_jkind(id, decl, _) -> - tree_of_jkind_declaration id decl - -and tree_of_modtype_declaration ?abbrev id decl = - let mty = - match decl.mtd_type with - | None -> Omty_abstract - | Some mty -> tree_of_modtype ?abbrev mty - in - Osig_modtype (Ident.name id, mty) - -and tree_of_module ?abbrev id md rs = wrap_mutation (fun () -> - let moda = - if Mode.Modality.is_undefined md.md_modalities then - Mode.Modality.Const.id - else - Ctype.zap_modalities_to_floor_if_at_least Alpha md.md_modalities - in - Osig_module (Ident.name id, tree_of_modtype ?abbrev md.md_type, - tree_of_modalities Immutable moda, - tree_of_rec rs) - ) - -let rec functor_parameters ~sep custom_printer = function - | [] -> ignore - | [id,param] -> - Fmt.dprintf "%t%t" - (custom_printer param) - (functor_param ~sep ~custom_printer id []) - | (id,param) :: q -> - Fmt.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(); - reset_naming_context (); - 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 - -(* Print a signature body (used by -i when compiling a .ml) *) - -let print_signature ppf tree = - fprintf ppf "@[%a@]" !Oprint.out_signature tree - -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 (); - reset_naming_context (); - let t = tree_of_signature sg in - if Warnings.(is_active @@ Erroneous_printed_signature "") - && Conflicts.exists () - then begin - let conflicts = Format_doc.asprintf "%t" Conflicts.print_explanations in - Location.prerr_warning (Location.in_file sourcefile) - (Warnings.Erroneous_printed_signature conflicts); - Warnings.check_fatal () - end; - compat print_signature ppf 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' - ~var_jkinds mode Errortrace.{ty = t; expanded = t'} = - let tree_of_typexp' ty = - let out = tree_of_typexp mode ty in - if var_jkinds then - match get_desc ty with - | Tvar { jkind; _ } | Tunivar { jkind; _ } -> - let okind = out_jkind_of_desc !printing_env (Jkind.get jkind) in - Otyp_jkind_annot (out, okind) - | _ -> - out - else - out - in - reset_loop_marks (); - mark_loops t; - if same_path t t' - then begin add_delayed (proxy t); Same (tree_of_typexp' 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 *) - print_reduced_evals := false; (* preserve unreduced eval in types *) - let first = tree_of_typexp' t in - print_reduced_evals := true; - let second = tree_of_typexp' t' in - if first = second then Same first - else Diff(first,second) - end - -let trees_of_type_expansion = - trees_of_type_expansion' ~var_jkinds:false - -let pp_type ppf t = - Style.as_inline_code !Oprint.out_type ppf t - -let quoted_ident ppf t = - Style.as_inline_code !Oprint.out_ident ppf t - -let type_expansion ppf = function - | Same t -> pp_type ppf t - | Diff(t,t') -> - fprintf ppf "@[<2>%a@ =@ %a@]" - pp_type t - pp_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 -> quoted_ident ppf p - | Diff(p,p') -> - fprintf ppf "@[<2>%a@ =@ %a@]" - quoted_ident p - quoted_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 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 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 - -(* 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) - (Jkind.Builtin.value ~why:Row_variable)))) - | _ -> 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 = - Fmt.dprintf "%a" !Oprint.out_ident (tree_of_path (Some 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_arg env ty = - let ty, vars = tpoly_get_poly ty in - if vars <> [] then false - else begin - match get_desc (Ctype.expand_head env ty) with - | Tconstr (p, _, _) -> Path.same p Predef.path_unit - | _ -> false - end - -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 = - match get_desc t3, get_desc t4 with - | Tarrow (_, ty1, ty2, _), _ - when is_unit_arg 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_arg 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 explain_fixed_row pos expl = match expl with - | Fixed_private -> - doc_printf "The %a variant type is private" Errortrace.print_pos pos - | Univar x -> - reserve_names 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 - | 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 - | Rigid -> Format_doc.Doc.empty - | Fixed_existential -> 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 | Fixed_existential)) -> - (* 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 -> - reserve_names 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 (Style.as_inline_code path) p - ) - | Errortrace.Module_type p -> Some( - doc_printf - "%a@,@[The module type@;<1 2>%a@ would escape its scope@]" - pp_doc pre (Style.as_inline_code path) p - ) - | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> - reserve_names 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) = - reserve_names diff.got; - reserve_names 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 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; - 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.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 _ -> - mark_loops x; - mark_loops y; - 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 - | Errortrace.Bad_jkind (t,e) -> - Some (doc_printf "@ @[%a@]" - (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> type_expr ppf t) - env) e) - | Errortrace.Bad_jkind_sort (t,e) -> - Some (doc_printf "@ @[%a@]" - (Jkind.Violation.report_with_offender_sort - ~offender:(fun ppf -> type_expr ppf t) - env) e) - | Errortrace.Unequal_var_jkinds (t1,k1,t2,k2) -> - let fmt_history t k ppf = - Jkind.(format_history env ~intro:( - dprintf "The layout of %a is %a" prepared_type_expr t - (format env) k) ppf k) - in - Some (doc_printf "@ because the layouts of their variables are different.\ - @ @[%t@;%t@]" - (fmt_history t1 k1) (fmt_history t2 k2)) - | Errortrace.Unequal_tof_kind_jkinds (k1, k2) -> - let fmt_history which k ppf = - Jkind.(format_history env ~intro:( - dprintf "The kind of %s is %a" which (format env) k) ppf k) - in - Some (doc_printf "@ because their kinds are different.\ - @ @[%t@;%t@]" - (fmt_history "the first" k1) (fmt_history "the second" k2)) - -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 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 ~var_jkinds mode txt_got txt_but = function - | None -> Format_doc.Doc.empty - | Some d -> - let d = - Errortrace.map_diff (trees_of_type_expansion' ~var_jkinds mode) d - in - doc_printf "%a@;<1 2>%a@ %a@;<1 2>%a" - pp_doc txt_got type_expansion d.Errortrace.got - pp_doc 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 jkind_error = match Misc.last tr with - | Some (Bad_jkind _ | Bad_jkind_sort _ | Unequal_var_jkinds _ - | Unequal_tof_kind_jkinds _) -> - true - | Some (Diff _ | Escape _ | Variant _ | Obj _ | Incompatible_fields _ - | Rec_occur _) - | None -> - false - in - match tr with - | [] -> assert false - | (elt :: tr) as full_trace -> - try - print_labels := not !Clflags.classic; - 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 ~var_jkinds:jkind_error 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 && not jkind_error - (* the jkinds mechanism has its own way of reporting missing cmis *) - 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; - print_reduced_evals := true; - raise exn - -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 report_unification_error ?type_expected_explanation - ppf env ({trace} : Errortrace.unification_error) = - report_error ?type_expected_explanation 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, 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; - print_labels := true - | _ -> () - with exn -> - print_labels := true; - raise exn - - 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 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 (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 - 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 - "@[%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) - -(* Adapt functions to exposed interface *) -let abbreviate ~abbrev f = - f ?abbrev:(if abbrev then Some (Abbrev.abbrev ()) else None) - -let tree_of_path = tree_of_path None -let tree_of_module ident ?(ellipsis = false) = - tree_of_module ident ?abbrev:(if ellipsis then Some (Abbrev.ellipsis ()) else None) -let tree_of_signature sg = tree_of_signature sg -let tree_of_modtype ?(abbrev = false) ty = - abbreviate ~abbrev tree_of_modtype ty -let tree_of_modtype_declaration ?(abbrev = false) id md = - abbreviate ~abbrev tree_of_modtype_declaration id md -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) - -(** Compatibility module for Format printers *) -module Compat = struct - let longident = Fmt.compat longident - let path = Fmt.compat path - let type_expr = Fmt.compat type_expr - let shared_type_scheme = Fmt.compat shared_type_scheme - let signature = Fmt.compat signature - let class_type = Fmt.compat class_type - let modtype = Fmt.compat modtype - let string_of_label (lbl : Asttypes.arg_label) = - let lbl : Types.arg_label = match lbl with - | Nolabel -> Nolabel - | Labelled s -> Labelled s - | Optional s -> Optional s - in - string_of_label lbl -end + Jkind.set_print_type_expr Doc.type_expr diff --git a/upstream/ocaml_flambda/typing/printtyp.mli b/upstream/ocaml_flambda/typing/printtyp.mli index 38dcc317b..9241eadd3 100644 --- a/upstream/ocaml_flambda/typing/printtyp.mli +++ b/upstream/ocaml_flambda/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,284 +13,95 @@ (* *) (**************************************************************************) -(* Printing functions *) +(** Printing functions *) -open Format_doc -open Types -open Outcometree - -val longident: Longident.t printer -val ident: Ident.t printer -val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string -val tree_of_path: Path.t -> out_ident -val path: Path.t printer -val string_of_path: Path.t -> string - -val type_path: Path.t printer -(** 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 - -type namespace := Shape.Sig_component_kind.t option +open Types -val strings_of_paths: namespace -> Path.t list -> string list - (** Print a list of paths, using the same naming context to - avoid name collisions *) +type namespace := Shape.Sig_component_kind.t -val raw_row_desc : formatter -> row_desc -> unit -val raw_type_expr: formatter -> type_expr -> unit -val raw_field : formatter -> row_field -> unit +val namespaced_ident: namespace -> Ident.t -> string val string_of_label: Types.arg_label -> 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 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. *) - - val reset: unit -> unit - (** Reset the naming context *) -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: explanation list printer - - val print_explanations: Format_doc.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: type_expr printer - -(** Prints a modality. If it is the identity modality, prints [id], which - defaults to nothing. *) -val modality : - ?id:(formatter -> unit) -> 'a Mode.Modality.Axis.t -> formatter -> 'a -> 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: type_expr printer -(** 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: constructor_arguments printer -val tree_of_type_scheme: type_expr -> out_type -val type_scheme: type_expr printer -val prepared_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 tree_of_value_description: Ident.t -> value_description -> out_sig_item -val value_description: Ident.t -> value_description printer -val label : label_declaration printer -val add_constructor_to_preparation : constructor_declaration -> unit -val prepared_constructor : constructor_declaration printer -val constructor : constructor_declaration printer -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 type_declaration: Ident.t -> type_declaration printer -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 -> extension_constructor 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 tree_of_jkind_declaration: - Ident.t -> jkind_declaration -> out_sig_item +(** [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 -val tree_of_module: - Ident.t -> ?ellipsis:bool -> module_declaration -> rec_status - -> out_sig_item -val modtype: module_type printer -val signature: signature printer -val tree_of_modtype: ?abbrev:bool -> module_type -> out_module_type -val tree_of_modtype_declaration: - ?abbrev:bool -> Ident.t -> modtype_declaration -> out_sig_item +module type Printers := sig -val expand_module_type: (Env.t -> module_type -> module_type) ref -(* Forward declaration to be filled in Mtype. We want to be able to print types - in Mtype for debugging purposes and hence don't want to depend on Mtype - here. -*) + 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 a list of functor parameters while adjusting the printing environment - for each functor argument. + 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]. *) - 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:unit printer -> ('b -> Format_doc.formatter -> unit) -> - (Ident.t option * 'b) list -> Format_doc.formatter -> 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 -type type_or_scheme = Type | Type_scheme + (** Prints a modality. If it is the identity modality, prints [id], which + defaults to nothing. *) + val modality : ?id:unit printer -> 'a Mode.Modality.Axis.t -> 'a printer -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 -> modtype_declaration printer -val class_type: class_type printer -val tree_of_class_declaration: - Ident.t -> class_declaration -> rec_status -> out_sig_item -val class_declaration: Ident.t -> class_declaration printer -val tree_of_cltype_declaration: - Ident.t -> class_type_declaration -> rec_status -> out_sig_item -val cltype_declaration: Ident.t -> class_type_declaration printer -val type_expansion : - type_or_scheme -> Errortrace.expanded_type printer -val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type + val type_scheme: type_expr printer -module Compat: sig - (** {!Format} compatible printers *) - type 'a printer := Format.formatter -> 'a -> unit - val longident : Longident.t printer - val path: Path.t printer - val type_expr: type_expr printer - val shared_type_scheme: type_expr printer - val signature: signature printer - val modtype: module_type printer - val class_type: class_type printer - val string_of_label: Asttypes.arg_label -> string -end + 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 report_ambiguous_type_error: - formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> - Format_doc.t -> Format_doc.t -> Format_doc.t -> unit + val type_expansion: + Out_type.type_or_scheme -> Errortrace.expanded_type printer -val report_unification_error : - ?type_expected_explanation:Format_doc.t -> - formatter -> - Env.t -> Errortrace.unification_error -> - Format_doc.t -> Format_doc.t -> - unit + val label : label_declaration printer -val report_equality_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.equality_error -> - Format_doc.t -> Format_doc.t -> - unit + val constructor : constructor_declaration printer + val constructor_arguments: constructor_arguments printer -val report_moregen_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.moregen_error -> - Format_doc.t -> Format_doc.t -> - unit + val extension_constructor: + Ident.t -> extension_constructor printer + (** Prints extension constructor with the type signature: + type ('a, 'b) bar += A of float + *) -val report_comparison_error : - formatter -> - type_or_scheme -> - Env.t -> Errortrace.comparison_error -> - Format_doc.t -> Format_doc.t -> - unit + val extension_only_constructor: + Ident.t -> extension_constructor printer + (** Prints only extension constructor without type signature: + A of float + *) -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 + 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 -(* for [Translquote] *) -type typobject_repr = { fields : (string * type_expr) list; open_row : bool } -type typvariant_repr = { - fields : (string * bool * type_expr list) list; - name : (Path.t * type_expr list) option; - closed : bool; - present : (string * row_field) list; - all_present : bool; - tags : string list option -} -val tree_of_typobject_repr : type_expr -> typobject_repr -val tree_of_typvariant_repr : row_desc -> typvariant_repr -(* 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 + val modtype: module_type printer + val signature: signature printer + val class_type: class_type printer + end -val rewrite_double_underscore_longidents: Env.t -> Longident.t -> Longident.t +module Doc : Printers with type 'a printer := 'a Format_doc.printer -(** [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 +(** For compatibility with Format printers *) +include Printers with type 'a printer := 'a Format_doc.format_printer diff --git a/upstream/ocaml_flambda/typing/printtyped.ml b/upstream/ocaml_flambda/typing/printtyped.ml index 10b4c9401..7308e668c 100644 --- a/upstream/ocaml_flambda/typing/printtyped.ml +++ b/upstream/ocaml_flambda/typing/printtyped.ml @@ -38,9 +38,9 @@ let fmt_location f loc = 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.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y.txt s.txt; | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + fprintf f "%a(%a)" fmt_longident_aux y.txt fmt_longident_aux z.txt let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt @@ -148,6 +148,12 @@ let fmt_partiality f x = | Total -> () | Partial -> fprintf f " (Partial)" +let fmt_presence f x = + match x with + | Types.Mp_present -> fprintf f "(Present)" + | Types.Mp_absent -> fprintf f "(Absent)" + + let line i f s (*...*) = fprintf f "%s" (String.make (2*i) ' '); fprintf f s (*...*) @@ -211,7 +217,6 @@ let typevar_jkind ~print_quote ppf (v, l) = let tuple_component_label i ppf = function | None -> line i ppf "Label: None\n" | Some s -> line i ppf "Label: Some \"%s\"\n" s -;; let typevars ppf vs = List.iter (typevar_jkind ~print_quote:true ppf) vs @@ -394,7 +399,7 @@ let rec core_type i ppf x = line i ppf "Ttyp_poly%a\n" (fun ppf -> List.iter (typevar_jkind ~print_quote:true ppf)) sl; core_type i ppf ct; - | Ttyp_package { pack_path = s; pack_fields = l } -> + | Ttyp_package { tpt_path = s; tpt_cstrs = l } -> line i ppf "Ttyp_package %a\n" fmt_path s; list i package_with ppf l; | Ttyp_open (path, _mod_ident, t) -> @@ -435,17 +440,17 @@ and label_ambiguity i ppf = function and poly_param : type a. _ -> _ -> a poly_param -> unit = fun i ppf -> function | Param ty -> - line i ppf "Param %a\n" (Format_doc.compat Printtyp.raw_type_expr) ty + line i ppf "Param %a\n" Rawprinttyp.type_expr ty | Arrow args -> line i ppf "Arrow\n"; list (i+1) (fun i ppf (label, ty) -> arg_label i ppf label; option i (fun i f -> - line i f "%a" (Format_doc.compat Printtyp.raw_type_expr)) ppf ty) + line i f "%a" Rawprinttyp.type_expr) ppf ty) ppf args | Method ({txt}, ty) -> fprintf ppf "Method %s %a\n" txt - (Format_doc.compat Printtyp.raw_type_expr) ty + Rawprinttyp.type_expr ty and type_inspection : type a. _ -> _ -> a type_inspection -> unit = fun i ppf -> function @@ -460,12 +465,7 @@ 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; + List.iter (pattern_extra i ppf) x.pat_extra; match x.pat_desc with | Tpat_any -> line i ppf "Tpat_any\n"; | Tpat_var { id = s; sort; mode = m; _ } -> @@ -541,7 +541,9 @@ and labeled_pattern_with_sorts : pattern i ppf x; line i ppf "%a\n" fmt_sort sort -and pattern_extra i ppf (extra_pat, _, attrs) = +and pattern_extra i ppf (extra_pat, loc, attrs) = + line i ppf "extra %a\n" fmt_location loc; + let i = i + 1 in match extra_pat with | Tpat_unpack -> line i ppf "Tpat_extra_unpack\n"; @@ -575,15 +577,18 @@ and function_body i ppf (body : function_body) = line i ppf "Tfunction_cases%a %a\n" fmt_partiality fc_partial fmt_location fc_loc; + let i = i+1 in alloc_mode_raw i ppf fc_arg_mode; line i ppf "%a\n" fmt_sort fc_arg_sort; - attributes (i+1) ppf fc_attributes; - List.iter (fun e -> expression_extra (i+1) ppf e []) fc_exp_extra; - list (i+1) case ppf fc_cases + attributes i ppf fc_attributes; + List.iter (fun e -> expression_extra i ppf (e, fc_loc, [])) fc_exp_extra; + list i case ppf fc_cases -and expression_extra i ppf x attrs = - match x with - | Texp_constraint (ct) -> +and expression_extra i ppf (extra, loc, attrs) = + line i ppf "extra %a\n" fmt_location loc; + let i = i + 1 in + match extra with + | Texp_constraint ct -> line i ppf "Texp_constraint\n"; attributes i ppf attrs; core_type i ppf ct; @@ -643,12 +648,7 @@ 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; + List.iter (expression_extra i ppf) x.exp_extra; match x.exp_desc with | Texp_ident { path; _ } -> line i ppf "Texp_ident %a\n" fmt_path path; | Texp_apply_layout (exp, args) -> @@ -682,16 +682,17 @@ and expression i ppf x = Option.iter (zero_alloc_assume i ppf) za; expression i ppf e; list i label_x_apply_arg ppf l; - | Texp_match (e, sort, l, partial) -> - line i ppf "Texp_match%a\n" - fmt_partiality partial; + | Texp_match (e, sort, l1, l2, partial) -> + line i ppf "Texp_match%a\n" fmt_partiality partial; expression i ppf e; line i ppf "%a\n" fmt_sort sort; - 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_unboxed_unit -> line i ppf "Texp_unboxed_unit\n"; | Texp_unboxed_bool b -> line i ppf "Texp_unboxed_bool %a\n" fmt_bool b; | Texp_tuple (l, am) -> @@ -1181,9 +1182,8 @@ and signature_item i ppf x = 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 + line i ppf "Tsig_module %a\n" fmt_presence md.md_presence; + module_declaration i ppf md | Tsig_modsubst ms -> line i ppf "Tsig_modsubst \"%a\" = %a\n" fmt_ident ms.ms_id fmt_path ms.ms_manifest; @@ -1222,7 +1222,7 @@ and signature_item i ppf x = jkind_declaration i ppf jd and module_declaration i ppf md = - line i ppf "%a" fmt_modname md.md_id; + line i ppf "%a\n" fmt_modname md.md_id; attributes i ppf md.md_attributes; module_type (i+1) ppf md.md_type; @@ -1319,7 +1319,7 @@ and structure_item i ppf x = line i ppf "Tstr_exception\n"; type_exception i ppf ext; | Tstr_module x -> - line i ppf "Tstr_module\n"; + line i ppf "Tstr_module %a\n" fmt_presence x.mb_presence; module_binding i ppf x | Tstr_recmodule bindings -> line i ppf "Tstr_recmodule\n"; diff --git a/upstream/ocaml_flambda/typing/rawprinttyp.ml b/upstream/ocaml_flambda/typing/rawprinttyp.ml new file mode 100644 index 000000000..e0f86e8ca --- /dev/null +++ b/upstream/ocaml_flambda/typing/rawprinttyp.ml @@ -0,0 +1,196 @@ +(**************************************************************************) +(* *) +(* 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 Mode +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 string_of_label : Types.arg_label -> string = function + Nolabel -> "" + | Labelled s | Position 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;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 labeled_type ppf (label, ty) = + begin match label with + | Some s -> fprintf ppf "label=\"%s\" " s + | None -> () + end; + raw_type ppf ty +and raw_type_list tl = raw_list raw_type tl +and labeled_type_list tl = raw_list labeled_type tl +and raw_lid_type_list tl = + raw_list (fun ppf (lid, typ) -> + let lid = Longident.unflatten lid |> Option.get in + fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) + tl +and raw_row_desc ppf 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) +and raw_type_desc ppf ty = + let env = Env.empty in + match ty with + Tvar { name; jkind } -> + fprintf ppf "Tvar (@,%a,@,%a)" + print_name name (Format_doc.compat (Jkind.format env)) jkind + | Tarrow((l,arg,ret),t1,t2,c) -> + fprintf ppf "@[Tarrow((\"%s\",%a,%a),@,%a,@,%a,@,%s)@]" + (string_of_label l) + (Format_doc.compat (Alloc.print ~verbose:true ())) arg + (Format_doc.compat (Alloc.print ~verbose:true ())) ret + raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" labeled_type_list tl + | Tunboxed_tuple tl -> + fprintf ppf "@[<1>Tunboxed_tuple@,%a@]" labeled_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) + | Tquote t -> + fprintf ppf "@[Tquote@ %a@]" raw_type t + | Tsplice t -> + fprintf ppf "@[Tsplice@ %a@]" raw_type t + | Tquote_eval t -> + fprintf ppf "@[Tquote_eval@ %a@]" raw_type t + | 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; jkind } -> + fprintf ppf "Tunivar (@,%a,@,%a)" + print_name name (Format_doc.compat (Jkind.format env)) jkind + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Trepr (t, sort_vars) -> + let print_sort_univar ppf uv = + fprintf ppf "%s" (Option.value uv.Jkind_types.Sort.name ~default:"_") + in + fprintf ppf "@[Trepr(@,%a,@,[@[%a@]])@]" + raw_type t + (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@ ") + print_sort_univar) sort_vars + | Tvariant row -> + raw_row_desc ppf row + | Tpackage pack -> + fprintf ppf "@[Tpackage(@,%a,@,%a)@]" + path pack.pack_path + raw_lid_type_list pack.pack_cstrs + | Tof_kind jkind -> + fprintf ppf "Tof_kind@ %a" (Format_doc.compat (Jkind.format env)) jkind +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 +| Some Types.Fixed_existential -> fprintf ppf "Some Fixed_existential" + +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 := [] +let row_field = raw_field +let row_desc = raw_row_desc + +let () = Btype.print_raw := type_expr +let () = Jkind.set_raw_type_expr type_expr diff --git a/upstream/ocaml_flambda/typing/rawprinttyp.mli b/upstream/ocaml_flambda/typing/rawprinttyp.mli new file mode 100644 index 000000000..cffde2342 --- /dev/null +++ b/upstream/ocaml_flambda/typing/rawprinttyp.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* 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 +val row_field: Format.formatter -> Types.row_field -> unit +val row_desc: Format.formatter -> Types.row_desc -> unit diff --git a/upstream/ocaml_flambda/typing/shape.ml b/upstream/ocaml_flambda/typing/shape.ml index 8521e4c16..be1d80b01 100644 --- a/upstream/ocaml_flambda/typing/shape.ml +++ b/upstream/ocaml_flambda/typing/shape.ml @@ -854,7 +854,6 @@ let rec print fmt t = | At_layout (shape, layout) -> Format.fprintf fmt "(%a : %a)" print_nested shape (Format_doc.compat Layout.format) layout - in if t.approximated then Format.fprintf fmt "@[(approx)@ %a@]@;" aux t @@ -1104,7 +1103,6 @@ let at_layout ?uid shape layout = hash = Hashtbl.hash (hash_at_layout, uid, shape.hash, layout); approximated = false } - let decompose_abs t = match t.desc with | Abs (x, t) -> Some (x, t) @@ -1115,36 +1113,29 @@ let dummy_mod = str Item.Map.empty let of_path ~find_shape ~namespace path = (* We need to handle the following cases: Path of constructor: - M.t.C + M.t.C [Pextra_ty("M.t", "C")] Path of label: - M.t.lbl + M.t.lbl [Pextra_ty("M.t", "lbl")] Path of label of inline record: - M.t.C.lbl + M.t.C.lbl [Pextra_ty(Pextra_ty("M.t", "C"), "lbl")] Path of label of implicit unboxed record: - M.t#.lbl - *) + M.t#.lbl [Pextra_ty(Pextra_ty("M.t", Punboxed_ty), "lbl")] *) let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function | Pident id -> find_shape ns id - | Pdot (Pextra_ty (path, Punboxed_ty), name) -> - (match ns with - Unboxed_label -> () - | _ -> Misc.fatal_error "Shape.of_path"); - proj (aux Type path) (name, Label) - | Pdot (path, name) -> - let namespace : Sig_component_kind.t = - match (ns : Sig_component_kind.t) with - | Constructor -> Type - | Label -> Type - | Unboxed_label -> Type - | _ -> Module - in - proj (aux namespace path) (name, ns) + | Pdot (path, name) -> proj (aux Module 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 - | Punboxed_ty -> aux ns path + match extra, ns, path with + | Pcstr_ty name, Label, Pextra_ty _ -> + (* Handle the M.t.C.lbl case *) + proj (aux Constructor path) (name, ns) + | Pcstr_ty name, Unboxed_label, Pextra_ty (path', Punboxed_ty) -> + (* Implicit-unboxed view of a boxed record: labels are stored in + the underlying boxed type's shape under the Label namespace. *) + proj (aux Type path') (name, Label) + | Pcstr_ty name, _, _ -> proj (aux Type path) (name, ns) + | Pext_ty, _, _ -> aux Extension_constructor path + | Punboxed_ty, _, _ -> aux ns path end in aux namespace path diff --git a/upstream/ocaml_flambda/typing/shape.mli b/upstream/ocaml_flambda/typing/shape.mli index de6ac7a6d..6e097166f 100644 --- a/upstream/ocaml_flambda/typing/shape.mli +++ b/upstream/ocaml_flambda/typing/shape.mli @@ -60,17 +60,14 @@ type base_layout = Jkind_types.Sort.base module Uid : sig type t = private | Compilation_unit of string - | Item of { - comp_unit: string; - id: int; - from: Unit_info.intf_or_impl } + | Item of { comp_unit: string; id: int; from: Unit_info.intf_or_impl } | Internal | Predef of string | Unboxed_version of t val reinit : unit -> unit - val mk : current_unit:Unit_info.t option -> t + val mk : current_unit:(Unit_info.t option) -> t val of_compilation_unit_id : Compilation_unit.t -> t val of_compilation_unit_name : Compilation_unit.Name.t -> t val of_predef_id : Ident.t -> t diff --git a/upstream/ocaml_flambda/typing/shape_reduce.ml b/upstream/ocaml_flambda/typing/shape_reduce.ml index 9115a2369..9dee50db6 100644 --- a/upstream/ocaml_flambda/typing/shape_reduce.ml +++ b/upstream/ocaml_flambda/typing/shape_reduce.ml @@ -29,18 +29,18 @@ type result = let rec print_result fmt result = match result with | Resolved uid -> - Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid + Format.fprintf fmt "@[Resolved:@ %a@]" Uid.print uid | Resolved_alias (uid, r) -> - Format.fprintf fmt "@[Alias: %a -> %a@]@;" + Format.fprintf fmt "@[Alias:@ %a@] ->@ %a" Uid.print uid print_result r | Unresolved shape -> - Format.fprintf fmt "@[Unresolved: %a@]@;" print shape + Format.fprintf fmt "@[Unresolved:@ %a@]" print shape | Approximated (Some uid) -> - Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid + Format.fprintf fmt "@[Approximated:@ %a@]" Uid.print uid | Approximated None -> - Format.fprintf fmt "@[Approximated: No uid@]@;" + Format.fprintf fmt "Approximated: No uid" | Internal_error_missing_uid -> - Format.fprintf fmt "@[Missing uid@]@;" + Format.fprintf fmt "Missing uid" module Diagnostics = struct type diagnostics = diff --git a/upstream/ocaml_flambda/typing/stypes.ml b/upstream/ocaml_flambda/typing/stypes.ml index bdc4b02fe..2e5d51af9 100644 --- a/upstream/ocaml_flambda/typing/stypes.ml +++ b/upstream/ocaml_flambda/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; | _ -> () @@ -149,8 +149,7 @@ let print_info pp prev_loc ti = Format.pp_print_string Format.str_formatter " "; Printtyp.wrap_printing_env ~error:false env (fun () -> - Format_doc.compat Printtyp.shared_type_scheme Format.str_formatter - typ + Printtyp.shared_type_scheme Format.str_formatter typ ); Format.pp_print_newline Format.str_formatter (); let s = Format.flush_str_formatter () in diff --git a/upstream/ocaml_flambda/typing/subst.ml b/upstream/ocaml_flambda/typing/subst.ml index 86b63254f..6559b3158 100644 --- a/upstream/ocaml_flambda/typing/subst.ml +++ b/upstream/ocaml_flambda/typing/subst.ml @@ -588,9 +588,12 @@ let rec typexp copy_scope s ty = | 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) + | Tpackage {pack_path; pack_cstrs} -> + Tpackage { + pack_path = modtype_path s pack_path; + pack_cstrs = + List.map (fun (n, ty) -> (n, typexp copy_scope s ty)) pack_cstrs; + } | Tobject (t1, name) -> let t1' = typexp copy_scope s t1 in let name' = diff --git a/upstream/ocaml_flambda/typing/tast_iterator.ml b/upstream/ocaml_flambda/typing/tast_iterator.ml index ae9616a24..ecf8cd85b 100644 --- a/upstream/ocaml_flambda/typing/tast_iterator.ml +++ b/upstream/ocaml_flambda/typing/tast_iterator.ml @@ -74,6 +74,20 @@ type iterator = let iter_snd f (_, y) = f y let iter_loc sub {loc; _} = sub.location sub loc +let rec iter_loc_lid sub lid = + let open Longident in + match lid with + | Lident _ -> () + | Ldot (lid, id) -> + iter_loc sub lid; iter_loc_lid sub lid.txt; iter_loc sub id + | Lapply (lid, lid') -> + iter_loc sub lid; iter_loc_lid sub lid.txt; + iter_loc sub lid'; iter_loc_lid sub lid'.txt + +let iter_loc_lid sub {loc; txt} = + iter_loc sub {loc; txt}; + iter_loc_lid sub txt + let location _sub _l = () let attribute sub x = @@ -120,7 +134,7 @@ let module_substitution sub ms = sub.location sub ms_loc; sub.attributes sub ms_attributes; iter_loc sub ms_name; - iter_loc sub ms_txt + iter_loc_lid sub ms_txt let include_kind sub = function | Tincl_structure -> () @@ -229,7 +243,7 @@ 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; + iter_loc_lid sub x.tyext_txt; List.iter (fun (c, _) -> sub.typ sub c) x.tyext_params; List.iter (sub.extension_constructor sub) x.tyext_constructors @@ -248,7 +262,7 @@ let extension_constructor sub ec = | Text_decl (_, ctl, cto) -> constructor_args sub ctl; Option.iter (sub.typ sub) cto - | Text_rebind (_, lid) -> iter_loc sub lid + | Text_rebind (_, lid) -> iter_loc_lid sub lid let[@warning "+9"] jkind_declaration sub ({jkind_id=_; jkind_name; jkind_jkind=_; jkind_annotation; @@ -263,9 +277,9 @@ 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_type (_, lid) -> iter_loc_lid sub lid | Tpat_unpack -> () - | Tpat_open (_, lid, env) -> iter_loc sub lid; sub.env sub env + | Tpat_open (_, lid, env) -> iter_loc_lid sub lid; sub.env sub env | Tpat_constraint (ct, ma) -> sub.typ sub ct; sub.modes sub ma | Tpat_inspected_type (Label_disambiguation _) -> () | Tpat_inspected_type (Polymorphic_parameter (Param _)) -> () @@ -286,7 +300,7 @@ let pat | Tpat_tuple l -> List.iter (fun (_, p) -> sub.pat sub p) l | Tpat_unboxed_tuple l -> List.iter (fun (_, p, _) -> sub.pat sub p) l | Tpat_construct (lid, _, l, vto) -> - iter_loc sub lid; + iter_loc_lid sub lid; List.iter (sub.pat sub) l; Option.iter (fun (vs, ct) -> List.iter @@ -297,9 +311,9 @@ let pat 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 + List.iter (fun (lid, _, i) -> iter_loc_lid sub lid; sub.pat sub i) l | Tpat_record_unboxed_product (l, _) -> - List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l + List.iter (fun (lid, _, i) -> iter_loc_lid sub lid; sub.pat sub i) l | Tpat_array (_, _, l) -> List.iter (sub.pat sub) l | Tpat_alias { pattern = p; name = s; _ } -> sub.pat sub p; iter_loc sub s | Tpat_lazy p -> sub.pat sub p @@ -363,7 +377,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = let iter_fields fields = Array.iter (function | _, Kept _ -> () - | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) + | _, Overridden (lid, exp) -> iter_loc_lid sub lid; sub.expr sub exp) fields in let iter_block_access sub = function @@ -374,7 +388,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Uaccess_unboxed_field (lid, _) -> iter_loc sub lid in match exp_desc with - | Texp_ident { lid; _ } -> iter_loc sub lid + | Texp_ident { lid; _ } -> iter_loc_lid sub lid | Texp_apply_layout (exp, _) -> sub.expr sub exp | Texp_constant _ -> () | Texp_let (rec_flag, list, exp) -> @@ -393,18 +407,20 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | (_, Arg (exp, _)) -> sub.expr sub exp | (_, Omitted _) -> ()) 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_unboxed_unit -> () | Texp_unboxed_bool _ -> () - | Texp_tuple (list, _) -> List.iter (fun (_,e) -> sub.expr sub e) list - | Texp_unboxed_tuple list -> List.iter (fun (_,e,_) -> sub.expr sub e) list + | Texp_tuple (list, _) -> List.iter (fun (_, e) -> sub.expr sub e) list + | Texp_unboxed_tuple list -> List.iter (fun (_, e, _) -> sub.expr sub e) list | Texp_construct (lid, _, args, _) -> - iter_loc sub lid; + iter_loc_lid sub lid; List.iter (sub.expr sub) args | Texp_variant (_, expo) -> Option.iter (fun (expr, _) -> sub.expr sub expr) expo @@ -415,13 +431,13 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = iter_fields fields; Option.iter (fun (exp, _) -> sub.expr sub exp) extended_expression; | Texp_field (exp, _, lid, _, _, _) -> - iter_loc sub lid; + iter_loc_lid sub lid; sub.expr sub exp | Texp_unboxed_field (exp, _, lid, _, _) -> - iter_loc sub lid; + iter_loc_lid sub lid; sub.expr sub exp | Texp_setfield (exp1, _, lid, _, exp2) -> - iter_loc sub lid; + iter_loc_lid sub lid; sub.expr sub exp1; sub.expr sub exp2 | Texp_array (_, _, list, _) -> List.iter (sub.expr sub) list @@ -449,7 +465,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = sub.expr sub exp) comp_clauses | Texp_atomic_loc (exp, _, lid, _, _) -> - iter_loc sub lid; + iter_loc_lid sub lid; sub.expr sub exp | Texp_ifthenelse (exp1, exp2, expo) -> sub.expr sub exp1; @@ -467,7 +483,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = sub.expr sub for_body | Texp_send (exp, _, _) -> sub.expr sub exp - | Texp_new (_, lid, _, _) -> iter_loc sub lid + | Texp_new (_, lid, _, _) -> iter_loc_lid sub lid | Texp_instvar (_, _, s) -> iter_loc sub s | Texp_mutvar id -> iter_loc sub id | Texp_setinstvar (_, _, s, exp) -> @@ -494,7 +510,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = List.iter (sub.binding_op sub) ands; sub.case sub body | Texp_unreachable -> () - | Texp_extension_constructor (lid, _) -> iter_loc sub lid + | Texp_extension_constructor (lid, _) -> iter_loc_lid sub lid | Texp_open (od, e) -> sub.open_declaration sub od; sub.expr sub e @@ -509,9 +525,9 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Texp_quotation exp -> sub.expr sub exp | Texp_antiquotation exp -> sub.expr sub exp -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 package_type sub {tpt_cstrs; tpt_txt; _} = + List.iter (fun (lid, p) -> iter_loc_lid sub lid; sub.typ sub p) tpt_cstrs; + iter_loc_lid sub tpt_txt let binding_op sub {bop_loc; bop_op_name; bop_exp; _} = sub.location sub bop_loc; @@ -568,8 +584,8 @@ let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = 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_ident (_, lid) -> iter_loc_lid sub lid + | Tmty_alias (_, lid) -> iter_loc_lid sub lid | Tmty_signature sg -> sub.signature sub sg | Tmty_functor (arg, mtype2, mmode2) -> functor_parameter sub arg; @@ -578,15 +594,17 @@ let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = | Tmty_with (mtype, list) -> sub.module_type sub mtype; List.iter (fun (_, lid, e) -> - iter_loc sub lid; sub.with_constraint sub e) list + iter_loc_lid sub lid; sub.with_constraint sub e) list | Tmty_typeof mexpr -> sub.module_expr sub mexpr - | Tmty_strengthen (mtype, _, _) -> sub.module_type sub mtype + | Tmty_strengthen (mtype, _, lid) -> + sub.module_type sub mtype; + iter_loc_lid sub lid 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_module (_, lid) -> iter_loc_lid sub lid + | Twith_modsubst (_, lid) -> iter_loc_lid sub lid | Twith_modtype mty -> sub.module_type sub mty | Twith_modtypesubst mty -> sub.module_type sub mty | Twith_jkind jd -> sub.jkind_declaration sub jd @@ -596,7 +614,7 @@ let with_constraint sub = function 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; + iter_snd (iter_loc_lid sub) open_expr; sub.env sub open_env let open_declaration sub {open_loc; open_expr; open_env; open_attributes; _} = @@ -619,13 +637,18 @@ let module_coercion sub = function | Tcoerce_primitive {pc_loc; pc_env; _} -> sub.location sub pc_loc; sub.env sub pc_env + | Tcoerce_invalid -> () -let module_expr sub {mod_loc; mod_desc; mod_env; mod_attributes; _} = +let module_expr sub {mod_loc; mod_desc; mod_mode; mod_env; mod_attributes; _} = sub.location sub mod_loc; sub.attributes sub mod_attributes; + begin match mod_mode with + | _, None -> () + | _, Some (_, txt, loc) -> iter_loc_lid sub {txt; loc} + end; sub.env sub mod_env; match mod_desc with - | Tmod_ident (_, lid) -> iter_loc sub lid + | Tmod_ident (_, lid) -> iter_loc_lid sub lid | Tmod_structure st -> sub.structure sub st | Tmod_functor (arg, mexpr) -> functor_parameter sub arg; @@ -677,7 +700,7 @@ let class_expr sub {cl_loc; cl_desc; cl_env; cl_attributes; _} = List.iter (fun (_, e) -> sub.expr sub e) ivars; sub.class_expr sub cl | Tcl_ident (_, lid, tyl) -> - iter_loc sub lid; + iter_loc_lid sub lid; List.iter (sub.typ sub) tyl | Tcl_open (od, e) -> sub.open_description sub od; @@ -690,7 +713,7 @@ let class_type sub {cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes; _} = match cltyp_desc with | Tcty_signature csg -> sub.class_signature sub csg | Tcty_constr (_, lid, list) -> - iter_loc sub lid; + iter_loc_lid sub lid; List.iter (sub.typ sub) list | Tcty_arrow (_, ct, cl) -> sub.typ sub ct; @@ -730,11 +753,11 @@ let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = | Ttyp_tuple list -> List.iter (fun (_, t) -> sub.typ sub t) list | Ttyp_unboxed_tuple list -> List.iter (fun (_, t) -> sub.typ sub t) list | Ttyp_constr (_, lid, list) -> - iter_loc sub lid; + iter_loc_lid 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; + iter_loc_lid sub lid; List.iter (sub.typ sub) list | Ttyp_alias (ct, _, jkind) -> sub.typ sub ct; @@ -745,7 +768,7 @@ let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = sub.typ sub ct | Ttyp_package pack -> sub.package_type sub pack | Ttyp_open (_, mod_ident, t) -> - iter_loc sub mod_ident; + iter_loc_lid sub mod_ident; sub.typ sub t | Ttyp_quote t -> sub.typ sub t | Ttyp_splice t -> sub.typ sub t diff --git a/upstream/ocaml_flambda/typing/tast_mapper.ml b/upstream/ocaml_flambda/typing/tast_mapper.ml index 7bc44b2a5..8df63fa41 100644 --- a/upstream/ocaml_flambda/typing/tast_mapper.ml +++ b/upstream/ocaml_flambda/typing/tast_mapper.ml @@ -85,6 +85,22 @@ 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 rec map_loc_lid sub lid = + let open Longident in + match lid with + | Lident id -> Lident id + | Ldot (lid, id) -> + let lid = { lid with txt = map_loc_lid sub lid.txt } in + Ldot (map_loc sub lid, map_loc sub id) + | Lapply (lid, lid') -> + let lid = { lid with txt = map_loc_lid sub lid.txt } in + let lid' = { lid' with txt = map_loc_lid sub lid'.txt } in + Lapply(map_loc sub lid, map_loc sub lid') + +let map_loc_lid sub {loc; txt} = + let txt = map_loc_lid sub txt in + map_loc sub {loc; txt} + let location _sub l = l let attribute sub x = @@ -134,7 +150,7 @@ let module_declaration sub x = 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_txt = map_loc_lid 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} @@ -267,7 +283,7 @@ let type_declarations sub (rec_flag, 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_txt = map_loc_lid 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 @@ -298,7 +314,7 @@ let extension_constructor sub x = Option.map (sub.typ sub) cto ) | Text_rebind (path, lid) -> - Text_rebind (path, map_loc sub lid) + Text_rebind (path, map_loc_lid sub lid) in let ext_attributes = sub.attributes sub x.ext_attributes in {x with ext_loc; ext_name; ext_kind; ext_attributes} @@ -317,9 +333,9 @@ let[@warning "+9"] jkind_declaration sub 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_type (path,lid) -> Tpat_type (path, map_loc_lid sub lid) + | Tpat_open (path,lid,env) -> + Tpat_open (path, map_loc_lid sub lid, sub.env sub env) | Tpat_constraint (ct, ma) -> Tpat_constraint (sub.typ sub ct, sub.modes sub ma) | Tpat_inspected_type (Label_disambiguation _) as d -> d @@ -345,22 +361,24 @@ let pat | Tpat_unboxed_tuple l -> Tpat_unboxed_tuple (List.map (fun (label, p, sort) -> label, sub.pat sub p, sort) l) - | Tpat_construct (loc, cd, l, vto) -> + | Tpat_construct (lid, cd, l, vto) -> let vto = Option.map (fun (vl,cty) -> List.map (fun (v, jk) -> (map_loc sub v, Option.map (sub.jkind_annotation sub) jk)) vl, sub.typ sub cty) vto in - Tpat_construct (map_loc sub loc, cd, List.map (sub.pat sub) l, vto) + Tpat_construct (map_loc_lid sub lid, 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_record + (List.map (tuple3 (map_loc_lid sub) id (sub.pat sub)) l, closed) | Tpat_record_unboxed_product (l, closed) -> Tpat_record_unboxed_product - (List.map (tuple3 (map_loc sub) id (sub.pat sub)) l, closed) - | Tpat_array (am, arg_sort, l) -> Tpat_array (am, arg_sort, List.map (sub.pat sub) l) + (List.map (tuple3 (map_loc_lid sub) id (sub.pat sub)) l, closed) + | Tpat_array (am, arg_sort, l) -> + Tpat_array (am, arg_sort, List.map (sub.pat sub) l) | Tpat_alias { pattern; id; name; uid; sort; mode; type_expr } -> Tpat_alias { pattern = sub.pat sub pattern; id; name = map_loc sub name; uid; @@ -501,23 +519,23 @@ let expr sub x = Array.map (function | label, Kept (t, mut, uu) -> label, Kept (t, mut, uu) | label, Overridden (lid, exp) -> - label, Overridden (map_loc sub lid, sub.expr sub exp)) + label, Overridden (map_loc_lid sub lid, sub.expr sub exp)) fields in let map_block_access sub = function | Baccess_field (lid, ld) -> - Baccess_field (map_loc sub lid, ld) + Baccess_field (map_loc_lid sub lid, ld) | Baccess_block (mut, idx) -> Baccess_block (mut, sub.expr sub idx) in let map_unboxed_access sub = function | Uaccess_unboxed_field (lid, ld) -> - Uaccess_unboxed_field (map_loc sub lid, ld) + Uaccess_unboxed_field (map_loc_lid sub lid, ld) in let exp_desc = match x.exp_desc with | Texp_ident r -> - Texp_ident { r with lid = map_loc sub r.lid } + Texp_ident { r with lid = map_loc_lid sub r.lid } | Texp_apply_layout (exp, args) -> Texp_apply_layout (sub.expr sub exp, args) | Texp_constant _ as d -> d @@ -536,23 +554,24 @@ let expr sub x = | Texp_apply (exp, list, pos, am, za) -> Texp_apply ( sub.expr sub exp, - List.map (function - | (lbl, Arg (exp, sort)) -> (lbl, Arg (sub.expr sub exp, sort)) - | (lbl, Omitted o) -> (lbl, Omitted o)) + List.map + (tuple2 id (Typedtree.map_apply_arg (tuple2 (sub.expr sub) id))) list, pos, am, za ) - | Texp_match (exp, sort, cases, p) -> + | Texp_match (exp, sort, cases, eff_cases, p) -> Texp_match ( sub.expr sub exp, sort, 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_unboxed_unit -> Texp_unboxed_unit | Texp_unboxed_bool b -> Texp_unboxed_bool b @@ -562,7 +581,8 @@ let expr sub x = Texp_unboxed_tuple (List.map (fun (label, e, s) -> label, sub.expr sub e, s) list) | Texp_construct (lid, cd, args, am) -> - Texp_construct (map_loc sub lid, cd, List.map (sub.expr sub) args, am) + Texp_construct + (map_loc_lid sub lid, cd, List.map (sub.expr sub) args, am) | Texp_variant (l, expo) -> Texp_variant (l, Option.map (fun (e, am) -> (sub.expr sub e, am)) expo) | Texp_record { fields; representation; extended_expression; alloc_mode } -> @@ -582,20 +602,20 @@ let expr sub x = (fun (exp, sort) -> (sub.expr sub exp, sort)) extended_expression } | Texp_field (exp, sort, lid, ld, float, ubr) -> - Texp_field (sub.expr sub exp, sort, map_loc sub lid, ld, float, ubr) + Texp_field (sub.expr sub exp, sort, map_loc_lid sub lid, ld, float, ubr) | Texp_unboxed_field (exp, sort, lid, ld, uu) -> - Texp_unboxed_field (sub.expr sub exp, sort, map_loc sub lid, ld, uu) + Texp_unboxed_field (sub.expr sub exp, sort, map_loc_lid sub lid, ld, uu) | Texp_setfield (exp1, am, lid, ld, exp2) -> Texp_setfield ( sub.expr sub exp1, am, - map_loc sub lid, + map_loc_lid sub lid, ld, sub.expr sub exp2 ) | Texp_atomic_loc (exp, sort, lid, ld, alloc_mode) -> Texp_atomic_loc - (sub.expr sub exp, sort, map_loc sub lid, ld, alloc_mode) + (sub.expr sub exp, sort, map_loc_lid sub lid, ld, alloc_mode) | Texp_array (amut, sort, list, alloc_mode) -> Texp_array (amut, sort, List.map (sub.expr sub) list, alloc_mode) | Texp_idx (ba, uas) -> @@ -636,7 +656,7 @@ let expr sub x = | Texp_new (path, lid, cd, apos) -> Texp_new ( path, - map_loc sub lid, + map_loc_lid sub lid, cd, apos ) @@ -697,7 +717,7 @@ let expr sub x = | Texp_unreachable -> Texp_unreachable | Texp_extension_constructor (lid, path) -> - Texp_extension_constructor (map_loc sub lid, path) + Texp_extension_constructor (map_loc_lid sub lid, path) | Texp_open (od, e) -> Texp_open (sub.open_declaration sub od, sub.expr sub e) | Texp_probe {name; handler; enabled_at_init;} -> @@ -719,10 +739,10 @@ let expr sub x = 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 tpt_txt = map_loc_lid sub x.tpt_txt in + let tpt_cstrs = List.map + (tuple2 (map_loc_lid sub) (sub.typ sub)) x.tpt_cstrs in + {x with tpt_txt; tpt_cstrs} let binding_op sub x = let bop_loc = sub.location sub x.bop_loc in @@ -795,8 +815,8 @@ let module_type sub x = 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_ident (path, lid) -> Tmty_ident (path, map_loc_lid sub lid) + | Tmty_alias (path, lid) -> Tmty_alias (path, map_loc_lid sub lid) | Tmty_signature sg -> Tmty_signature (sub.signature sub sg) | Tmty_functor (arg, mtype2, mmode2) -> Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2, @@ -804,12 +824,12 @@ let module_type sub x = | Tmty_with (mtype, list) -> Tmty_with ( sub.module_type sub mtype, - List.map (tuple3 id (map_loc sub) (sub.with_constraint sub)) list + List.map (tuple3 id (map_loc_lid sub) (sub.with_constraint sub)) list ) | Tmty_typeof mexpr -> Tmty_typeof (sub.module_expr sub mexpr) | Tmty_strengthen (mtype, p, lid) -> - Tmty_strengthen (sub.module_type sub mtype, p, lid) + Tmty_strengthen (sub.module_type sub mtype, p, map_loc_lid sub lid) in let mty_attributes = sub.attributes sub x.mty_attributes in {x with mty_loc; mty_desc; mty_env; mty_attributes} @@ -819,14 +839,14 @@ let with_constraint sub = function | 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) + | Twith_module (path, lid) -> Twith_module (path, map_loc_lid sub lid) + | Twith_modsubst (path, lid) -> Twith_modsubst (path, map_loc_lid sub lid) | Twith_jkind jd -> Twith_jkind (sub.jkind_declaration sub jd) | Twith_jkindsubst jd -> Twith_jkindsubst (sub.jkind_declaration sub jd) 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_expr = tuple2 id (map_loc_lid sub) od.open_expr; open_env = sub.env sub od.open_env; open_attributes = sub.attributes sub od.open_attributes} @@ -854,13 +874,21 @@ let module_coercion sub = function | Tcoerce_primitive pc -> Tcoerce_primitive {pc with pc_loc = sub.location sub pc.pc_loc; pc_env = sub.env sub pc.pc_env} + | Tcoerce_invalid -> Tcoerce_invalid 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_mode = + match x.mod_mode with + | _, None -> x.mod_mode + | mode, Some (locks, txt, loc) -> + let { txt; loc } = map_loc_lid sub { txt; loc } in + mode, Some (locks, txt, loc) + in let mod_desc = match x.mod_desc with - | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc sub lid) + | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc_lid 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) @@ -890,7 +918,7 @@ let module_expr sub x = ) in let mod_attributes = sub.attributes sub x.mod_attributes in - {x with mod_loc; mod_desc; mod_env; mod_attributes} + {x with mod_loc; mod_desc; mod_mode; mod_env; mod_attributes} let module_binding sub x = let mb_loc = sub.location sub x.mb_loc in @@ -925,9 +953,8 @@ let class_expr sub x = | Tcl_apply (cl, args) -> Tcl_apply ( sub.class_expr sub cl, - List.map (function - | (lbl, Arg (exp, sort)) -> (lbl, Arg (sub.expr sub exp, sort)) - | (lbl, Omitted o) -> (lbl, Omitted o)) + List.map + (tuple2 id (Typedtree.map_apply_arg (tuple2 (sub.expr sub) id))) args ) | Tcl_let (rec_flag, value_bindings, ivars, cl) -> @@ -941,7 +968,7 @@ let class_expr sub x = sub.class_expr sub cl ) | Tcl_ident (path, lid, tyl) -> - Tcl_ident (path, map_loc sub lid, List.map (sub.typ sub) tyl) + Tcl_ident (path, map_loc_lid 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 @@ -957,7 +984,7 @@ let class_type sub x = | Tcty_constr (path, lid, list) -> Tcty_constr ( path, - map_loc sub lid, + map_loc_lid sub lid, List.map (sub.typ sub) list ) | Tcty_arrow (label, ct, cl) -> @@ -1012,13 +1039,13 @@ let typ sub x = Ttyp_unboxed_tuple (List.map (fun (label, t) -> label, sub.typ sub t) list) | Ttyp_constr (path, lid, list) -> - Ttyp_constr (path, map_loc sub lid, List.map (sub.typ sub) list) + Ttyp_constr (path, map_loc_lid 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, + map_loc_lid sub lid, List.map (sub.typ sub) list ) | Ttyp_alias (ct, s, jkind) -> @@ -1031,7 +1058,7 @@ let typ sub x = | 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) + Ttyp_open (path, map_loc_lid sub mod_ident, sub.typ sub t) | Ttyp_repr (vars, ct) -> Ttyp_repr (vars, sub.typ sub ct) | Ttyp_newlayout (vars, ct) -> Ttyp_newlayout (vars, sub.typ sub ct) | Ttyp_of_kind jkind -> @@ -1099,11 +1126,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/upstream/ocaml_flambda/typing/type_shape.ml b/upstream/ocaml_flambda/typing/type_shape.ml index b5bb81f7a..486fd4575 100644 --- a/upstream/ocaml_flambda/typing/type_shape.ml +++ b/upstream/ocaml_flambda/typing/type_shape.ml @@ -319,7 +319,7 @@ module Type_shape = struct | Tvariant _ | Tunivar _ | Tpoly (_, _) | Trepr (_, _) - | Tpackage (_, _) + | Tpackage _ | Tquote _ | Tsplice _ | Tquote_eval _ | Tof_kind _ -> assert false in diff --git a/upstream/ocaml_flambda/typing/typeclass.ml b/upstream/ocaml_flambda/typing/typeclass.ml index ef980cc16..8c26b201a 100644 --- a/upstream/ocaml_flambda/typing/typeclass.ml +++ b/upstream/ocaml_flambda/typing/typeclass.ml @@ -494,7 +494,7 @@ let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = val_attributes = attrs; val_zero_alloc = Zero_alloc.default; 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 ~mode:Mode.Value.legacy name desc met_env @@ -511,7 +511,7 @@ let add_self_met loc id sign self_var_kind vars cl_num val_attributes = attrs; val_zero_alloc = Zero_alloc.default; 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 ~mode:Mode.Value.legacy id desc met_env @@ -528,7 +528,7 @@ let add_instance_var_met loc label id sign cl_num attrs met_env = val_attributes = attrs; Types.val_loc = loc; val_zero_alloc = Zero_alloc.default; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } in Env.add_value ~mode:Mode.Value.legacy id desc met_env @@ -687,10 +687,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 ~new_var_jkind:Any val_env ~closed:false Alloc.Const.legacy styp) - ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) in begin match @@ -736,8 +735,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 () -> Typecore.type_exp val_env sdefinition) in begin @@ -1105,7 +1103,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) @@ -1113,9 +1111,9 @@ and class_structure cl_num virt self_scope final val_env met_env loc in let met_env = List.fold_right - (fun {Typecore.pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> + (fun {Typecore.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=Typecore.As_var) pv_type pv_attributes met_env) self_pat_vars met_env in let fields = @@ -1207,13 +1205,15 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let scases = [ Exp.case (Pat.construct ~loc - (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) + (mknoloc (Longident.(Ldot (mknoloc (Lident "*predef*"), + mknoloc "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")))) + (mknoloc (Longident.(Ldot (mknoloc (Lident "*predef*"), + mknoloc "None")))) None) default; ] @@ -1226,7 +1226,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = in let param_name = "*opt*" ^ param_suffix in let smatch = - Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident param_name))) + Exp.match_ ~loc + (Exp.ident ~loc (mknoloc (Longident.Lident param_name))) scases in let sfun = @@ -1243,13 +1244,9 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = if Typecore.has_poly_constraint spat then raise(Error(spat.ppat_loc, val_env, Polymorphic_class_parameter)); 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 @@ -1281,7 +1278,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let partial = let dummy = Typecore.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 val_env' = val_env' @@ -1311,9 +1308,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 @@ -1467,8 +1463,9 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = |> Subst.Lazy.force_value_description in let ty = - Ctype.with_local_level ~post:Ctype.generalize + Ctype.with_local_level_generalize (fun () -> Ctype.instance vd.val_type) + ~before_generalize:Ctype.generalize in let expr = {exp_desc = @@ -1532,8 +1529,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 @@ -1656,8 +1655,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 = @@ -1748,8 +1747,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 *) @@ -1900,31 +1901,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) @@ -1933,8 +1923,11 @@ let final_decl env define_class | Some reason -> let printer = if define_class - then Format_doc.doc_printf "%a" (Printtyp.class_declaration id) clty - else Format_doc.doc_printf "%a" (Printtyp.cltype_declaration id) 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; @@ -2038,20 +2031,29 @@ 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, 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 + (* XCR rtjoa: there was no ~post here before - do we need to generalize? with + local level generalize for class differs from the normal one + + dkalinichenko: I'm not sure we do, but if we didn't before, let's not start? + + rtjoa: agreed, but will just leave this here until the testsuite passes + *) + ~before_generalize:ignore in let res = List.rev_map (final_decl env define_class) res in let decls = List.fold_right extract_type_decls res [] in @@ -2181,6 +2183,8 @@ let approx_class_declarations env sdecls = List.iter (check_recmod_decl env) sdecls; decls, env + + (*******************************) (* Error report *) @@ -2193,12 +2197,14 @@ 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_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 @@ -2207,20 +2213,20 @@ let report_error_doc env ppf = | 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 + 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 - Printtyp.report_unification_error ppf env err + 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 @@ -2241,7 +2247,7 @@ let report_error_doc 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 @@ -2250,15 +2256,15 @@ let report_error_doc 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@]" - out_type (Printtyp.tree_of_typexp Type abbrev) - out_type (Printtyp.tree_of_typexp Type actual) - 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) -> let msg = Format_doc.doc_printf in - Printtyp.report_unification_error ppf env err + Errortrace_report.unification ppf env err (msg "The expression %a has type" Style.inline_code ("new " ^ c) ) @@ -2289,11 +2295,11 @@ let report_error_doc env ppf = (Style.as_inline_code Printtyp.longident) lid expected provided | Parameter_mismatch err -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf env err + 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@]" @@ -2302,7 +2308,7 @@ let report_error_doc 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@ \ @@ -2322,13 +2328,13 @@ let report_error_doc 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; + 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 (Printtyp.tree_of_typexp Type meth_ty) - out_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>%a@]@ \ @@ -2336,13 +2342,13 @@ let report_error_doc env ppf = 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 @@ -2358,13 +2364,13 @@ let report_error_doc env 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 -> Errortrace_report.unification ppf env err (msg "Type") (msg "is not compatible with type") ) | Self_clash err -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf env err + Errortrace_report.unification ppf env err (msg "This object is expected to have type") (msg "but actually has type") | Mutability_mismatch (_lab, mut) -> diff --git a/upstream/ocaml_flambda/typing/typecore.ml b/upstream/ocaml_flambda/typing/typecore.ml index 268de9b5f..cee7eb65b 100644 --- a/upstream/ocaml_flambda/typing/typecore.ml +++ b/upstream/ocaml_flambda/typing/typecore.ml @@ -22,10 +22,11 @@ open Misc open Asttypes open Parsetree open Types -open Mode +open Data_types open Typedtree open Btype open Ctype +open Mode type comprehension_type = | List_comprehension @@ -104,10 +105,12 @@ type contains_gadt = let wrong_kind_sort_of_constructor (lid : Longident.t) = match lid with - | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> + | Lident "true" | Lident "false" + | Ldot(_, {txt="true"; _}) | Ldot(_, {txt="false"; _}) -> Boolean - | Lident "[]" | Lident "::" | Ldot(_, "[]") | Ldot(_, "::") -> List - | Lident "()" | Ldot(_, "()") -> Unit + | Lident "[]" | Lident "::" + | Ldot(_, {txt="[]"; _}) | Ldot(_, {txt="::"; _}) -> List + | Lident "()" | Ldot(_, {txt="()"; _}) -> Unit | _ -> Constructor type existential_restriction = @@ -119,6 +122,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 submode_reason = | Application of type_expr | Constructor of Longident.t @@ -146,10 +154,6 @@ type mode_mismatch_kind = Parameter | Return type error = | Constructor_arity_mismatch of Longident.t * int * int - | Constructor_labeled_arg - | Partial_tuple_pattern_bad_type - | Extra_tuple_label of string option * type_expr - | Missing_tuple_label of string option * type_expr | Label_mismatch of record_form_packed * Longident.t * Errortrace.unification_error | Pattern_type_clash : @@ -159,7 +163,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; @@ -232,19 +236,21 @@ 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 | Invalid_extension_constructor_payload | Not_an_extension_constructor + | Invalid_atomic_loc_payload + | Label_not_atomic of Longident.t + | Atomic_in_pattern of Longident.t | Probe_format | Probe_name_format of string | Probe_name_undefined of string | Probe_is_enabled_format | Extension_not_enabled : _ Language_extension.t -> error - | Atomic_in_pattern of Longident.t - | Invalid_atomic_loc_payload - | Label_not_atomic of Longident.t | Modalities_on_atomic_field of Longident.t | Literal_overflow of string | Unknown_literal of string * char @@ -261,11 +267,18 @@ 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 record_form_packed * type_expr + | Constructor_labeled_arg + | Partial_tuple_pattern_bad_type + | Extra_tuple_label of string option * type_expr + | Missing_tuple_label of string option * type_expr + | Repeated_tuple_exp_label of string + | Repeated_tuple_pat_label of string | Wrong_expected_record_boxing of wrong_kind_context * record_form_packed * type_expr - | Expr_not_a_record_type of record_form_packed * type_expr | Expr_record_type_has_wrong_boxing of record_form_packed * type_expr | Invalid_unboxed_access of { prev_el_type : type_expr; ua : Parsetree.unboxed_access } @@ -395,7 +408,7 @@ let check_probe_name name loc env = 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} let is_borrow e = match e.pexp_desc with @@ -903,7 +916,8 @@ let constant_integer i ~suffix : end | Some suffix -> Error (Unknown_constant_literal suffix) -let constant : Parsetree.constant -> (Typedtree.constant, error) result = +let constant_desc + : Parsetree.constant_desc -> (Typedtree.constant, error) result = function | Pconst_integer (i, suffix) -> begin match constant_integer i ~suffix with @@ -964,6 +978,8 @@ let constant : Parsetree.constant -> (Typedtree.constant, error) result = Error (Unknown_literal (Misc.format_as_unboxed_literal i, suffix)) end +let constant const = constant_desc const.pconst_desc + let constant_or_raise env loc cst = match constant cst with | Ok c -> @@ -1005,6 +1021,16 @@ let extract_option_type env ty = Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty | _ -> assert false +let is_floatarray_type env ty = + match get_desc (expand_head env ty) with + Tconstr(path, [], _) -> Path.same path Predef.path_floatarray + | _ -> false + +let is_iarray_type env ty = + match get_desc (expand_head env ty) with + | Tconstr(path, [_], _) -> Path.same path Predef.path_iarray + | _ -> false + let protect_expansion env ty = if Env.has_local_constraints env then generic_instance ty else ty @@ -1218,8 +1244,49 @@ let check_project_mutability ~loc ~env mut_name mutability mode = if Types.is_mutable mutability then submode ~loc ~env mode (mode_project_mutable mut_name) +(* Represents information about an array type inferred using type-directed + disambiguation. *) +type array_info = + { ty_elt : (type_expr * Jkind.sort) option; + mut : mutable_flag } + +let disambiguate_array_literal ~loc env expected_ty = + let return (ty_elt : (type_expr * Jkind.sort) option) (mut : mutable_flag) = + if not (is_principal expected_ty) then + Location.prerr_warning loc + (not_principal "this type-based array disambiguation"); + { ty_elt; mut } + in + if is_floatarray_type env expected_ty then + return (Some (instance Predef.type_float, Jkind.Sort.scannable)) Mutable + else if is_iarray_type env expected_ty then + return None Immutable + else + { ty_elt = None; mut = Mutable } + (* 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 (Jkind.Sort.(of_const Const.for_continuation)); + val_lpoly = Lpoly.determined []; + Types.val_loc = loc; val_attributes = []; + val_modalities = Modality.undefined; + val_zero_alloc = Zero_alloc.default; + 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 @@ -1232,10 +1299,42 @@ let unify_exp_types loc env ty expected_ty = | Tags(l1,l2) -> raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) +(* 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 + +(** [sexp] 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))) + (* helper notation for Pattern_env.t *) let (!!) (penv : Pattern_env.t) = penv.env (* Unification inside type_pat *) +(* If [penv] is available, calling this function requires + [penv.in_counterexample = false] *) let unify_pat_types loc env ty ty' = try unify env ty ty' with | Unify err -> @@ -1244,33 +1343,47 @@ let unify_pat_types loc env ty ty' = raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) (* GADT unification inside solve_Ppat_construct and check_counter_example_pat *) +(* We need to distinguish [pat] and [expected] if [refine = true] and + [penv.in_counterexample = false] (see [unify_gadt] for details) *) let nothing_equated = TypePairs.create 0 -let unify_pat_types_return_equated_pairs ~refine loc penv ty ty' = +let unify_pat_types_return_equated_pairs ~refine loc penv ~pat ~expected = try - if refine then unify_gadt penv ty ty' - else (unify !!penv ty ty'; nothing_equated) + if refine || penv.Pattern_env.in_counterexample + then unify_gadt penv ~pat ~expected + else (unify !!penv pat expected; 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') +(* Unify pattern types in functions that can be called either from + [type_pat] or [check_counter_example_pat]. + Since it calls normal unification when [penv.in_counterexample = false], + or [unify_gadt] when [penv.in_counterexample = true], + [ty] and [ty'] always have symmetric roles. *) +let unify_pat_types_penv loc penv ty ty' = + (* [penv.in_counterexample = true] only in calls originating + from [check_counter_example_pat], + which in turn may contain only non-leaking type variables *) + ignore (unify_pat_types_return_equated_pairs ~refine:false loc penv + ~pat:ty ~expected:ty') (** [sdesc_for_hint] is used by error messages to report literals in their original formatting *) +(* If [penv] is available, calling this function requires + [penv.in_counterexample = false] *) 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 unify_head_only loc penv constr ~expected:ty = + let path = cstr_res_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 + unify_pat_types_penv loc penv ty' ty (* Creating new conjunctive types is not allowed when typing patterns *) (* make all Reither present in open variants *) @@ -1315,17 +1428,22 @@ 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_uid: Uid.t; pv_mode: Value.l; - pv_kind : value_kind; + pv_value_kind : value_kind; pv_type: type_expr; pv_loc: Location.t; - pv_as_var: bool; + pv_kind: pattern_variable_kind; pv_attributes: attributes; pv_sort: Jkind_types.Sort.t; + pv_uid : Uid.t; pv_lpoly: Lpoly.t; } @@ -1374,7 +1492,21 @@ 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_mode = Value.disallow_right Value.legacy; + pv_value_kind = desc.val_kind; + pv_type = desc.val_type; + pv_loc = desc.val_loc; + pv_kind = Continuation_var; + pv_attributes = desc.val_attributes; + pv_sort = Jkind.Sort.(of_const Const.for_continuation); + pv_uid= desc.val_uid; + pv_lpoly = desc.val_lpoly}] + +let create_type_pat_state ?cont allow_modules = let tps_module_variables = match allow_modules with | Modules_allowed { scope } -> @@ -1382,7 +1514,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 = []; } @@ -1420,18 +1552,18 @@ let iter_pattern_variables_type f : pattern_variable list -> unit = List.iter (fun {pv_type; _} -> f pv_type) let iter_pattern_variables_type_mut ~f_immut ~f_mut pvs = - List.iter (fun {pv_type; pv_kind; pv_lpoly; _} -> - match pv_kind with + List.iter (fun {pv_type; pv_value_kind; pv_lpoly; _} -> + match pv_value_kind with | Val_mut _ -> f_mut pv_type | _ -> f_immut pv_lpoly pv_type) pvs let add_pattern_variables ?check ?check_as env pv = List.fold_right - (fun {pv_id; pv_mode; pv_kind; pv_type; pv_loc; pv_as_var; + (fun {pv_id; pv_mode; pv_value_kind; pv_type; pv_loc; pv_kind; pv_attributes; pv_uid; pv_lpoly} env -> - let check = if pv_as_var then check_as else check in + let check = if pv_kind=As_var then check_as else check in Env.add_value ?check ~mode:pv_mode pv_id - {val_type = pv_type; val_kind = pv_kind; val_lpoly = pv_lpoly; + {val_type = pv_type; val_kind = pv_value_kind; val_lpoly = pv_lpoly; Types.val_loc = pv_loc; val_attributes = pv_attributes; val_modalities = Modality.undefined; val_zero_alloc = Zero_alloc.default; @@ -1497,28 +1629,28 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name mode | 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_unit_name ()); - } :: module_variables - in - tps.tps_module_variables <- - Modvars_allowed { scope; module_variables; }; - id + 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_unit_name ()) in + let pv_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in tps.tps_pattern_variables <- {pv_id = id; pv_mode = mode; - pv_kind = kind; + pv_value_kind = kind; 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; pv_sort = sort; @@ -1591,7 +1723,7 @@ and build_as_type_and_mode_extra env p ~mode : _ -> _ * _ = 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); @@ -1712,7 +1844,8 @@ and build_as_type_aux (env : Env.t) p ~mode = (* Constraint solving during typing of patterns *) let solve_Ppat_alias ~mode env pat = - with_local_level ~post:(fun (ty_var, _) -> generalize ty_var) + with_local_level_generalize + ~before_generalize:(fun (ty_var, _) -> generalize ty_var) (fun () -> build_as_type_and_mode ~mode env pat) (* Extracts the first element from a list matching a label. Roughly: @@ -1745,9 +1878,6 @@ let extract_or_mk_pat label rem closed = If [closed] is [Open], then no "missing label" errors are possible; instead, [_] patterns will be generated for those labels. An unnecessarily [Open] pattern results in a warning. - - (Note: an alternative approach to creating [_] patterns could be to add a - [closed] flag to the typedtree) *) let reorder_pat loc penv patl closed labeled_tl expected_ty = let take_next (taken, rem) (label, _) = @@ -1768,7 +1898,7 @@ let reorder_pat loc penv patl closed labeled_tl expected_ty = (* This assumes the [args] have already been reordered according to the [expected_ty], if needed. *) -let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty = +let solve_Ppat_tuple ~alloc_mode loc env args expected_ty = (* CR layouts v5: consider sharing code with [solve_Ppat_unboxed_tuple] below when we allow non-values in boxed tuples. *) let arity = List.length args in @@ -1787,21 +1917,20 @@ let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty = let ann = (* CR layouts v5: restriction to value here to be relaxed. *) List.map2 - (fun (label, p) mode -> + (fun (label, _) mode -> ( label, - p, newgenvar (Jkind.Builtin.value_or_null ~why:Tuple_element), simple_pat_mode mode )) args arg_modes in - let ty = newgenty (Ttuple (List.map (fun (lbl, _, t, _) -> lbl, t) ann)) in + let ty = newgenty (Ttuple (List.map (fun (lbl, t, _) -> lbl, t) ann)) in let expected_ty = generic_instance expected_ty in - unify_pat_types_refine ~refine loc env ty expected_ty; + unify_pat_types_penv loc env ty expected_ty; ann (* This assumes the [args] have already been reordered according to the [expected_ty], if needed. *) -let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = +let solve_Ppat_unboxed_tuple ~alloc_mode loc env args expected_ty = let arity = List.length args in let arg_modes = match alloc_mode.tuple_modes with @@ -1817,13 +1946,12 @@ let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = in let ann = List.map2 - (fun (label, p) mode -> + (fun (label, _) mode -> let jkind, sort = Jkind.of_new_sort_var ~why:Jkind.History.Unboxed_tuple_element ~level:(Ctype.get_current_level ()) in ( label, - p, newgenvar jkind, simple_pat_mode mode, sort @@ -1831,15 +1959,18 @@ let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = args arg_modes in let ty = - newgenty (Tunboxed_tuple (List.map (fun (lbl, _, t, _, _) -> lbl, t) ann)) + newgenty (Tunboxed_tuple (List.map (fun (lbl, t, _, _) -> lbl, t) ann)) in let expected_ty = generic_instance expected_ty in - unify_pat_types_refine ~refine loc env ty expected_ty; + unify_pat_types_penv loc env ty expected_ty; ann 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 = + assert (not penv.in_counterexample); 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 existentials = List.map (fun (name, jkind_annot_opt) -> @@ -1850,19 +1981,25 @@ let solve_constructor_annotation ~default:(Jkind.Builtin.value ~why:Existential_type_variable) jkind_annot_opt in - let decl = new_local_type ~loc:name.loc Definition jkind in + let tv = newvar jkind in + let decl = + new_local_type ~loc:name.loc Definition jkind + ~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}, jkind_annot_opt) + {name with txt = id}, (decl, tv), jkind_annot_opt) 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 Alloc.Const.legacy 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 @@ -1874,56 +2011,92 @@ let solve_constructor_annotation unify_pat_types cty.ctyp_loc !!penv ty1 (newty (Ttuple (List.map (fun t -> None, t) ty_args))); match get_desc (expand_head !!penv ty2) with - Ttuple tyl -> (List.map snd tyl) + Ttuple tyl -> List.map snd tyl | _ -> assert false in - if existentials <> [] then ignore begin - let ids = List.map (fun (x, _) -> x.txt) existentials in + if existentials <> [] then begin + let ids_decls = List.map (fun (x,dm,_) -> (x.txt,dm)) existentials 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 (existentials, cty) + ty_args, Some (List.map (fun (ty, _, jkind) -> ty, jkind) existentials, cty) -let solve_Ppat_construct ~refine tps penv loc constr no_existentials +let solve_Ppat_construct tps (penv : Pattern_env.t) 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; + unify_head_only loc penv constr ~expected:(instance expected_ty); (* 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 + let refine = constr.cstr_generalized && no_existentials = None in + (* Here [ty_res] contains only fresh (non-leaking) type variables, + so the requirement of [unify_gadt] is fulfilled. *) + unify_pat_types_return_equated_pairs ~refine loc penv ~pat:ty_res + ~expected:expected_ty 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_args_ty, ty_res, equated_types, existential_ctyp = + 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 - let ty_args_ty = - List.map (fun ca -> - ca.Types.ca_type) ty_args - in - ty_args, ty_args_ty, ty_res, unify_res ty_res expected_ty, None + ty_args, ty_res, unify_res ty_res expected_ty, None | Some (name_list, sty) -> let existential_treatment = if name_list = [] then @@ -1936,41 +2109,37 @@ 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 ty_args_ty = List.map (fun ca -> - ca.Types.ca_type) ty_args in + let equated_types = lazy (unify_res ty_res expected_ty) in + let ty_args_ty = List.map (fun ca -> ca.Types.ca_type) ty_args in let ty_args_ty, existential_ctyp = solve_constructor_annotation tps penv name_list sty ty_args_ty - ty_ex + ty_ex (fun () -> ignore (Lazy.force equated_types)) in let ty_args = List.map2 (fun arg ca_type -> {arg with Types.ca_type}) ty_args ty_args_ty in - ty_args, ty_args_ty, 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) + (ty_args, equated_types, existential_ctyp) end in - if !Clflags.principal && not refine then begin + if !Clflags.principal && not penv.in_counterexample then begin (* Do not warn for counter-examples *) let exception Warn_only_once in try TypePairs.iter (fun (t1, t2) -> - generalize_structure t1; - generalize_structure 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.type_expr t1 - Printtyp.type_expr t2 + "typing this pattern requires considering@ @[%a@]@ and@ \ + @[%a@]@ as@ equal.@ \ + But@ the@ knowledge@ of@ these@ types" + (Style.as_inline_code Printtyp.Doc.type_expr) t1 + (Style.as_inline_code Printtyp.Doc.type_expr) t2 in Location.prerr_warning loc (Warnings.Not_principal msg); raise Warn_only_once) @@ -1979,42 +2148,54 @@ let solve_Ppat_construct ~refine tps penv loc constr no_existentials end; (ty_args, existential_ctyp) -let solve_Ppat_record_field ~refine loc penv label label_lid record_ty +let solve_Ppat_record_field loc penv label label_lid record_ty record_form = - 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) + unify_pat_types_penv loc penv ty_res (instance record_ty) with Error(_loc, _env, Pattern_type_clash(err, _)) -> raise(Error(label_lid.loc, !!penv, Label_mismatch(P record_form, label_lid.txt, err))) end; - (ty_arg, [ty_res; ty_arg]) + ty_arg end -let solve_Ppat_array ~refine loc env mutability expected_ty = - let type_some_array = - if Types.is_mutable mutability then Predef.type_array - else Predef.type_iarray - in - let jkind, arg_sort = - Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) - in - let ty_elt = newgenvar jkind in +let solve_Ppat_array loc env (mutability : mutable_flag) expected_ty + : _ * _ * mutable_flag = let expected_ty = generic_instance expected_ty in - unify_pat_types_refine ~refine - loc env (type_some_array ty_elt) expected_ty; - ty_elt, arg_sort + match mutability with + | Immutable -> + let jkind, arg_sort = + Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) + in + let ty_elt = newgenvar jkind in + unify_pat_types_penv loc env (Predef.type_iarray ty_elt) expected_ty; + ty_elt, arg_sort, Immutable + | Mutable -> + match disambiguate_array_literal ~loc !!env expected_ty with + | { ty_elt = Some (ty_elt, sort); mut } -> ty_elt, sort, mut + | { ty_elt = None; mut } -> + let array_type = match mut with + | Immutable -> Predef.type_iarray + | Mutable -> Predef.type_array + in + let jkind, arg_sort = + Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) + in + let ty_elt = newgenvar jkind in + unify_pat_types_penv loc env (array_type ty_elt) expected_ty; + ty_elt, arg_sort, mut -let solve_Ppat_lazy ~refine loc env expected_ty = +let solve_Ppat_lazy loc env expected_ty = let nv = newgenvar (Jkind.Builtin.value ~why:Lazy_expression) in - unify_pat_types_refine ~refine loc env (Predef.type_lazy_t nv) + unify_pat_types_penv loc env (Predef.type_lazy_t nv) (generic_instance expected_ty); nv let solve_Ppat_constraint tps loc env mode 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 mode sty) in tps.tps_pattern_force <- force :: tps.tps_pattern_force; @@ -2028,7 +2209,7 @@ let solve_Ppat_constraint tps loc env mode sty expected_ty = in (cty, ty, expected_ty') -let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = +let solve_Ppat_variant loc env tag no_arg expected_ty = (* CR layouts v5: relax the restriction to value here. *) let arg_type = if no_arg @@ -2044,7 +2225,7 @@ let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = (* 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; + unify_pat_types_penv loc env (newgenty(Tvariant row)) expected_ty; (arg_type, make_row (newvar (Jkind.Builtin.value ~why:Row_variable)), instance expected_ty) @@ -2127,7 +2308,8 @@ let build_or_pat env loc lid = let type_for_loop_like_index ~error ~loc ~env ~param ~any ~var = match param.ppat_desc with | Ppat_any -> - any (Ident.create_local "_for", Uid.mk ~current_unit:(Env.get_unit_name ())) + any (Ident.create_local "_for", + Uid.mk ~current_unit:(Env.get_current_unit ())) | Ppat_var name -> var ~name ~pv_mode:Value.(min |> disallow_right) @@ -2156,11 +2338,13 @@ let type_for_loop_index ~loc ~env ~param = -> let check s = Warnings.Unused_for_index s in let pv_id = Ident.create_local 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 let pv = { pv_id; pv_uid; pv_mode; - pv_kind = Val_reg Jkind.Sort.(of_const Const.for_loop_index); - pv_type; pv_loc; pv_as_var; + pv_value_kind = + Val_reg Jkind.Sort.(of_const Const.for_loop_index); + pv_type; pv_loc; + pv_kind = if pv_as_var then As_var else Std_var; pv_attributes; pv_sort = Jkind.Sort.(of_const Const.for_loop_index); pv_lpoly = Lpoly.determined []; @@ -2298,7 +2482,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 @@ -2313,10 +2497,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_doc.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], @@ -2334,7 +2520,8 @@ end) = struct if Warnings.is_active (Name_out_of_scope ("", Name "")) then begin let path_s = Printtyp.wrap_printing_env ~error:true env - (fun () -> Format_doc.asprintf "%a" Printtyp.type_path tpath) in + (fun () -> Format_doc.asprintf "%a" Printtyp.Doc.type_path tpath) + in warn lid.loc (Warnings.Name_out_of_scope (path_s, Name (Longident.last lid.txt))) end @@ -2617,7 +2804,8 @@ let disambiguate_sort_lid_a_list let qual_lid = match qual, lid.txt with | Some modname, Longident.Lident s -> - {lid with txt = Longident.Ldot (modname, s)} + let name = { lid with txt = s } in + {lid with txt = Longident.Ldot (modname, name)} | _ -> lid in lid, process_label qual_lid, a @@ -2793,19 +2981,18 @@ let rec has_literal_pattern p = | Ppat_lazy p | Ppat_open (_, p) -> has_literal_pattern p - | Ppat_tuple (ps, _) -> has_literal_pattern_labeled_tuple ps | Ppat_array (_, ps) -> List.exists has_literal_pattern ps - | Ppat_unboxed_tuple (ps, _) -> has_literal_pattern_labeled_tuple ps + | Ppat_tuple (ps, _) + | Ppat_unboxed_tuple (ps, _) -> + List.exists (fun (_,p) -> has_literal_pattern p) ps | Ppat_record (ps, _) | Ppat_record_unboxed_product (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 -and has_literal_pattern_labeled_tuple labeled_ps = - List.exists (fun (_, p) -> has_literal_pattern p) labeled_ps - let check_scope_escape loc env level ty = try Ctype.check_scope_escape env level ty with Escape esc -> @@ -2865,9 +3052,6 @@ let as_comp_pattern | Value -> as_computation_pattern pat | Computation -> pat -let components_have_label (labeled_components : (string option * 'a) list) = - List.exists (function Some _, _ -> true | _ -> false) labeled_components - let forbid_atomic_field_patterns loc penv (label_lid, label, pat) = (* Pattern-matching under atomic record fields is not allowed. We still allow wildcard patterns, so that it is valid to list all @@ -2897,10 +3081,11 @@ let rec type_pat and type_pat_aux : type k . type_pat_state -> k pattern_category -> no_existentials:_ -> - alloc_mode:expected_pat_mode -> mutable_flag:mutable_flag -> penv:_ -> - _ -> _ -> _ -> k general_pattern + alloc_mode:expected_pat_mode -> mutable_flag:mutable_flag -> + penv:Pattern_env.t -> _ -> _ -> _ -> k general_pattern = fun tps category ~no_existentials ~alloc_mode ~mutable_flag ~penv sp expected_ty sort -> + assert (penv.in_counterexample = false); let type_pat tps category ?(alloc_mode=alloc_mode) ?(penv=penv) = type_pat tps category ~no_existentials ~alloc_mode ~mutable_flag ~penv in @@ -2918,46 +3103,17 @@ and type_pat_aux let rp = crp and rvp x = crp (pure category x) and rcp x = crp (only_impure category x) in - let type_pat_array mutability spl pat_attributes = - (* Sharing the code between the two array cases means we're guaranteed to - keep them in sync, at the cost of a worse diff with upstream; it - shouldn't be too bad. We can inline this when we upstream this code and - combine the two array pattern constructors. *) - let ty_elt, arg_sort = - solve_Ppat_array ~refine:false loc penv mutability expected_ty - in - let modalities = Typemode.mutable_modalities mutability in - check_project_mutability ~loc ~env:!!penv Array_elements mutability - alloc_mode.mode; - let is_contained_by : Mode.Hint.is_contained_by = - {containing = Array Modality; container = (loc, Pattern)} - in - let alloc_mode = - apply_is_contained_by is_contained_by ~modalities alloc_mode.mode - in - let alloc_mode = simple_pat_mode alloc_mode in - let pl = - List.map (fun p -> type_pat ~alloc_mode tps Value p ty_elt arg_sort) spl - in - rvp { - pat_desc = Tpat_array (mutability, arg_sort, pl); - pat_loc = loc; pat_extra=[]; - pat_type = instance expected_ty; - pat_attributes; - pat_env = !!penv; - pat_unique_barrier = Unique_barrier.not_computed () } - in let type_tuple_pat spl closed = (* CR layouts v5: consider sharing code with [type_unboxed_tuple_pat] below when we allow non-values in boxed tuples. *) + assert (closed = Open || List.length spl >= 2); + Option.iter + (fun l -> raise (Error (loc, !!penv, Repeated_tuple_pat_label l))) + (Misc.repeated_label spl); let args = match get_desc (expand_head !!penv expected_ty) with (* If it's a principally-known tuple pattern, try to reorder *) | Ttuple labeled_tl when is_principal expected_ty -> - begin match closed with - | Open -> Language_extension.assert_enabled ~loc Labeled_tuples () - | Closed -> () - end; reorder_pat loc penv spl closed labeled_tl expected_ty (* If not, it's not allowed to be open (partial) *) | _ -> @@ -2965,18 +3121,15 @@ and type_pat_aux | Open -> raise (Error (loc, !!penv, Partial_tuple_pattern_bad_type)) | Closed -> spl in - let spl_ann = - solve_Ppat_tuple ~refine:false ~alloc_mode loc penv args expected_ty + let expected_tys = + solve_Ppat_tuple ~alloc_mode loc penv args expected_ty in let pl = - List.map (fun (lbl, p, t, alloc_mode) -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - lbl; + List.map2 (fun (lbl, t, alloc_mode) (_, p) -> lbl, type_pat tps Value ~alloc_mode p t Jkind.Sort.(of_const Const.for_tuple_element)) - spl_ann + expected_tys args in rvp { pat_desc = Tpat_tuple pl; @@ -2989,14 +3142,14 @@ and type_pat_aux let type_unboxed_tuple_pat spl closed = Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; + assert (closed = Open || List.length spl >= 2); + Option.iter + (fun l -> raise (Error (loc, !!penv, Repeated_tuple_pat_label l))) + (Misc.repeated_label spl); let args = match get_desc (expand_head !!penv expected_ty) with (* If it's a principally-known tuple pattern, try to reorder *) | Tunboxed_tuple labeled_tl when is_principal expected_ty -> - begin match closed with - | Open -> Language_extension.assert_enabled ~loc Labeled_tuples () - | Closed -> () - end; reorder_pat loc penv spl closed labeled_tl expected_ty (* If not, it's not allowed to be open (partial) *) | _ -> @@ -3004,17 +3157,13 @@ and type_pat_aux | Open -> raise (Error (loc, !!penv, Partial_tuple_pattern_bad_type)) | Closed -> spl in - let spl_ann = - solve_Ppat_unboxed_tuple ~refine:false ~alloc_mode loc penv args - expected_ty + let expected_tys = + solve_Ppat_unboxed_tuple ~alloc_mode loc penv args expected_ty in let pl = - List.map (fun (lbl, p, t, alloc_mode, sort) -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - lbl; + List.map2 (fun (lbl, t, alloc_mode, sort) (_, p) -> lbl, type_pat tps Value ~alloc_mode p t sort, sort) - spl_ann + expected_tys args in let ty = newty (Tunboxed_tuple (List.map (fun (lbl, p, _) -> lbl, p.pat_type) pl)) @@ -3050,7 +3199,7 @@ and type_pat_aux in let type_label_pat (label_lid, label, sarg) = let ty_arg = - solve_Ppat_record_field ~refine:false loc penv label label_lid + solve_Ppat_record_field loc penv label label_lid record_ty record_form in check_project_mutability ~loc ~env:!!penv (Record_field label.lbl_name) label.lbl_mut alloc_mode.mode; @@ -3216,14 +3365,14 @@ and type_pat_aux pat_env = !!penv; pat_unique_barrier = Unique_barrier.not_computed () } | Ppat_interval (l, r) -> + let open Ast_helper in let expand_interval lo hi ~make = - let open Ast_helper.Pat in - let gloc = Location.ghostify loc in + let gloc = {loc with Location.loc_ghost=true} in let rec loop lo hi = - if lo = hi then constant ~loc:gloc (make lo) + if lo = hi then Pat.constant ~loc:gloc (make gloc lo) else - or_ ~loc:gloc - (constant ~loc:gloc (make lo)) + Pat.or_ ~loc:gloc + (Pat.constant ~loc:gloc (make gloc lo)) (loop (lo + 1) hi) in let p = if lo <= hi then loop lo hi else loop hi lo in @@ -3237,10 +3386,10 @@ and type_pat_aux with | Const_char c1, Const_char c2 -> expand_interval (Char.code c1) (Char.code c2) - ~make:(fun i -> Pconst_char (Char.chr i)) + ~make:(fun loc i -> Const.char ~loc (Char.chr i)) | Const_untagged_char c1, Const_untagged_char c2 -> expand_interval (Char.code c1) (Char.code c2) - ~make:(fun i -> Pconst_untagged_char (Char.chr i)) + ~make:(fun loc i -> Const.untagged_char ~loc (Char.chr i)) | _ -> raise (Error (loc, !!penv, Invalid_interval)) end @@ -3287,25 +3436,24 @@ and type_pat_aux let sargs = match sarg' with None -> [] - | Some sarg' -> - match sarg' with - | {ppat_desc = Ppat_tuple (spl, _)} as sp when + | Some {ppat_desc = Ppat_tuple (spl, _)} when constr.cstr_arity > 1 || Builtin_attributes.explicit_arity sp.ppat_attributes -> - if components_have_label spl then - raise (Error(loc, !!penv, Constructor_labeled_arg)) - else - List.map snd spl - | {ppat_desc = Ppat_any} as sp when + List.map (fun (l, sp) -> + match l with + | Some _ -> raise (Error(loc, !!penv, Constructor_labeled_arg)) + | None -> sp + ) 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; [] - | {ppat_desc = Ppat_any} as sp when constr.cstr_arity > 1 -> + | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 -> replicate_list sp constr.cstr_arity - | sp -> [sp] in + | 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 :: _ -> @@ -3317,7 +3465,7 @@ and type_pat_aux constr.cstr_arity, List.length sargs))); let (args, existential_ctyp) = - solve_Ppat_construct ~refine:false tps penv loc constr no_existentials + solve_Ppat_construct tps penv loc constr no_existentials existential_styp expected_ty in @@ -3376,7 +3524,7 @@ and type_pat_aux 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 + solve_Ppat_variant loc penv tag constant expected_ty in let arg = (* PR#6235: propagate type information *) match sarg, arg_type with @@ -3399,24 +3547,53 @@ and type_pat_aux Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; type_record_pat Unboxed_product lid_sp_list closed | Ppat_array (mut, spl) -> - let mut = - match mut with + (match mut with + | Asttypes.Mutable -> () + | Asttypes.Immutable -> + Language_extension.assert_enabled ~loc Immutable_arrays ()); + let ty_elt, arg_sort, mutability = + solve_Ppat_array loc penv mut expected_ty + in + let mutability = + match mutability with | Mutable -> Mutable { mode = Value.Comonadic.legacy; (* CR aspsmith: Revisit once we support atomic arrays *) atomic = Nonatomic } - | Immutable -> - Language_extension.assert_enabled ~loc Immutable_arrays (); - Immutable + | Immutable -> Immutable in - type_pat_array mut spl sp.ppat_attributes + let modalities = Typemode.mutable_modalities mutability in + check_project_mutability ~loc ~env:!!penv Array_elements mutability + alloc_mode.mode; + let is_contained_by : Mode.Hint.is_contained_by = + {containing = Array Modality; container = (loc, Pattern)} + in + let alloc_mode = + apply_is_contained_by is_contained_by ~modalities alloc_mode.mode + in + let alloc_mode = simple_pat_mode alloc_mode in + let pl = + List.map + (fun p -> type_pat ~alloc_mode tps Value p ty_elt arg_sort) spl + in + rvp { + pat_desc = Tpat_array (mutability, arg_sort, pl); + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv; + pat_unique_barrier = Unique_barrier.not_computed () } | 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 + ~before_generalize:(fun (_, tys) -> List.iter generalize tys) + begin fun () -> (* Introduce a new scope using with_local_level without generalizations *) let env1, p1, env2, p2 = with_local_level begin fun () -> @@ -3460,7 +3637,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), [p1.pat_type; p2.pat_type] + end + in + rp { pat_desc = pat_desc; pat_loc = loc; pat_extra = []; pat_type = instance expected_ty; pat_attributes = sp.ppat_attributes; @@ -3468,7 +3648,7 @@ and type_pat_aux pat_unique_barrier = Unique_barrier.not_computed () } | Ppat_lazy sp1 -> submode ~loc ~env:!!penv alloc_mode.mode mode_force_lazy; - let nv = solve_Ppat_lazy ~refine:false loc penv expected_ty in + let nv = solve_Ppat_lazy loc penv expected_ty in let alloc_mode = global_pat_mode alloc_mode in let p1 = type_pat ~alloc_mode tps Value sp1 nv @@ -3537,6 +3717,8 @@ and type_pat_aux pat_attributes = sp.ppat_attributes; pat_unique_barrier = Unique_barrier.not_computed (); } + | Ppat_effect _ -> + raise (Error (loc, !!penv, Effect_pattern_below_toplevel)) | Ppat_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -3544,11 +3726,11 @@ let type_pat tps category ?no_existentials ~mutable_flag penv = type_pat tps category ~no_existentials ~mutable_flag ~penv let type_pattern - category ~lev ~alloc_mode env spat expected_ty sort allow_modules + category ~lev ~alloc_mode env spat expected_ty ?cont sort allow_modules = - let tps = create_type_pat_state allow_modules in + 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 + ~equations_scope:lev ~in_counterexample:false in let pat = type_pat tps category ~alloc_mode ~mutable_flag:Immutable new_penv spat expected_ty sort @@ -3566,7 +3748,7 @@ let type_pattern_list let tps = create_type_pat_state allow_modules in let equations_scope = get_current_level () in let new_penv = Pattern_env.make env - ~is_lpoly ~equations_scope ~allow_recursive_equations:false in + ~is_lpoly ~equations_scope ~in_counterexample:false in let type_pat (attrs, pat_mode, exp_mode, pat) ty sort = Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> @@ -3585,13 +3767,13 @@ let type_pattern_list let type_class_arg_pattern cl_num val_env met_env l spat = let pvs, pat = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let tps = create_type_pat_state Modules_rejected in let nv = newvar (Jkind.Builtin.value ~why:Class_term_argument) in let alloc_mode = simple_pat_mode Value.legacy in let equations_scope = get_current_level () in let new_penv = Pattern_env.make val_env - ~equations_scope ~allow_recursive_equations:false in + ~equations_scope ~in_counterexample:false in let pat = type_pat tps Value ~no_existentials:In_class_args ~alloc_mode ~mutable_flag:Immutable new_penv spat nv @@ -3608,15 +3790,13 @@ let type_class_arg_pattern cl_num val_env met_env l spat = (type_option (newvar Predef.option_argument_jkind)); tps.tps_pattern_variables, pat end - ~post:(fun (pvs, _) -> iter_pattern_variables_type generalize_structure - pvs) in let (pv, val_env, met_env) = List.fold_right - (fun {pv_id; pv_uid; pv_type; pv_loc; pv_as_var; pv_attributes; pv_sort} + (fun {pv_id; pv_uid; pv_type; pv_loc; pv_kind; pv_attributes; pv_sort} (pv, val_env, met_env) -> let check s = - if pv_as_var then Warnings.Unused_var { name = s; mutated = false } + if pv_kind = As_var then Warnings.Unused_var { name = s; mutated = false } else Warnings.Unused_var_strict { name = s; mutated = false } in let id' = Ident.rename pv_id in let val_env = @@ -3658,7 +3838,7 @@ let type_self_pattern env spat = let alloc_mode = simple_pat_mode Value.legacy in let equations_scope = get_current_level () in let new_penv = Pattern_env.make env - ~equations_scope ~allow_recursive_equations:false in + ~equations_scope ~in_counterexample:false in let pat = type_pat tps Value ~no_existentials:In_self_pattern ~alloc_mode ~mutable_flag:Immutable new_penv spat nv @@ -3694,7 +3874,8 @@ let rec pat_tuple_arity spat = | Ppat_constant _ | Ppat_unboxed_unit | Ppat_unboxed_bool _ | Ppat_interval _ | Ppat_construct _ | Ppat_variant _ | Ppat_record _ | Ppat_record_unboxed_product _ | Ppat_array _ | Ppat_type _ - | Ppat_lazy _ | Ppat_unpack _ | Ppat_extension _ -> Not_local_tuple + | Ppat_lazy _ | Ppat_unpack _ | Ppat_extension _ | Ppat_effect _ -> + Not_local_tuple | Ppat_or(sp1, sp2) -> combine_pat_tuple_arity (pat_tuple_arity sp1) (pat_tuple_arity sp2) | Ppat_constraint(p, _, _) | Ppat_open(_, p) | Ppat_alias(p, _) -> pat_tuple_arity p @@ -3865,13 +4046,13 @@ let enter_nonsplit_or info = let rec check_counter_example_pat ~info ~(penv : Pattern_env.t) type_pat_state tp expected_ty k = + assert (penv.in_counterexample = true); 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 alloc_mode = simple_pat_mode Value.min in let solve_expected (x : pattern) : pattern = - unify_pat_types_refine ~refine x.pat_loc penv x.pat_type + unify_pat_types_penv x.pat_loc penv x.pat_type (instance expected_ty); x in @@ -3892,7 +4073,7 @@ let rec check_counter_example_pat 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 + solve_Ppat_record_field loc penv label label_lid record_ty record_form in check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) in @@ -3937,41 +4118,43 @@ let rec check_counter_example_pat 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 -> - let tpl_ann = - solve_Ppat_tuple ~refine ~alloc_mode loc penv tpl - expected_ty + let expected_tys = + solve_Ppat_tuple ~alloc_mode loc penv tpl expected_ty in - map_fold_cont (fun (l,p,t,_) k -> check_rec p t (fun p -> k (l, p))) + let tpl_ann = List.combine tpl expected_tys in + map_fold_cont (fun ((l,p),(_,t,_)) k -> check_rec p t (fun p -> k (l, p))) tpl_ann (fun pl -> - mkp k (Tpat_tuple pl) - ~pat_type:(newty (Ttuple (List.map (fun (l,p) -> (l,p.pat_type)) - pl)))) + let pat_type = + newty (Ttuple (List.map (fun (l,p) -> (l,p.pat_type)) pl)) + in + mkp k (Tpat_tuple pl) ~pat_type) | Tpat_unboxed_tuple tpl -> - let tpl_ann = - solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc penv - (List.map (fun (l,t,_) -> l, t) tpl) - expected_ty + let expected_tys = + solve_Ppat_unboxed_tuple ~alloc_mode loc penv + (List.map (fun (l,t,_) -> l, t) tpl) expected_ty in List.iter2 - (fun (_, _, orig_sort) (_, _, _, _, sort) -> + (fun (_, _, orig_sort) (_, _, _, sort) -> (* Sanity check *) assert (Jkind.Sort.equate orig_sort sort)) - tpl tpl_ann; + tpl expected_tys; + let tpl_ann = List.combine tpl expected_tys in map_fold_cont - (fun (l,p,t,_,sort) k -> check_rec p t (fun p -> k (l, p, sort))) + (fun ((l,p,_),(_,t,_,sort)) k -> check_rec p t (fun p -> k (l, p, sort))) tpl_ann (fun pl -> - mkp k (Tpat_unboxed_tuple pl) - ~pat_type:(newty (Tunboxed_tuple - (List.map (fun (l,p,_) -> (l,p.pat_type)) - pl)))) + let pat_type = + newty (Tunboxed_tuple + (List.map (fun (l,p,_) -> (l,p.pat_type)) pl)) + in + mkp k (Tpat_unboxed_tuple pl) ~pat_type) | 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 + solve_Ppat_construct + type_pat_state penv loc constr None None expected_ty in map_fold_cont (fun (p,t) -> check_rec p t.Types.ca_type) @@ -3981,7 +4164,7 @@ let rec check_counter_example_pat | 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 + solve_Ppat_variant loc penv tag constant expected_ty in let k arg = mkp k ~pat_type (Tpat_variant(tag, arg, ref row)) in begin @@ -3993,11 +4176,18 @@ let rec check_counter_example_pat | Tpat_record(fields, closed) -> type_label_pats fields closed Legacy | Tpat_record_unboxed_product(fields, closed) -> type_label_pats fields closed Unboxed_product - | Tpat_array (mut, original_arg_sort, tpl) -> - let ty_elt, arg_sort = solve_Ppat_array ~refine loc penv mut expected_ty in + | Tpat_array (mutability, original_arg_sort, tpl) -> + let mut : mutable_flag = + match mutability with + | Mutable _ -> Mutable + | Immutable -> Immutable + in + let ty_elt, arg_sort, _ = + solve_Ppat_array loc penv mut expected_ty + in assert (Jkind.Sort.equate original_arg_sort arg_sort); map_fold_cont (fun p -> check_rec p ty_elt) tpl - (fun pl -> mkp k (Tpat_array (mut, arg_sort, pl))) + (fun pl -> mkp k (Tpat_array (mutability, arg_sort, pl))) | Tpat_or(tp1, tp2, _) -> (* We are in counter-example mode, but try to avoid backtracking *) let must_split = @@ -4039,7 +4229,7 @@ let rec check_counter_example_pat mkp k (Tpat_or (p1, p2, None)) end | Tpat_lazy tp1 -> - let nv = solve_Ppat_lazy ~refine loc penv expected_ty in + let nv = solve_Ppat_lazy 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)) @@ -4049,14 +4239,16 @@ let check_counter_example_pat ~counter_example_args penv tp expected_ty = 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) + wrap_trace_gadt_instances ~force:true !!penv + (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 + ~equations_scope:lev ~in_counterexample:true in let state = save_state penv in let counter_example_args = { @@ -4119,9 +4311,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) @@ -4141,15 +4333,21 @@ let rec list_labels_aux env visited ls ty_fun = 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 + | 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 = - 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 -(* Collecting arguments for function applications *) + +(* Collecting arguments for function applications. *) (* See also Note [Type-checking applications] *) type untyped_apply_arg = @@ -4162,12 +4360,30 @@ type untyped_apply_arg = mode_fun : Alloc.lr; mode_arg : Alloc.lr; wrapped_in_some : bool; } + (* [arg] is a [Known_arg] in: + - [f arg] when is known to be a function (f : _ -> _) + - [f ~lab:arg] when (f : lab:_ -> _) + - [f ?lab:arg] when (f : ?lab:_ -> _) + In these cases we have [wrapped_in_some = false]. + + - [f ~lab:arg] when (f : ?lab:_ -> _) + In this case [wrapped_in_some = true]. + + [ty_arg] is the (possibly generic) expected type of the argument, + and [ty_arg0] is an instance of [ty_arg]. *) | Unknown_arg of { sarg : Parsetree.expression; ty_arg_mono : type_expr; sort_arg : Jkind.sort; mode_fun : Alloc.lr; mode_arg : Alloc.lr} + (* [arg] is an [Unknown_arg] in: + [f arg] when [f] is not known (either a type variable, + or the [commu_ok] case where a function type is known + but not principally). + + [ty_arg_mono] is the expected type of the argument, usually just + a fresh type variable. *) | Eliminated_optional_arg of { expected_label: arg_label; mode_fun: Alloc.lr; @@ -4175,6 +4391,11 @@ type untyped_apply_arg = sort_arg : Jkind.sort; mode_arg : Alloc.lr; level: int; } + (* When [f : ?foo:ty -> _ -> _], [~foo] is an [Eliminated_optional_arg] + in [f x] ([foo] is an optional argument that was not passed, but a + following positional argument was passed). + + [level] is the level of the function arrow. *) type untyped_omitted_param = { mode_fun: Alloc.lr; @@ -4191,30 +4412,6 @@ let is_partial_apply args = | Arg _ -> false) args -let remaining_function_type ty_ret mode_ret rev_args = - let ty_ret, _, _ = - List.fold_left - (fun (ty_ret, mode_ret, closed_args) (lbl, arg) -> - match arg with - | Arg (Unknown_arg { mode_arg; _ } | Known_arg { mode_arg; _ }) -> - let closed_args = mode_arg :: closed_args in - (ty_ret, mode_ret, closed_args) - | Arg (Eliminated_optional_arg - { mode_fun; ty_arg; mode_arg; level; _ }) - | Omitted { mode_fun; ty_arg; mode_arg; level } -> - let arrow_desc = lbl, mode_arg, mode_ret in - let ty_ret = - newty2 ~level - (Tarrow (arrow_desc, ty_arg, ty_ret, commu_ok)) - in - let mode_ret, _ = - Alloc.newvar_above (Alloc.join (mode_fun :: closed_args)) - in - (ty_ret, mode_ret, closed_args)) - (ty_ret, mode_ret, []) rev_args - in - ty_ret - (** Within a single application, constrain the curried arrow type as given by [close_over] and [partial_apply]. This constraint is not required for soundness, but useful in the lack of a signature, in which case the @@ -4329,10 +4526,49 @@ let check_curried_application_complete ~env ~app_loc args = seems to be easy to make this not quadratic, though.) *) +let remaining_function_type_for_error ty_ret mode_ret rev_args = + let ty_ret, _, _ = + List.fold_left + (fun (ty_ret, mode_ret, closed_args) (lbl, arg) -> + match arg with + | Arg (Unknown_arg { mode_arg; _ } | Known_arg { mode_arg; _ }) -> + let closed_args = mode_arg :: closed_args in + (ty_ret, mode_ret, closed_args) + | Arg (Eliminated_optional_arg + { mode_fun; ty_arg; mode_arg; level; _ }) + | Omitted { mode_fun; ty_arg; mode_arg; level } -> + let arrow_desc = lbl, mode_arg, mode_ret in + let ty_ret = + newty2 ~level + (Tarrow (arrow_desc, ty_arg, ty_ret, commu_ok)) + in + let mode_ret, _ = + Alloc.newvar_above (Alloc.join (mode_fun :: closed_args)) + in + (ty_ret, mode_ret, closed_args)) + (ty_ret, mode_ret, []) rev_args + in + ty_ret + +let get_arg_loc = function + | (_, Arg ( Known_arg { sarg; _ } + | Unknown_arg { sarg; _ })) -> Some sarg.pexp_loc + | (_, Arg (Eliminated_optional_arg _)) + | (_, Omitted _) -> None + +let previous_arg_loc rev_args ~funct = + (* [rev_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). *) + rev_args + |> List.find_map get_arg_loc + |> Option.value ~default:funct.exp_loc + (* This function processes any arguments remaining after traversing the type of the function; these would be over-saturated arguments or arguments to a function whose type is not known. *) -let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar = +let collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs + ret_tvar = let labels_match ~param ~arg = param = arg || !Clflags.classic && arg = Nolabel && not (is_omittable param) @@ -4341,12 +4577,6 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar let ls, tvar = list_labels env ty_fun in tvar || List.mem l ls in - let get_arg_loc = function - | (_, Arg ( Known_arg { sarg; _ } - | Unknown_arg { sarg; _ })) -> Some sarg.pexp_loc - | (_, Arg (Eliminated_optional_arg _)) - | (_, Omitted _) -> None - in let rec loop ty_fun mode_fun rev_args sargs = match sargs with | [] -> ty_fun, mode_fun, List.rev rev_args @@ -4401,7 +4631,9 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar (sort_arg, mode_arg, tpoly_get_mono ty_arg, mode_ret, ty_res) | td -> let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in - let ty_res = remaining_function_type ty_fun mode_fun rev_args in + let ty_res = + remaining_function_type_for_error ty_fun mode_fun rev_args + in match get_desc ty_res with | Tarrow _ -> if !Clflags.classic || not (has_label lbl ty_fun) then @@ -4410,25 +4642,11 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar else raise (Error(funct.exp_loc, env, Incoherent_label_order)) | _ -> - let previous_arg_loc = - (* [rev_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). *) - (* CR ccasinghino: the above comment is confusing - these - arguments are in reverse order according to the function - type, but not according to their positions in the source - program. We diverge from upstream here by not trying to - provide a good location in the [Eliminated_optional_arg] - case - maybe fix one day if it is noticeable. *) - rev_args - |> List.find_map get_arg_loc - |> 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; + previous_arg_loc = previous_arg_loc rev_args ~funct; extra_arg_loc = sarg.pexp_loc; })) in let arg = @@ -4436,81 +4654,72 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar in loop ty_res mode_ret ((lbl, Arg arg) :: rev_args) rest in - loop ty_fun mode_fun rev_args sargs + loop ty_fun0 mode_fun rev_args sargs (* See Note [Type-checking applications] for an overview *) -let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret_tvar = +let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs + ret_tvar = let warned = ref false in let rec loop ty_fun ty_fun0 mode_fun rev_args sargs = - let type_unknown_args () = - (* We're not looking at a *known* function type anymore, or there are no - arguments left. *) - collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs ret_tvar - in - if sargs = [] then type_unknown_args () else + if sargs = [] then + collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs + ret_tvar + else let ty_fun' = expand_head env ty_fun in - match get_desc ty_fun', get_desc (expand_head env ty_fun0), sargs with - | Tarrow (ad, ty_arg, ty_ret, com), - Tarrow (_, ty_arg0, ty_ret0, _), - (_, sarg1) :: _ - when is_commu_ok com -> - let lv = get_level ty_fun' in + 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 lopt = + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + | Tarrow (ad, ty_arg, ty_ret, com), + Tarrow (_, ty_arg0, ty_ret0, _) + when is_commu_ok com -> + Some (ad, `Arrow (ty_arg, ty_ret, ty_arg0, ty_ret0)) + | _ -> None + in + let first_arg_loc = + match sargs with + | (_, sarg) :: _ -> sarg.pexp_loc + | [] -> Location.none + in + match lopt with + | None -> + (* We're not looking at a *known* function type anymore. *) + collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs + ret_tvar + | Some (ad, arrow_kind) -> + begin let (l, mode_arg, mode_ret) = ad 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 sort_arg = - match type_sort ~why:Function_argument ~fixed:false env ty_arg with - | Ok sort -> sort - | Error err -> raise(Error(sarg1.pexp_loc, env, - Function_type_not_rep(ty_arg, err))) - in let name = label_name l and optional = is_optional l and omittable = is_omittable l in - let use_arg ~commuted sarg l' = - let wrapped_in_some = optional && not (is_optional l') in - if wrapped_in_some then - may_warn sarg.pexp_loc - (not_principal "using an optional argument here"); - Arg (Known_arg - { sarg; ty_arg; ty_arg0; commuted; sort_arg; - mode_fun; mode_arg; wrapped_in_some }) - in - let eliminate_omittable_arg expected_label = - may_warn funct.exp_loc - (Warnings.Non_principal_labels "eliminated omittable argument"); - Arg - (Eliminated_optional_arg - { mode_fun; ty_arg; mode_arg - ; sort_arg; level = lv; expected_label}) - in - let remaining_sargs, arg = + let remaining_sargs, arg_opt = 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 omittable && l' = Nolabel) then - (remaining_sargs, use_arg ~commuted:false sarg l') + (remaining_sargs, Some (sarg, l', ~commuted:false)) else if omittable && not (List.exists (fun (l, _) -> name = label_name l) - remaining_sargs) && + remaining_sargs) && List.exists (function (Nolabel, _) -> true | _ -> false) sargs then - (sargs, eliminate_omittable_arg l) + (sargs, None) else raise(Error(sarg.pexp_loc, env, Apply_wrong_label(l', ty_fun', omittable))) end else (* Arguments can be commuted, try to fetch the argument - corresponding to the first parameter. *) + corresponding to the first parameter. *) match extract_label name sargs with | Some (l', sarg, commuted, remaining_sargs) -> if commuted then begin @@ -4530,27 +4739,54 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret Location.prerr_warning sarg.pexp_loc (Warnings.Nonoptional_label label)); - remaining_sargs, use_arg ~commuted sarg l' + remaining_sargs, Some (sarg, l', ~commuted) | None -> - sargs, - if omittable && List.mem_assoc Nolabel sargs then - eliminate_omittable_arg l - else begin - (* No argument was given for this parameter, we abstract over - it. *) + sargs, None + in + match arrow_kind with + | `Arrow (ty_arg, ty_ret, ty_arg0, ty_ret0) -> + let sort_arg = + match + type_sort ~why:Function_argument ~fixed:false env ty_arg + with + | Ok sort -> sort + | Error err -> + raise(Error(first_arg_loc, env, + Function_type_not_rep(ty_arg, err))) + in + let arg = + match arg_opt with + | Some (sarg, l', ~commuted) -> + let wrapped_in_some = optional && not (is_optional l') in + if wrapped_in_some then + may_warn sarg.pexp_loc + (not_principal "using an optional argument here"); + Arg (Known_arg + { sarg; ty_arg; ty_arg0; commuted; sort_arg; + mode_fun; mode_arg; wrapped_in_some }) + | None -> + if omittable && List.mem_assoc Nolabel sargs then begin + may_warn funct.exp_loc (Warnings.Non_principal_labels + "eliminated omittable argument"); + Arg (Eliminated_optional_arg + { mode_fun; ty_arg; mode_arg + ; sort_arg; level = lv; expected_label = l}) + end 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 { mode_fun; ty_arg; mode_arg; level = lv; sort_arg } end - in - loop ty_ret ty_ret0 mode_ret ((l, arg) :: rev_args) remaining_sargs - | _ -> - type_unknown_args () + in + loop ty_ret ty_ret0 mode_ret ((l, arg) :: rev_args) remaining_sargs + end in loop ty_fun ty_fun0 mode_fun [] sargs (* See Note [Type-checking applications] for an overview *) -let type_omitted_parameters expected_mode env loc ty_ret mode_ret args = +let type_omitted_parameters_and_build_result_type expected_mode env loc ty_ret + mode_ret args = let ty_ret, mode_ret, _, _, args = List.fold_left (fun (ty_ret, mode_ret, open_args, closed_args, args) (lbl, arg, sch) -> @@ -4624,7 +4860,7 @@ let rec is_nonexpansive exp = is_nonexpansive pat_exp.vb_expr && is_nonexpansive body | Texp_apply(e, (_,Omitted _)::el, _, _, _) -> is_nonexpansive e && List.for_all is_nonexpansive_arg (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... *) @@ -4975,7 +5211,7 @@ let rec approx_type env sty = let mret = Alloc.newvar () in newty (Tarrow ((p,marg,mret), newmono arg, ret, commu_ok)) | Ptyp_tuple args -> - newty (Ttuple (List.map (fun (label, t) -> label, approx_type env t) args)) + newty (Ttuple (List.map (fun (l, t) -> l, approx_type env t) 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 @@ -5080,6 +5316,10 @@ let rec type_approx env sexp ty_expected = ignore (type_approx_constraint env (Pcoerce (sty1, sty2)) ty_expected ~loc : type_expr) + | Pexp_pack (_, Some ptyp) -> + let sty = Ast_helper.Typ.package ~loc ptyp in + ignore @@ + type_approx_constraint env (Pconstraint sty) ~loc ty_expected | _ -> () and type_tuple_approx (env: Env.t) loc ty_expected l = @@ -5145,7 +5385,10 @@ let check_univars env kind exp ty_expected vars = in let pty = instance ty_expected in let exp_ty, vars = - with_local_level_iter ~post:generalize begin fun () -> + with_local_level_generalize + ~before_generalize:(fun (exp_ty, vars) -> + List.iter generalize (exp_ty :: vars)) + begin fun () -> match get_desc pty with Tpoly (body, tl) -> (* Enforce scoping for type_let: @@ -5190,19 +5433,13 @@ let check_univars env kind exp ty_expected vars = ()) univars vars; unify_exp_types exp.exp_loc env exp_ty ty'; - ((exp_ty, vars), exp_ty::vars) + (exp_ty, vars) | _ -> assert false end in let ty, complete = polyfy env exp_ty vars in if not complete then error ty 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 @@ -5287,10 +5524,13 @@ let check_partial_application ~statement exp = | Texp_probe _ | Texp_probe_is_enabled _ | Texp_src_pos | Texp_function _ | Texp_quotation _ | Texp_antiquotation _ -> 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_apply_layout (e, _) -> check e @@ -5366,8 +5606,6 @@ let contains_variant_either ty = try loop ty; false with Exit -> true end -let shallow_iter_ppat_labeled_tuple f lst = List.iter (fun (_,p) -> f p) lst - let shallow_iter_ppat f p = match p.ppat_desc with | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ @@ -5377,10 +5615,11 @@ 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 (fun (_,p) -> f p) lst - | Ppat_unboxed_tuple (lst, _) -> shallow_iter_ppat_labeled_tuple f lst + | Ppat_tuple (lst, _) -> List.iter (fun (_, p) -> f p) lst + | Ppat_unboxed_tuple (lst, _) -> List.iter (fun (_, p) -> f p) lst | Ppat_construct (_, Some (_, p)) | Ppat_exception p | Ppat_alias (p,_) | Ppat_open (_,p) @@ -5425,15 +5664,18 @@ let may_contain_gadts p = (* One of the things we do in the presence of GADT constructors (see above definition) is treat `let p = e in ...` as a match `match e with p -> ...`. This changes the way type inference works to check the expression first, and - using its type in the checking of the pattern. We want that behavior for + use its type in the checking of the pattern. We want that behavior for labeled tuple patterns as well. *) let turn_let_into_match p = - exists_ppat (fun p -> - match p.ppat_desc with - | Ppat_construct _ -> true - | Ppat_tuple (_, Open) -> true - | Ppat_tuple (ps, _) when components_have_label ps -> true - | _ -> false) p + exists_ppat + (fun p -> + match p.ppat_desc with + | Ppat_construct _ -> true + | Ppat_tuple (_, Open) -> true + | Ppat_tuple (spl, Closed) -> + List.exists (fun (l, _) -> Option.is_some l) spl + | _ -> 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 @@ -5461,7 +5703,7 @@ 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 @@ -5470,30 +5712,9 @@ let check_absent_variant env = 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. - - 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 @@ -5510,15 +5731,6 @@ let name_cases default lst = (* Typing of expressions *) -(** [sdesc_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 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))) - let is_exclave_extension_node = function | "extension.exclave" | "ocaml.exclave" | "exclave" -> true | _ -> false @@ -5533,7 +5745,7 @@ let rec is_inferred sexp = [Nolabel, sbody]) when is_exclave_extension_node txt -> is_inferred sbody | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint (_, Some _, _) - | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true + | Pexp_coerce _ | Pexp_send _ | Pexp_new _ | Pexp_pack (_, Some _) -> true | Pexp_sequence (_, e) | Pexp_open (_, e) | Pexp_constraint (e, None, _) -> is_inferred e | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 @@ -5592,6 +5804,10 @@ let with_explanation explanation f = 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 + let unique_use ~loc ~env mode_l mode_r = if not (Language_extension.is_at_least Unique Language_extension.maturity_of_unique_for_drf) then begin @@ -5709,7 +5925,7 @@ let split_function_ty let { ty = ty_fun; explanation }, loc_fun = in_function in let separate = !Clflags.principal || Env.has_local_constraints env in let { ty_arg; ty_ret; arg_mode; ret_mode } as filtered_arrow = - with_local_level_if separate begin fun () -> + with_local_level_generalize_structure_if separate begin fun () -> let force_tpoly = (* If [has_poly] is true then we rely on the later call to type_pat to enforce the invariant that the parameter type @@ -5724,9 +5940,6 @@ let split_function_ty in raise (Error(loc_fun, env, err)) end - ~post:(fun {ty_arg; ty_ret; _} -> - generalize_structure ty_arg; - generalize_structure ty_ret) in apply_mode_annots ~loc:loc_fun ~env Parameter mode_annots arg_mode; apply_mode_annots ~loc:loc_fun ~env Return ret_mode_annots ret_mode; @@ -5825,25 +6038,6 @@ and type_function_ret_info = ret_sort: Jkind.sort; } -(* 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 generalize_structure_type_block_access_result - { ba; base_ty; el_ty; flat_float = _ } = - generalize_structure base_ty; - generalize_structure el_ty; - match ba with - | Baccess_field _ -> () - | Baccess_block (_, idx) -> - generalize_structure_exp idx - -let generalize_structure_type_unboxed_access_result - (el_ty, Uaccess_unboxed_field _) = - generalize_structure el_ty - (* value binding elaboration *) let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; pvb_modes=modes; _ } = @@ -5997,13 +6191,12 @@ and type_expect_ env (expected_mode : expected_mode) 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 let type_expect_record (type rep) ~overwrite (record_form : rep record_form) @@ -6015,11 +6208,11 @@ and type_expect_ | None -> None | Some sexp -> let exp, mode = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let mode = Value.newvar () in let exp = type_exp ~recarg env (mode_default mode) sexp in exp, mode - end ~post:(fun (exp, _) -> generalize_structure_exp exp) + end in Some (exp, Mode.Value.disallow_right mode) in @@ -6066,7 +6259,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 @@ -6293,7 +6486,7 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } in - match desc with + match sexp.pexp_desc with | Pexp_ident lid -> let path, actual_mode, layout_args, desc, kind = type_ident env ~recarg lid @@ -6349,34 +6542,34 @@ and type_expect_ submode ~loc ~env actual_mode expected_mode; if List.is_empty layout_args then exp else { exp with exp_desc = Texp_apply_layout (exp, layout_args) } - | Pexp_constant(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 expected_mode - 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({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 expected_mode + 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_unboxed_unit -> Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; @@ -6442,7 +6635,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 @@ -6491,9 +6684,10 @@ 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 (Jkind.Builtin.any ~why:Dummy_jkind))) + unify_exp ~sexp new_env body + (newvar (Jkind.Builtin.any ~why:Dummy_jkind))) in let exp = match mutable_flag, pat_exp_list with @@ -6591,39 +6785,35 @@ and type_expect_ | Nontail | Default -> Value.newvar () in let funct_expected_mode = mode_default funct_mode in - (* does the function return a tvar which is too generic? *) + let outer_level = get_current_level () in + let outer_level_var () = + newvar2 outer_level (Jkind.Builtin.any ~why:Dummy_jkind) + in let rec ret_tvar seen ty_fun = let ty = expand_head env ty_fun in if TypeSet.mem ty seen then false 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 (outer_level_var ()) ty_arg with Unify _ -> assert false); ret_tvar (TypeSet.add ty seen) ty_fun | Tvar _ -> - let v = newvar (Jkind.Builtin.any ~why:Dummy_jkind) in + let v = outer_level_var () in let rt = get_level ty > get_level v in unify_var env v ty; rt | _ -> - let v = newvar (Jkind.Builtin.any ~why:Dummy_jkind) in - unify_var env v ty; + unify_var env (outer_level_var ()) ty; false in + (* one more level for warning on non-returning functions *) + with_local_level_generalize ~before_generalize:ignore begin fun () -> let type_sfunct sfunct = - (* one more level for warning on non-returning functions *) - let funct, ty = - with_local_level - begin fun () -> - let funct = - with_local_level_if_principal - (fun () -> type_exp env funct_expected_mode sfunct) - ~post: generalize_structure_exp - in - let ty = instance funct.exp_type in - (funct, ty) - end + let funct = + with_local_level_generalize_structure_if_principal + (fun () -> type_exp env funct_expected_mode sfunct) in + let ty = instance funct.exp_type in let rt = wrap_trace_gadt_instances env (ret_tvar TypeSet.empty) ty in rt, funct in @@ -6686,6 +6876,7 @@ and type_expect_ submode ~loc ~env ~reason:(Application ty_ret) mode_ret expected_mode; check_tail_call_local_returning loc env ap_mode pm; exp + end | Pexp_match(sarg, caselist) -> let is_bor = is_borrow sarg in let env, expected_mode, exp_extra = @@ -6703,25 +6894,46 @@ and type_expect_ tuple_pat_mode mode modes_pat, mode_tuple mode modes in let arg, sort = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let expected_ty, sort = new_rep_var ~why:Match () in let arg = type_expect env arg_expected_mode sarg (mk_expected expected_ty) in arg, sort - end ~post:(fun (arg, _) -> - may_lower_contravariant_then_generalize env arg) + end ~before_generalize:(fun (arg, _) -> + may_lower_contravariant env arg; + generalize arg.exp_type) + 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_pat_mode expected_mode arg.exp_type + sort 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 expected_mode ty_expected_explained loc + eff_caselist eff_conts in - let cases, partial = - type_cases Computation env arg_pat_mode expected_mode - arg.exp_type sort 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, sort, cases, partial); + exp_desc = Texp_match(arg, sort, val_cases, eff_cases, partial); exp_loc = loc; exp_extra; exp_type = instance ty_expected; exp_attributes = sexp.pexp_attributes; @@ -6733,13 +6945,32 @@ and type_expect_ sbody ty_expected_explained in let arg_mode = simple_pat_mode Value.legacy in - let cases, _ = + 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 arg_mode expected_mode Predef.type_exn Jkind.Sort.(of_const Const.for_exception) ty_expected_explained - ~check_if_total:false loc caselist in + ~check_if_total:false loc exn_caselist + in + let eff_cases = + match eff_caselist with + | [] -> [] + | eff_caselist -> + type_effect_cases Value env expected_mode 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; @@ -6751,8 +6982,8 @@ and type_expect_ type_unboxed_tuple ~loc ~env ~expected_mode ~ty_expected ~explanation ~attributes:sexp.pexp_attributes sexpl | Pexp_construct(lid, sarg) -> - type_construct ~overwrite env expected_mode loc lid - sarg ty_expected_explained sexp.pexp_attributes + type_construct ~overwrite ~sexp env expected_mode lid sarg + ty_expected_explained | Pexp_variant(l, sarg) -> (* Keep sharing *) let ty_expected1 = protect_expansion env ty_expected in @@ -6818,18 +7049,8 @@ and type_expect_ Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; type_expect_record ~overwrite Unboxed_product lid_sexp_list opt_sexp | Pexp_field(srecord, lid) -> - let (record, record_sort, rmode, label, _, ambiguity) = - type_label_access Legacy env srecord Env.Projection lid - in - let ty_arg = - with_local_level_if_principal begin fun () -> - (* [ty_arg] is the type of field, [ty_res] is the type of record, they - could share type variables, which are now instantiated *) - let (_, ty_arg, ty_res) = instance_label ~fixed:false label in - (* we now link the two record types *) - unify_exp env record ty_res; - ty_arg - end ~post:generalize_structure + let record, record_sort, rmode, label, ambiguity, ty_arg = + solve_Pexp_field ~label_usage:Env.Projection env sexp srecord Legacy lid in check_project_mutability ~loc:record.exp_loc ~env (Record_field label.lbl_name) label.lbl_mut rmode; @@ -6887,18 +7108,9 @@ and type_expect_ exp_env = env } | Pexp_unboxed_field(srecord, lid) -> Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; - let (record, record_sort, rmode, label, _, ambiguity) = - type_label_access Unboxed_product env srecord Env.Projection lid - in - let ty_arg = - with_local_level_if_principal begin fun () -> - (* [ty_arg] is the type of field, [ty_res] is the type of record, they - could share type variables, which are now instantiated *) - let (_, ty_arg, ty_res) = instance_label ~fixed:false label in - (* we now link the two record types *) - unify_exp env record ty_res; - ty_arg - end ~post:generalize_structure + let record, record_sort, rmode, label, ambiguity, ty_arg = + solve_Pexp_field ~label_usage:Env.Projection env sexp srecord + Unboxed_product lid in if Types.is_mutable label.lbl_mut then fatal_error @@ -6954,7 +7166,7 @@ and type_expect_ (Texp_inspected_type (Label_disambiguation ambiguity), loc, []) :: record.exp_extra } in - unify_exp env record ty_record; + unify_exp ~sexp env record ty_record; rue { exp_desc = Texp_setfield (record, Locality.disallow_right (regional_to_local @@ -6964,27 +7176,71 @@ and type_expect_ exp_type = instance Predef.type_unit; exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_array(mut, sargl) -> + | Pexp_array(mutability, sargl) -> + (* [: :] syntax requires the iarray extension. + Check for it before proceeding with type-based disambiguation. *) + (match mutability with + | Mutable -> () + | Immutable -> + Language_extension.assert_enabled ~loc Immutable_arrays ()); + let ty_elt, elt_sort, mutability = + let ty_expected = generic_instance ty_expected in + match mutability with + | Immutable -> + let jkind, elt_sort = + Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) + in + let ty_elt = newgenvar jkind in + with_explanation (fun () -> + unify_exp_types loc env (Predef.type_iarray ty_elt) ty_expected); + ty_elt, elt_sort, Asttypes.Immutable + | Mutable -> + match disambiguate_array_literal ~loc env ty_expected with + | { ty_elt = Some (ty_elt, sort); mut } -> ty_elt, sort, mut + | { ty_elt = None; mut } -> + let jkind, elt_sort = + Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) + in + let ty_elt = newgenvar jkind in + let to_unify = + match mut with + | Mutable -> Predef.type_array ty_elt + | Immutable -> Predef.type_iarray ty_elt + in + with_explanation (fun () -> + unify_exp_types loc env to_unify ty_expected); + ty_elt, elt_sort, mut + in let mutability = - match mut with + match mutability with | Mutable -> Mutable { mode = Value.Comonadic.legacy; (* CR aspsmith: Revisit once we support atomic arrays *) atomic = Nonatomic; } - | Immutable -> - Language_extension.assert_enabled ~loc Immutable_arrays (); - Immutable + | Immutable -> Immutable in - type_generic_array - ~loc - ~env - ~expected_mode - ~ty_expected - ~explanation - ~mutability - ~attributes:sexp.pexp_attributes - sargl + let alloc_mode, array_mode = register_allocation ~loc expected_mode in + let modalities = Typemode.mutable_modalities mutability in + let is_contained_by : Mode.Hint.is_contained_by = + {containing = Array Modality; container = (loc, Expression)} + in + let argument_mode = + mode_is_contained_by is_contained_by ~modalities array_mode + in + check_construct_mutability ~loc ~env mutability ~ty:ty_elt array_mode; + let argument_mode = expect_mode_cross env ty_elt argument_mode in + let argl = + List.map + (fun sarg -> type_expect env argument_mode sarg (mk_expected ty_elt)) + sargl + in + re { + exp_desc = Texp_array (mutability, elt_sort, argl, alloc_mode); + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } | Pexp_idx (ba, uas) -> Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; (* Compute the expected base type, to use for disambiguation of the record @@ -7001,8 +7257,7 @@ and type_expect_ let expected_base_ty = expected_base_ty ty_expected in let principal = is_principal ty_expected in let { ba; base_ty; el_ty; flat_float; modality } = - with_local_level_if_principal - ~post:generalize_structure_type_block_access_result + with_local_level_generalize_structure_if_principal (fun () -> let res = type_block_access env expected_base_ty principal ba in (* This unification is to get a better [base_ty], and is not @@ -7037,9 +7292,7 @@ and type_expect_ (fun (el_ty, modality) ua -> (* Generalize after each step, otherwise we'll have more "non-principal" warnings than desired. *) - with_local_level_if_principal - ~post:(fun ((t,_), ua) -> - generalize_structure_type_unboxed_access_result (t,ua)) + with_local_level_generalize_structure_if_principal (fun () -> let (el_ty, ua_modality), ua = type_unboxed_access env loc el_ty ua @@ -7115,7 +7368,7 @@ and type_expect_ type_expect env expected_mode 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 = []; @@ -7225,7 +7478,7 @@ and type_expect_ } | Pexp_constraint (sarg, Some sty, modes) -> let modes = Typemode.transl_mode_annots modes in - let (ty, extra_cty) = + let (ty, exp_extra) = let alloc_mode = Mode.Alloc.Const.Option.value modes.mode_modes @@ -7250,9 +7503,8 @@ and type_expect_ exp_env = env; exp_extra = (Texp_mode modes, loc, []) :: - (Texp_constraint extra_cty, - loc, - sexp.pexp_attributes) :: arg.exp_extra; + (Texp_constraint exp_extra, loc, sexp.pexp_attributes) :: + arg.exp_extra; } | Pexp_coerce(sarg, sty, sty') -> let arg, ty', exp_extra = @@ -7276,9 +7528,8 @@ and type_expect_ submode ~loc ~env Mode.Value.legacy expected_mode; let pm = position_and_mode env expected_mode sexp in let (obj,meth,typ) = - with_local_level_if_principal + with_local_level_generalize_structure_if_principal (fun () -> type_send env loc explanation e met.txt) - ~post:(fun (_,_,typ) -> generalize_structure typ) in let typ, obj_extra = match get_desc typ with @@ -7405,7 +7656,7 @@ and type_expect_ | 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 @@ -7416,7 +7667,7 @@ and type_expect_ | _ -> 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 = []; @@ -7447,7 +7698,7 @@ and type_expect_ let body = type_expect new_env expected_mode 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 @@ -7524,8 +7775,7 @@ and type_expect_ } | 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 -> @@ -7547,59 +7797,92 @@ and type_expect_ { 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 tl ty') - ~post:(fun (_,ty'') -> generalize_structure ty'') in let exp = type_expect env expected_mode sbody (mk_expected ty'') in (exp, vars) end - ~post: begin fun (exp,vars) -> - generalize_and_check_univars env "method" exp ty_expected vars + ~before_generalize:begin fun (exp,vars) -> + List.iter generalize (exp.exp_type :: 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 expected_mode sbody in let exp = {exp with exp_type = newmono 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(name, jkind, sbody) -> - type_newtype_expr ~loc ~env ~expected_mode ~rue ~attributes:sexp.pexp_attributes - name jkind sbody - | 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 - let mode = Typedtree.mode_without_locks_exn modl.mod_mode in - submode ~loc ~env mode expected_mode; - 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 } + let body, ety, id, uid = + type_newtype env name jkind (fun env -> + let expr = type_exp env expected_mode 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 (id, name, jkind, uid), + loc, sexp.pexp_attributes) :: body.exp_extra + } + | Pexp_pack (m, optyp) -> + begin match optyp with + | Some ptyp -> + let t = Ast_helper.Typ.package ~loc:ptyp.ppt_loc ptyp in + let pty, exp_extra = type_constraint env t Alloc.Const.legacy in + begin match get_desc (instance pty) with + | Tpackage pack -> + let (modl, pack') = !type_package env m pack in + let mode = Typedtree.mode_without_locks_exn modl.mod_mode in + submode ~loc ~env mode expected_mode; + let ty = newty (Tpackage pack') in + unify_exp_types m.pmod_loc env (instance pty) ty; + rue { + exp_desc = Texp_pack modl; + exp_loc = loc; + exp_extra = [Texp_constraint exp_extra, loc, []]; + exp_type = instance pty; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + fatal_error "[type_expect] Package not translated to a package" + end + | None -> + let pack = + match get_desc (Ctype.expand_head env (instance ty_expected)) with + Tpackage pack -> + 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"); + pack + | Tvar _ -> + raise (Error (loc, env, Cannot_infer_signature)) + | _ -> + raise (Error (loc, env, Not_a_packed_module ty_expected)) + in + let (modl, pack') = !type_package env m pack in + let mode = Typedtree.mode_without_locks_exn modl.mod_mode in + submode ~loc ~env mode expected_mode; + rue { + exp_desc = Texp_pack modl; + exp_loc = loc; exp_extra = []; + exp_type = newty (Tpackage pack'); + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end | Pexp_open (od, e) -> Env.check_no_open_quotations loc env Open_qt; let tv = newvar (Jkind.Builtin.any ~why:Dummy_jkind) in @@ -7625,15 +7908,16 @@ and type_expect_ (* CR layouts v5: eliminate value requirement *) let ty = newvar (Jkind.Builtin.value_or_null ~why:Tuple_element) in let loc = Location.ghostify slet.pbop_op.loc in - let spat_acc = Ast_helper.Pat.tuple ~loc [None, spat_acc; None, spat] Closed in + let spat_acc = + Ast_helper.Pat.tuple ~loc [None, spat_acc; None, spat] Closed + in let ty_acc = newty (Ttuple [None, ty_acc; None, ty]) in loop spat_acc ty_acc Jkind.Sort.scannable rest in let op_path, op_desc, op_type, spat_params, ty_params, param_sort, ty_func_result, body_sort, ty_result, op_result_sort, ty_andops, sort_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 = op_desc.val_type in @@ -7666,10 +7950,9 @@ 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, param_sort, - ty_func_result, body_sort, ty_result, op_result_sort, - ty_andops, sort_andops), - [ty_andops; ty_params; ty_func_result; ty_result]) + (op_path, op_desc, op_type, spat_params, ty_params, param_sort, + ty_func_result, body_sort, ty_result, op_result_sort, + ty_andops, sort_andops) end in let exp, exp_sort, ands = @@ -7759,7 +8042,9 @@ and type_expect_ begin match payload with | PStr ([{ pstr_desc = Pstr_eval - ({pexp_desc=(Pexp_constant (Pconst_string(name,_,None))); + ({pexp_desc= + (Pexp_constant + { pconst_desc = Pconst_string(name,_,None); _}); pexp_loc = name_loc; _ } , _)}]) -> @@ -7787,14 +8072,13 @@ and type_expect_ { pexp_desc = Pexp_field (srecord, lid); _ } as sexp, _ ) } ] -> - let (record, record_sort, rmode, label, _, _ambiguity) = - type_label_access Legacy env srecord Env.Mutation lid + let record, record_sort, rmode, label, ambiguity, ty_arg = + solve_Pexp_field ~label_usage:Env.Mutation env sexp srecord + Legacy lid in Env.mark_label_used Env.Projection label.lbl_uid; if (not (Types.is_atomic label.lbl_mut)) then raise (Error (loc, env, Label_not_atomic lid.txt)); - let (_, ty_arg, ty_res) = instance_label ~fixed:false label in - unify_exp env record ty_res; let alloc_mode, argument_mode = register_allocation ~loc expected_mode in @@ -7806,6 +8090,11 @@ and type_expect_ raise (Error (loc, env, Modalities_on_atomic_field lid.txt)) end; submode ~loc ~env rmode argument_mode; + let record = + { record with exp_extra = + (Texp_inspected_type (Label_disambiguation ambiguity), loc, []) + :: record.exp_extra } + in rue { exp_desc = Texp_atomic_loc @@ -8122,18 +8411,18 @@ and type_coerce match sty with | None -> let (cty', ty', force) = - with_local_level begin fun () -> + with_local_level_generalize_structure begin fun () -> Typetexp.transl_simple_type_delayed env type_mode sty' end - ~post:(fun (_, ty, _) -> generalize_structure ty) 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 expected_mode 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', _, _)) @@ -8145,14 +8434,14 @@ and type_coerce && closed_type_expr ~env ty' -> if not gen && (* first try a single coercion *) let snap = snapshot () in - let ty, _b = enlarge_type env ty' in + let ty, _b = enlarge_type env (generic_instance 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 + let force' = subtype env arg_type (generic_instance ty') in force (); force' (); if not gen && !Clflags.principal then Location.prerr_warning loc @@ -8162,7 +8451,7 @@ and type_coerce raise (Error (loc, env, Not_subtype err)) end; | _ -> - let ty, b = enlarge_type env ty' in + let ty, b = enlarge_type env (generic_instance 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 @@ -8173,14 +8462,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 type_mode sty and (cty', ty', force') = Typetexp.transl_simple_type_delayed env type_mode sty' in - ((cty, ty, force, cty', ty', force'), - [ ty; ty' ]) + (cty, ty, force, cty', ty', force') end in begin try @@ -8197,10 +8485,10 @@ and type_coerce and type_constraint env sty type_mode = (* Pretend separate = true, 1% slowdown for lablgtk *) let cty = - with_local_level begin fun () -> - Typetexp.transl_simple_type ~new_var_jkind:Any env ~closed:false type_mode sty + with_local_level_generalize_structure begin fun () -> + Typetexp.transl_simple_type ~new_var_jkind:Any env ~closed:false type_mode + sty end - ~post:(fun cty -> generalize_structure cty.ctyp_type) in cty.ctyp_type, cty @@ -8220,14 +8508,66 @@ and type_constraint_expect type_coerce constraint_arg env expected_mode loc ty_constrain ty_coerce type_mode ~loc_arg | Pconstraint ty_constrain -> - let ty, extra_cty = type_constraint env ty_constrain type_mode in + let ty, cty = type_constraint env ty_constrain type_mode in constraint_arg.type_with_constraint env expected_mode ty, ty, - Texp_constraint extra_cty + Texp_constraint cty 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 the jkind annotation written + by the user. +*) +and type_newtype + : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) + -> a * type_expr * Ident.t * Uid.t = + fun env { txt = name; loc = name_loc } jkind_annot_opt type_body -> + let jkind = + Jkind.of_annotation_option_default env ~context:(Newtype_declaration name) + ~default:(Jkind.Builtin.value ~why:Univar) jkind_annot_opt + in + let ty = + if Typetexp.valid_tyvar_name name then + newvar ~name jkind + else + newvar jkind + 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 jkind 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; + 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 = (* CR zqian: [lookup_value] should close over the memaddr of all prefix modules. *) @@ -8502,7 +8842,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 { function_ = _, params_suffix, body; newtypes; params_contain_gadt = suffix_contains_gadt; @@ -8698,7 +9038,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]. *) @@ -8757,7 +9097,7 @@ and type_label_access ~level:(Ctype.get_current_level ()) in let record = - with_local_level_if_principal ~post:generalize_structure_exp + with_local_level_generalize_structure_if_principal (fun () -> type_expect ~recarg:Allowed env (mode_default mode) srecord (mk_expected (newvar record_jkind))) @@ -8783,6 +9123,25 @@ and type_label_access (record, record_sort, Mode.Value.disallow_right mode, label, expected_type, ambiguity) +and solve_Pexp_field + : 'rep . label_usage:_ -> _ -> _ -> _ -> 'rep record_form -> _ -> + _ * _ * _ * 'rep gen_label_description * _ * _ = + fun ~label_usage env sexp srecord form lid -> + let (record, record_sort, rmode, label, _, ambiguity) = + type_label_access form env srecord label_usage lid + in + let ty_arg = + with_local_level_generalize_structure_if_principal begin fun () -> + (* [ty_arg] is the type of field, [ty_res] is the type of record, they + could share type variables, which are now instantiated *) + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in + (* we now link the two record types *) + unify_exp ~sexp env record ty_res; + ty_arg + end + in + (record, record_sort, rmode, label, ambiguity, ty_arg) + (* 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.) *) @@ -8801,14 +9160,20 @@ and type_format loc str env = loc = loc; } in let mk_constr name args = - let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in + let lid = + Longident.(Ldot(mknoloc (Lident "CamlinternalFormatBasics"), + mknoloc name)) + in let arg = match args with | [] -> None | [ e ] -> Some e | _ :: _ :: _ -> - Some (mk_exp_loc (Pexp_tuple (List.map (fun e -> None, e) args))) in + Some (mk_exp_loc (Pexp_tuple (List.map (fun e -> None, e) 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 @@ -9052,22 +9417,15 @@ and type_label_exp = fun ~overwrite create env arg_mode loc ty_expected (lid, label, sarg) record_form -> (* 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 = is_poly_Tpoly label.lbl_arg in + let (vars, arg) = + (* raise level to check univars *) + with_local_level_generalize_if is_poly begin fun () -> let unify_as_label ty_expected = - 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) @@ -9077,9 +9435,8 @@ and type_label_exp 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 let (vars, ty_arg) = unify_as_label ty_expected in if label.lbl_private = Private then @@ -9087,7 +9444,6 @@ and type_label_exp 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 overwrite = match overwrite with | No_overwrite_label -> No_overwrite @@ -9097,45 +9453,15 @@ and type_label_exp Assigning(ty_arg, mode) in let arg = type_argument ~overwrite env arg_mode sarg ty_arg (instance ty_arg) in - (vars, ty_arg, snap, arg) + (vars, 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 ~overwrite:No_overwrite env arg_mode 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 (vars, arg) -> + may_lower_contravariant env arg; + List.iter generalize (arg.exp_type :: label.lbl_arg :: vars) + ) 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 ~overwrite env (mode : expected_mode) sarg ty_expected' ty_expected = @@ -9201,7 +9527,7 @@ and type_argument ?explanation ?recarg ~overwrite env (mode : expected_mode) sar (* we must be very careful about not breaking the semantics *) let exp_mode, _ = Value.newvar_below (as_single_mode mode) in let texp = - with_local_level_if_principal ~post:generalize_structure_exp + with_local_level_generalize_structure_if_principal (fun () -> let expected_mode = mode @@ -9233,7 +9559,7 @@ and type_argument ?explanation ?recarg ~overwrite env (mode : expected_mode) sar 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 && @@ -9245,7 +9571,7 @@ and type_argument ?explanation ?recarg ~overwrite env (mode : expected_mode) sar marg, ty_arg, mret, 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 begin let alloc_mode, mode_subcomponent = register_allocation ~loc:sarg.pexp_loc ~desc:Function_coercion mode @@ -9262,7 +9588,7 @@ and type_argument ?explanation ?recarg ~overwrite env (mode : expected_mode) sar val_zero_alloc = Zero_alloc.default; val_modalities = Modality.undefined; 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 ~mode id desc env in @@ -9365,26 +9691,25 @@ and type_argument ?explanation ?recarg ~overwrite env (mode : expected_mode) sar let mode = expect_mode_cross env ty_expected' mode in let texp = type_expect ?recarg ~overwrite env mode sarg (mk_expected ?explanation ty_expected') in - unify_exp env texp ty_expected; + unify_exp ~sexp:sarg env texp ty_expected; texp (* See Note [Type-checking applications] for an overview *) -and type_apply_arg env ~app_loc ~funct ~index ~position_and_mode ~partial_app (lbl, arg) = +and type_apply_arg env ~app_loc ~funct ~index ~position_and_mode ~partial_app + (lbl, arg) = match arg with | Arg (Unknown_arg { sarg; ty_arg_mono; mode_arg; sort_arg }) -> let expected_mode, mode_arg = mode_argument ~funct ~index ~position_and_mode ~partial_app mode_arg in - let arg = - type_expect env expected_mode sarg (mk_expected ty_arg_mono) - in + let arg = type_expect env expected_mode sarg (mk_expected ty_arg_mono) in (match lbl with | Labelled _ | Nolabel -> () | Optional _ -> (* CR layouts v5: relax value requirement *) - unify_exp env arg + unify_exp ~sexp:sarg env arg (type_option(newvar Predef.option_argument_jkind)) | Position _ -> - unify_exp env arg (instance Predef.type_lexing_position)); + unify_exp ~sexp:sarg env arg (instance Predef.type_lexing_position)); (lbl, Arg (arg, mode_arg, sort_arg), None) | Arg (Known_arg { sarg; ty_arg; ty_arg0; mode_arg; wrapped_in_some; sort_arg }) -> @@ -9416,12 +9741,12 @@ and type_apply_arg env ~app_loc ~funct ~index ~position_and_mode ~partial_app (l let separate = !Clflags.principal || Env.has_local_constraints env in - let arg, _, _ = - with_local_level begin fun () -> + let arg, ty_arg, vars = + with_local_level_generalize begin fun () -> let vars, ty_arg' = - with_local_level_if separate begin fun () -> + with_local_level_generalize_structure_if separate begin fun () -> instance_poly_fixed vars ty_arg' - end ~post:(fun (_, ty_arg') -> generalize_structure ty_arg') + end in let (ty_arg0', vars0) = tpoly_get_poly ty_arg0 in let vars0, ty_arg0' = instance_poly_fixed vars0 ty_arg0' in @@ -9432,11 +9757,12 @@ and type_apply_arg env ~app_loc ~funct ~index ~position_and_mode ~partial_app (l in arg, ty_arg, vars end - ~post:(fun (arg, ty_arg, vars) -> + ~before_generalize:(fun (arg, ty_arg, vars) -> if maybe_expansive arg then lower_contravariant env arg.exp_type; - generalize_and_check_univars env "argument" arg ty_arg vars); + List.iter generalize (arg.exp_type :: ty_arg :: vars)) in + check_univars env "argument" arg ty_arg vars; {arg with exp_type = instance arg.exp_type}, sch end in @@ -9463,14 +9789,14 @@ and type_application env app_loc expected_mode position_and_mode | (* Special case for ignore: avoid discarding warning *) [Parsetree.Nolabel, sarg] when is_ignore funct -> let {ty_arg; arg_mode; ty_ret; ret_mode} = - with_local_level_if_principal (fun () -> - filter_arrow_mono env (instance funct.exp_type) Nolabel - ) ~post:(fun {ty_ret; _} -> generalize_structure ty_ret) + with_local_level_generalize_structure_if_principal (fun () -> + filter_arrow_mono env (instance funct.exp_type) Nolabel) in let type_sort ~why ty = match Ctype.type_sort ~why ~fixed:false env ty with | Ok sort -> sort - | Error err -> raise (Error (app_loc, env, Function_type_not_rep (ty, err))) + | Error err -> + raise (Error (app_loc, env, Function_type_not_rep (ty, err))) in let arg_sort = type_sort ~why:Function_argument ty_arg in let arg_mode, _ = @@ -9502,7 +9828,11 @@ and type_application env app_loc expected_mode position_and_mode end in let ty_ret, mode_ret, args, position_and_mode = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> + (* Consider for example the application + [f n] + with + [f : a:bar -> ?opt:baz -> int -> unit] *) let sargs = List.map (fun (label, e) -> Typetexp.transl_label_from_expr label e) sargs in @@ -9510,6 +9840,11 @@ and type_application env app_loc expected_mode position_and_mode collect_apply_args env funct ignore_labels ty (instance ty) (value_to_alloc_r2l funct_mode) sargs ret_tvar in + (* example: [collect_apply_args] returns + [ty_ret = unit] and + [args = [(Label "a", Omitted bar); + (Optional "opt", Arg (Eliminated_optional_arg baz)); + (Nolabel, Arg (Known_arg n))]] *) let partial_app = is_partial_apply untyped_args in let position_and_mode = if partial_app then position_and_mode_default else position_and_mode @@ -9520,13 +9855,22 @@ and type_application env app_loc expected_mode position_and_mode ~position_and_mode ~partial_app arg) untyped_args in + (* example: type-check [n] and generate [None] for [?opt]. + [args] becomes [(Label "a", Omitted bar); + (Optional "opt", Arg None); + (Nolabel, Arg n)] *) let ty_ret, mode_ret, args = - type_omitted_parameters expected_mode env app_loc ty_ret mode_ret - args + type_omitted_parameters_and_build_result_type expected_mode env + app_loc ty_ret mode_ret args in check_curried_application_complete ~env ~app_loc untyped_args; + (* example: + [ty_ret] becomes [a:bar -> unit] + [args] becomes [(Label "a", Omitted ()); + (Optional "opt", Arg None); + (Nolabel, Arg n)] *) ty_ret, mode_ret, args, position_and_mode - end ~post:(fun (ty_ret, _, _, _) -> generalize_structure ty_ret) + end in args, ty_ret, mode_ret, position_and_mode @@ -9536,6 +9880,9 @@ and type_tuple ~overwrite ~loc ~env ~(expected_mode : expected_mode) ~ty_expecte we allow non-values in boxed tuples. *) let arity = List.length sexpl in assert (arity >= 2); + Option.iter + (fun l -> raise (Error (loc, env, Repeated_tuple_exp_label l))) + (Misc.repeated_label sexpl); let alloc_mode, value_mode = register_allocation_value_mode ~loc expected_mode.mode in @@ -9587,9 +9934,6 @@ and type_tuple ~overwrite ~loc ~env ~(expected_mode : expected_mode) ~ty_expecte let expl = Misc.Stdlib.List.map3 (fun (label, body) ((_, ty), argument_mode) overwrite -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - label; let argument_mode = mode_default argument_mode in let argument_mode = expect_mode_cross env ty argument_mode in (label, type_expect ~overwrite env argument_mode body (mk_expected ty))) @@ -9608,6 +9952,9 @@ and type_unboxed_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; let arity = List.length sexpl in assert (arity >= 2); + Option.iter + (fun l -> raise (Error (loc, env, Repeated_tuple_exp_label l))) + (Misc.repeated_label sexpl); let argument_mode = expected_mode.mode |> apply_is_contained_by {containing = Tuple; container = (loc, Expression)} @@ -9651,9 +9998,6 @@ and type_unboxed_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected let expl = List.map2 (fun (label, body) ((_, ty, sort), argument_mode) -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - label; let argument_mode = mode_default argument_mode in let argument_mode = expect_mode_cross env ty argument_mode in (label, type_expect env argument_mode body (mk_expected ty), sort)) @@ -9669,8 +10013,8 @@ and type_unboxed_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected exp_attributes = attributes; exp_env = env } -and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg - ty_expected_explained attrs = +and type_construct ~overwrite ~sexp env (expected_mode : expected_mode) 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 @@ -9681,7 +10025,7 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg 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 @@ -9693,53 +10037,50 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg in let sargs = match sarg with - | None -> [] - | Some se -> begin - match se.pexp_desc with - | Pexp_tuple sel when - constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs - -> - if components_have_label sel then - raise(Error(loc, env, Constructor_labeled_arg)) - else - List.map (fun (_, e) -> e) sel - | _ -> [se] - end - in + None -> [] + | Some {pexp_desc = Pexp_tuple sel} when + constr.cstr_arity > 1 + || Builtin_attributes.explicit_arity sexp.pexp_attributes + -> + List.map (fun (l, se) -> + match l with + | Some _ -> + raise (Error(sexp.pexp_loc, env, Constructor_labeled_arg)) + | None -> se + ) 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 unify_as_construct ty_expected = - with_local_level_if separate 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, [], None); - exp_loc = loc; + exp_loc = sexp.pexp_loc; exp_extra = [ - Texp_inspected_type (Label_disambiguation ambiguity), loc, []]; + Texp_inspected_type (Label_disambiguation ambiguity), + sexp.pexp_loc, + [] + ]; 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 + with_explanation explanation (fun () -> + unify_exp ~sexp env {texp with exp_type = instance ty_res} + (instance ty_expected)); (ty_args, ty_res, texp) end - ~post:(fun (ty_args, ty_res, _) -> - generalize_structure ty_res; - List.iter (fun {Types.ca_type=ty; _} -> generalize_structure ty) ty_args) in let ty_args, ty_res, texp = unify_as_construct ty_expected in let ty_args0, ty_res = @@ -9748,7 +10089,7 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg | _ -> 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 @@ -9761,7 +10102,7 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg 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 constructor_mode = @@ -9780,12 +10121,14 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg | Variant_unboxed | Variant_with_null -> expected_mode, None | Variant_boxed _ when constr.cstr_constant -> expected_mode, None | Variant_boxed _ | Variant_extensible -> - let alloc_mode, argument_mode = register_allocation ~loc expected_mode in + let alloc_mode, argument_mode = + register_allocation ~loc:sexp.pexp_loc expected_mode + in argument_mode, Some alloc_mode in begin match overwrite, constr.cstr_repr with | Overwriting(_, _, _), Variant_unboxed -> - raise (Error (loc, env, Overwrite_of_invalid_term)); + raise (Error (sexp.pexp_loc, env, Overwrite_of_invalid_term)); | _, _ -> () end; let overwrites = @@ -9811,7 +10154,7 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg (fun e ({Types.ca_type=ty; ca_modalities=modalities; _},t0) overwrite -> let is_contained_by : Mode.Hint.is_contained_by = { containing = Constructor (constr.cstr_name, Modality); - container = (loc, Expression) } + container = (sexp.pexp_loc, Expression) } in let argument_mode = mode_is_contained_by is_contained_by ~modalities argument_mode @@ -9822,9 +10165,9 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg if constr.cstr_private = Private then begin match constr.cstr_repr with | Variant_extensible -> - raise(Error(loc, env, Private_constructor (constr, ty_res))) + raise(Error(sexp.pexp_loc, env, Private_constructor (constr, ty_res))) | Variant_boxed _ | Variant_unboxed -> - raise (Error(loc, env, Private_type ty_res)); + raise (Error(sexp.pexp_loc, env, Private_type ty_res)); | Variant_with_null -> assert false (* [Variant_with_null] can't be made private due to [or_null_reexport]. *) end; @@ -9849,39 +10192,43 @@ and type_statement ?explanation ?(position=RNontail) env sexp = | Texp_while _ -> true | _ -> false in + let expected_ty, sort = + if !Clflags.strict_sequence then + (* CR layouts v5: when we have unboxed unit, allow it for -strict-sequence + *) + instance Predef.type_unit, Jkind.Sort.scannable + else begin + (* We're requiring the statement to have a representable jkind. But that + doesn't actually rule out things like "assert false"---we'll just end + up getting a sort variable for its jkind. *) + (* CR layouts v10: Abstract jkinds will introduce cases where we really + have [any] and can't get a sort here. *) + new_rep_var ~why:Statement () + end + in (* Raise the current level to detect non-returning functions *) - let exp = - with_local_level - (fun () -> type_exp env (mode_max_with_position position) 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 - (* CR layouts v5: when we have unboxed unit, allow it for -strict-sequence *) - let expected_ty = instance Predef.type_unit in - with_explanation explanation (fun () -> - unify_exp env exp expected_ty); - exp, Jkind.Sort.scannable - else begin - (* We're requiring the statement to have a representable jkind. But that - doesn't actually rule out things like "assert false"---we'll just end up - getting a sort variable for its jkind. *) - (* CR layouts v10: Abstract jkinds will introduce cases where we really have - [any] and can't get a sort here. *) - let tv, sort = new_rep_var ~why:Statement () in - check_partial_application ~statement:true exp; - with_explanation explanation (fun () -> - try unify_var env ty tv - with Unify err -> - raise(Error(exp.exp_loc, env, - Expr_type_clash(err, None, Some sexp.pexp_desc)))); - exp, sort + with_local_level_generalize + (fun () -> type_exp env (mode_max_with_position position) sexp, sort) + ~before_generalize: begin fun (exp, _sort) -> + 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 + with_explanation explanation (fun () -> + unify_exp ~sexp env exp expected_ty) + else begin + check_partial_application ~statement:true exp; + with_explanation explanation (fun () -> + try unify_var env ty expected_ty + with Unify err -> + raise(Error(exp.exp_loc, env, + Expr_type_clash(err, None, Some sexp)))); + end end (* Most of the arguments are the same as [type_cases]. @@ -9898,20 +10245,22 @@ and type_statement ?explanation ?(position=RNontail) 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 pat_mode ty_arg sort_arg ty_res loc caselist ~type_body ~check_if_total -> (* ty_arg is _fully_ generalized *) @@ -9923,7 +10272,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 @@ -9953,25 +10302,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 ~alloc_mode:pat_mode env pattern - ty_arg sort_arg allow_modules + type_pattern ?cont category ~lev ~alloc_mode:pat_mode env + pattern ty_arg sort_arg allow_modules in pattern_force := force @ !pattern_force; { typed_pat = pat; @@ -9984,9 +10337,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 @@ -9994,7 +10344,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 = @@ -10002,7 +10352,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) *) @@ -10028,7 +10378,7 @@ 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') -> + ~before_generalize: begin fun (half_typed_cases, _, _, ty_arg') -> generalize ty_arg'; List.iter (fun { pat_vars; _ } -> iter_pattern_variables_type generalize pat_vars @@ -10037,11 +10387,12 @@ and map_half_typed_cases 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 @@ -10053,23 +10404,26 @@ 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 { name = s; mutated = false }) ~check_as:(fun s -> Warnings.Unused_var { name = s; mutated = false}) 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 = @@ -10146,80 +10500,13 @@ and map_half_typed_cases (* Ensure that existential types do not escape *) ~post:(fun ty_res' -> enforce_current_level env ty_res') -(** 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 the jkind annotation written - by the user. -*) -and type_newtype - : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) - -> a * type_expr * Ident.t * Uid.t = - fun env name jkind_annot_opt type_body -> - let { txt = name; loc = name_loc } : _ Location.loc = name in - let jkind = - Jkind.of_annotation_option_default env ~context:(Newtype_declaration name) - ~default:(Jkind.Builtin.value ~why:Univar) jkind_annot_opt - in - let ty = - if Typetexp.valid_tyvar_name name then - newvar ~name jkind - else - newvar jkind - in - (* Use [with_local_level] just for scoping *) - with_local_level begin fun () -> - (* Create a fake abstract type declaration for name. *) - let decl = new_local_type ~loc:name_loc Definition jkind 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; - let uid = decl.type_uid in - (result, ety, id, uid) - end - -(** [type_newtype] where the "body" is just an expression. *) -and type_newtype_expr - ~loc ~env ~expected_mode ~rue ~attributes name jkind_annot_opt sbody = - let body, ety, id, uid = - type_newtype env name jkind_annot_opt (fun env -> - let expr = type_exp env expected_mode 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 (id, name, jkind_annot_opt, uid), - loc, attributes) :: body.exp_extra } - (* Typing of match cases *) and type_cases : type k . k pattern_category -> - _ -> _ -> _ -> _ -> _ -> _ -> check_if_total:bool -> _ -> + _ -> _ -> _ -> _ -> _ -> _ -> ?conts:_ -> check_if_total:bool -> _ -> Parsetree.case list -> k case list * partial = fun category env pat_mode expr_mode - ty_arg sort_arg ty_res_explained ~check_if_total loc caselist -> + ty_arg sort_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 @@ -10242,17 +10529,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 pat_mode ty_arg sort_arg ty_res loc caselist - ~check_if_total + map_half_typed_cases ?conts category env pat_mode ty_arg sort_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 mode_max scond + (type_expect when_env mode_max scond (mk_expected ~explanation:When_guard Predef.type_bool)) in let exp = @@ -10260,6 +10554,7 @@ and type_cases in { c_lhs = pat; + c_cont = cont; c_guard = guard; c_rhs = {exp with exp_type = ty_infer} } @@ -10325,6 +10620,37 @@ and type_function_cases_expect {mode_modes = Alloc.disallow_right ret_mode; mode_desc = []} } end +and type_effect_cases + : type k . k pattern_category -> _ -> _ -> _ -> _ -> Parsetree.case list -> + _ -> k case list + = fun category env rhs_mode ty_res_explained loc caselist conts -> + let { ty = ty_res; explanation = _ } = ty_res_explained 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 scope = create_scope () in + let name = Ctype.get_new_abstract_name env "%eff" in + let id = Ident.create_scoped ~scope name in + let decl = + Ctype.new_local_type ~loc Definition (Jkind.for_effect_arg id) + 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 sort_eff = Jkind.Sort.(of_const Const.for_effect) in + let cases, _ = + type_cases category new_env (simple_pat_mode Value.legacy) rhs_mode + ty_arg sort_eff ty_res_explained ~conts ~check_if_total:false loc + caselist + in + cases + end + (* Typing of let bindings *) and type_let ?check ?check_strict ?(force_toplevel = false) @@ -10375,21 +10701,21 @@ and type_let ?check ?check_strict ?(force_toplevel = false) let attrs_list = List.map (fun (attrs, _, _, _) -> attrs) spatl in let is_recursive = (rec_flag = Recursive) in - let (pat_list, exp_list, new_env, mvs, sorts, _pvs) = - with_local_level begin fun () -> + let (pat_list, exp_list, new_env, mvs, sorts, pvs) = + with_local_level_generalize begin fun () -> if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); let (pat_list, new_env, force, pvs, mvs), sorts = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let nvs, sorts = List.split (List.map (fun _ -> new_rep_var ~why:Let_binding ()) spatl) in let (pat_list, _new_env, _force, pvs, _mvs as res) = - with_local_level_if is_recursive (fun () -> + with_local_level_generalize_if is_recursive (fun () -> type_pattern_list Value existential_context env mutable_flag spatl nvs sorts allow_modules ~is_lpoly - ) ~post:(fun (_, _, _, pvs, _) -> - iter_pattern_variables_type generalize pvs) + ) ~before_generalize:(fun (_, _, _, pvs, _) -> + iter_pattern_variables_type generalize pvs) in (* If recursive, first unify with an approximation of the expression *) @@ -10443,11 +10769,6 @@ and type_let ?check ?check_strict ?(force_toplevel = false) pat_list; res, sorts 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -10463,8 +10784,7 @@ and type_let ?check ?check_strict ?(force_toplevel = false) let mode_pat_typ_list = List.map (fun (m, pat) -> - let ty = pat.pat_type in - m, {pat with pat_type = instance ty}, ty) + m, {pat with pat_type = instance pat.pat_type}, pat.pat_type) pat_list in (* Only bind pattern variables after generalizing *) @@ -10487,8 +10807,7 @@ and type_let ?check ?check_strict ?(force_toplevel = false) match get_desc expected_ty 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_fixed ~keep_names:true tl ty) in let exp = @@ -10517,7 +10836,7 @@ and type_let ?check ?check_strict ?(force_toplevel = false) (mode_pat_typ_list, exp_list, new_env, mvs, sorts, List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs) end - ~post: begin fun (mode_pat_typ_list, exp_list, _, _, _, pvs) -> + ~before_generalize: begin fun (mode_pat_typ_list, exp_list, _, _, _, pvs) -> List.iter2 (fun (_, pat, _) (exp, _) -> if maybe_expansive exp then lower_contravariant env pat.pat_type) @@ -10536,12 +10855,6 @@ and type_let ?check ?check_strict ?(force_toplevel = false) pv_lpoly) ~f_mut:(unify_var env (newvar (Jkind.Builtin.any ~why:Dummy_jkind))) pvs; - (* update pattern variable jkind reasons *) - List.iter - (fun pv -> - Ctype.check_and_update_generalized_ty_jkind - ~name:pv.pv_id ~loc:pv.pv_loc pv.pv_type) - pvs; List.iter2 (fun (_, _, expected_ty) (exp, vars) -> match vars with @@ -10559,21 +10872,30 @@ and type_let ?check ?check_strict ?(force_toplevel = false) | Some vars -> if maybe_expansive exp then lower_contravariant env exp.exp_type; - generalize_and_check_univars env "definition" - exp expected_ty vars) + List.iter generalize (exp.exp_type :: expected_ty :: vars)) mode_pat_typ_list exp_list; - let update_exp_jkind (_, p, _) (exp, _) = - let pat_name = - match p.pat_desc with - Tpat_var { id; _ } -> Some id - | Tpat_alias { id; _ } -> Some id - | _ -> None in - Ctype.check_and_update_generalized_ty_jkind - ?name:pat_name ~loc:exp.exp_loc exp.exp_type - in - List.iter2 update_exp_jkind mode_pat_typ_list exp_list; end in + (* update pattern variable jkind reasons *) + List.iter + (fun pv -> + Ctype.check_and_update_generalized_ty_jkind + ~name:pv.pv_id ~loc:pv.pv_loc pv.pv_type) + pvs; + List.iter2 + (fun (_, _, expected_ty) (exp, vars) -> + Option.iter (check_univars env "definition" exp expected_ty) vars) + pat_list exp_list; + let update_exp_jkind (_, p, _) (exp, _) = + let pat_name = + match p.pat_desc with + Tpat_var { id; _ } -> Some id + | Tpat_alias { id; _ } -> Some id + | _ -> None in + Ctype.check_and_update_generalized_ty_jkind + ?name:pat_name ~loc:exp.exp_loc exp.exp_type + in + List.iter2 update_exp_jkind pat_list exp_list; let l = List.combine pat_list exp_list in let l = List.combine sorts l in let l = @@ -10760,7 +11082,7 @@ and type_andops env sarg sands expected_sort expected_ty = | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest -> let op_path, op_desc, op_type, ty_arg, sort_arg, ty_rest, sort_rest, ty_result, op_result_sort = - 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 = op_desc.val_type in let ty_arg, sort_arg = new_rep_var ~why:Function_argument () in @@ -10778,11 +11100,9 @@ and type_andops env sarg sands expected_sort 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, sort_arg, ty_rest, sort_rest, - ty_result, op_result_sort), - [ty_rest; ty_arg; ty_result]) + (op_path, op_desc, op_type, ty_arg, sort_arg, ty_rest, sort_rest, + ty_result, op_result_sort) end - ~post:generalize_structure in let let_arg, sort_let_arg, rest = loop env let_sarg rest sort_rest ty_rest @@ -10810,50 +11130,6 @@ and type_andops env sarg sands expected_sort expected_ty = in let_arg, sort_let_arg, List.rev rev_ands -(* Can be re-inlined when we upstream immutable arrays *) -and type_generic_array - ~loc - ~env - ~(expected_mode : expected_mode) - ~ty_expected - ~explanation - ~mutability - ~attributes - sargl - = - let alloc_mode, array_mode = register_allocation ~loc expected_mode in - let type_ = - if Types.is_mutable mutability then Predef.type_array - else Predef.type_iarray - in - let modalities = Typemode.mutable_modalities mutability in - let is_contained_by : Mode.Hint.is_contained_by = - {containing = Array Modality; container = (loc, Expression)} - in - let argument_mode = - mode_is_contained_by is_contained_by ~modalities array_mode - in - let jkind, elt_sort = - Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) - in - let ty = newgenvar jkind in - let to_unify = type_ ty in - with_explanation explanation (fun () -> - unify_exp_types loc env to_unify (generic_instance ty_expected)); - check_construct_mutability ~loc ~env mutability ~ty array_mode; - let argument_mode = expect_mode_cross env ty argument_mode in - let argl = - List.map - (fun sarg -> type_expect env argument_mode sarg (mk_expected ty)) - sargl - in - re { - exp_desc = Texp_array (mutability, elt_sort, argl, alloc_mode); - exp_loc = loc; exp_extra = []; - exp_type = instance ty_expected; - exp_attributes = attributes; - exp_env = env } - and type_expect_mode ~loc ~env ~(modes : Alloc.Const.Option.t) expected_mode = let min = Alloc.Const.Option.value ~default:Alloc.Const.min modes |> Const.alloc_as_value in let max = Alloc.Const.Option.value ~default:Alloc.Const.max modes |> Const.alloc_as_value in @@ -11117,7 +11393,7 @@ and type_comprehension_expr ~loc ~env ~ty_expected ~attributes cexpr = ~why:Jkind.History.Array_comprehension_element in let element_ty = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let element_ty = newvar jkind in unify_exp_types loc @@ -11125,7 +11401,7 @@ and type_comprehension_expr ~loc ~env ~ty_expected ~attributes cexpr = (instance (container_type element_ty)) (instance ty_expected); element_ty - end ~post:generalize_structure + end in let new_env, comp_clauses = (* To understand why we don't provide modes here, see "What modes should @@ -11251,7 +11527,7 @@ and type_comprehension_iterator let penv = Pattern_env.make env ~equations_scope:(get_current_level ()) - ~allow_recursive_equations:false + ~in_counterexample:false in let pattern = (* To understand why we can currently only provide [global] bindings for @@ -11355,7 +11631,6 @@ and type_send env loc explanation e met = in (obj,meth,typ) - let maybe_check_uniqueness_exp exp = if Language_extension.is_at_least Unique Language_extension.maturity_of_unique_for_drf then @@ -11392,12 +11667,14 @@ let type_let existential_ctx env mutable_flag rec_flag spat_sexp_list = let type_expression env jkind sexp = let exp = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> Typetexp.TyVarEnv.reset (); let expected = mk_expected (newvar jkind) in type_expect env mode_toplevel_expression sexp expected end - ~post:(may_lower_contravariant_then_generalize env) + ~before_generalize:(fun exp -> + may_lower_contravariant env exp; + generalize exp.exp_type) in let exp = match sexp.pexp_desc with @@ -11424,18 +11701,19 @@ let type_expression env sexp = (* Error report *) -let spellcheck ppf unbound_name valid_names = - Misc.did_you_mean ppf (fun () -> - Misc.spellcheck valid_names unbound_name - ) +let spellcheck unbound_name valid_names = + Misc.did_you_mean (Misc.spellcheck valid_names unbound_name) -let spellcheck_idents ppf unbound valid_idents = - spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) +let spellcheck_idents unbound valid_idents = + spellcheck (Ident.name unbound) (List.map Ident.name valid_idents) open Format_doc module Fmt = Format_doc -let longident = Printtyp.longident +module Printtyp = Printtyp.Doc + +let quoted_longident = Style.as_inline_code Pprintast.Doc.longident +let quoted_constr = Style.as_inline_code Pprintast.Doc.constr let tuple_component ~print_article ppf lbl = let article = @@ -11456,12 +11734,50 @@ 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` *) (* CR layouts v2.5: Should we add a case here for float#? Test it, if so. *) 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 @@ -11501,17 +11817,21 @@ let report_partial_application = function match get_desc tr.Errortrace.got.Errortrace.expanded with | Tarrow _ -> [ Location.msg - "@[@{Hint@}: This function application is partial,@ \ - maybe some arguments are missing.@]" ] + "@[@{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 (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 @@ -11605,17 +11925,10 @@ let report_type_expected_explanation_opt 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 = - match Typedtree.nominal_exp_doc Printtyp.longident funct with - | None -> Fmt.fprintf ppf "This function" - | Some name -> - Fmt.fprintf ppf "The function %a" - (Style.as_inline_code Fmt.pp_doc) name - let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc ~extra_arg_loc ~returns_unit loc = let open Location in @@ -11635,16 +11948,20 @@ let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc 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 has type@ %a@]\ + errorf ~loc:app_loc + "@[@[<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 + ~sub:( + let semicolon = + if returns_unit then + [msg ~loc:tail_loc "@{Hint@}: Did you forget a ';'?"] + else [] + in + semicolon @ + [msg ~loc:extra_arg_loc "This extra argument is not expected."] + ) let msg = Fmt.doc_printf @@ -11654,10 +11971,10 @@ let report_error ~loc env = 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 + quoted_constr lid expected provided | Constructor_labeled_arg -> Location.errorf ~loc - "Constructors cannot have labeled arguments. \ + "Constructors cannot have labeled arguments.@ \ Consider using an inline record instead." | Partial_tuple_pattern_bad_type -> Location.errorf ~loc @@ -11673,8 +11990,7 @@ let report_error ~loc env = (* We only hint if the missing component is labeled. This is unlikely to be a correct fix for traditional tuples. *) match lbl with - | Some _ -> fprintf ppf "@ Hint: use %a to ignore some components." - Style.inline_code ".." + | Some _ -> fprintf ppf "@ Hint: use .. to ignore some components." | None -> () in Location.errorf ~loc @@ -11687,7 +12003,7 @@ let report_error ~loc env = report_unification_error ~loc env err (msg "The %s field %a@ belongs to the type" (record_form_to_string record_form) - (Style.as_inline_code longident) lid) + quoted_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 @@ -11705,21 +12021,18 @@ let report_error ~loc env = "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 - ) () + Location.aligned_error_hint ~loc + "@{Variable @}%a must occur on both sides of this %a pattern" + Style.inline_code (Ident.name id) + Style.inline_code "|" + (spellcheck_idents 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 "This expression has 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 }; @@ -11809,51 +12122,61 @@ let report_error ~loc env = (record_form_to_string record_form) print_labels labels | Label_not_mutable lid -> Location.errorf ~loc "The record field %a is not mutable" - (Style.as_inline_code longident) lid + quoted_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 - )) () + Printtyp.wrap_printing_env ~error:true env (fun () -> + let { ty; explanation } = ty_expected in + if Path.is_constructor_typath type_path then + Location.aligned_error_hint ~loc + "@{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 + (spellcheck name.txt valid_names) + else + let intro ppf = Fmt.fprintf ppf "@[%s type@;<1 2>%a%a@]@\n" + eorp (Style.as_inline_code Printtyp.type_expr) ty + pp_doc (report_type_expected_explanation_opt explanation) + in + let main = + Fmt.doc_printf "@{There is no %s @}%a within type %a" + (Datatype_kind.label_name kind) + Style.inline_code name.txt + (Style.as_inline_code Printtyp.type_path) type_path + in + let main, sub = + match spellcheck name.txt valid_names with + | None -> main, [] + | Some hint -> + let main, hint = Misc.align_error_hint ~main ~hint in + main, [Location.mknoloc hint] + in + Location.errorf ~loc ~sub "%t%a" intro pp_doc main + ) | 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 () -> - Printtyp.report_ambiguous_type_error ppf env tp tpl + let pr = match kind with + | Datatype_kind.Record | Datatype_kind.Record_unboxed_product -> + quoted_longident + | Datatype_kind.Variant -> quoted_constr + in + Location.errorf ~loc "%t" (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) + name pr lid type_name) (msg "The %s %a@ belongs to one of the following %s types:" - name (Style.as_inline_code longident) lid type_name) + name pr 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 - ) () + Location.errorf ~loc + "This expression is not an object;@ it has type %a%a" + (Style.as_inline_code Printtyp.type_expr) ty + pp_doc (report_type_expected_explanation_opt explanation) | Non_value_object (err, explanation) -> Location.error_of_printer ~loc (fun ppf () -> fprintf ppf "Object types must have layout value.@ %a%a" @@ -11870,38 +12193,44 @@ let report_error ~loc env = err) () | 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 - )) () + Printtyp.wrap_printing_env ~error:true env (fun () -> + let intro ppf = + Fmt.fprintf ppf + "@[@[This expression has type@;<1 2>%a@]@,@]" + (Style.as_inline_code Printtyp.type_expr) ty + in + let main = + Fmt.doc_printf "@{It has no method @}%a" + Style.inline_code me + in + let main, sub = + match Option.bind valid_methods (spellcheck me) with + | None -> main, [] + | Some hint -> + let main, hint = Misc.align_error_hint ~main ~hint in + main, [Location.mknoloc hint] + in + Location.errorf ~sub ~loc "%t%a" intro pp_doc main + ) | 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; - ) () + Location.aligned_error_hint ~loc + "@{This expression has no method @}%a" + Style.inline_code me + (spellcheck me valid_methods) | Virtual_class cl -> - Location.errorf ~loc "Cannot instantiate the virtual class %a" - (Style.as_inline_code longident) cl + Location.errorf ~loc "Cannot instantiate the virtual class %a" + quoted_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; - ) () + Location.aligned_error_hint ~loc + "@{Unbound instance variable @}%a" Style.inline_code var + (spellcheck var valid_vars) | Instance_variable_not_mutable v -> - Location.errorf ~loc "The instance variable %a is not mutable" - Style.inline_code 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 () -> - Printtyp.Subtype.report_error ppf env err "is not a subtype of" - ) () + Location.errorf ~loc "%t" (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" @@ -11910,23 +12239,26 @@ let report_error ~loc env = "The instance variable %a is overridden several times" Style.inline_code v | Coercion_failure (ty_exp, err, b) -> - let intro = - let ty_exp = Printtyp.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 - Location.error_of_printer ~loc (fun ppf () -> - Printtyp.report_unification_error ppf env err + 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 + Location.errorf ~loc "%t" (fun ppf -> + 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)" - ) () + (Fmt.Doc.msg "but is here used with type") + ) + ~sub:( + if not b then [] else + [ Location.msg "This simple coercion was not fully general"; + Location.msg + "@{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,@ \ @@ -11983,7 +12315,7 @@ let report_error ~loc env = (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 + quoted_longident lid (Style.as_inline_code Printtyp.type_expr) ty | Private_constructor (constr, ty) -> Location.errorf ~loc @@ -11992,7 +12324,7 @@ let report_error ~loc env = (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 + quoted_longident lid | Incoherent_label_order -> Location.errorf ~loc "This function is applied to arguments@ \ @@ -12024,7 +12356,7 @@ let report_error ~loc env = | At_toplevel -> dprintf "Existential types are not allowed in toplevel bindings" | In_group -> - dprintf "Existential types are not allowed in %a bindings" + dprintf "Existential types are not allowed in grouped (%a) bindings" Style.inline_code "let ... and ..." | In_rec -> dprintf "Existential types are not allowed in recursive bindings" @@ -12069,6 +12401,12 @@ let report_error ~loc env = 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 \ @@ -12113,25 +12451,25 @@ let report_error ~loc env = let name = Language_extension.to_string ext in Location.errorf ~loc "Extension %s must be enabled to use this feature." name - | Atomic_in_pattern lid -> - Location.errorf ~loc - "Atomic fields (here %a) are forbidden in patterns,@ \ - as it is difficult to reason about when the atomic read@ \ - will happen during pattern matching:@ the field may be read@ \ - zero, one or several times depending on the patterns around it." - (Style.as_inline_code longident) lid + | Modalities_on_atomic_field lid -> + Location.errorf ~loc + "Modalities are not allowed on fields given to %a (here, %a)" + Style.inline_code "[%atomic.loc]" + quoted_longident lid | Invalid_atomic_loc_payload -> Location.errorf ~loc "Invalid %a payload, a record field access is expected." Style.inline_code "[%atomic.loc]" | Label_not_atomic lid -> Location.errorf ~loc "The record field %a is not atomic" - (Style.as_inline_code longident) lid - | Modalities_on_atomic_field lid -> - Location.errorf ~loc - "Modalities are not allowed on fields given to %a (here, %a)" - Style.inline_code "[%atomic.loc]" - (Style.as_inline_code longident) lid + quoted_longident lid + | Atomic_in_pattern lid -> + Location.errorf ~loc + "Atomic fields (here %a) are forbidden in patterns,@ \ + as it is difficult to reason about when the atomic read@ \ + will happen during pattern matching:@ the field may be read@ \ + zero, one or several times depending on the patterns around it." + quoted_longident lid | Literal_overflow ty -> Location.errorf ~loc "Integer literal exceeds the range of representable integers of type %a" @@ -12199,6 +12537,20 @@ let report_error ~loc env = "@[<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@]" @@ -12246,6 +12598,14 @@ let report_error ~loc env = which is not a %s type." (Style.as_inline_code Printtyp.type_expr) ty (record_form_to_string record_form) + | Repeated_tuple_exp_label l -> + Location.errorf ~loc + "@[This tuple expression has two labels named %a@]" + Style.inline_code l + | Repeated_tuple_pat_label l -> + Location.errorf ~loc + "@[This tuple pattern has two labels named %a@]" + Style.inline_code l | Expr_record_type_has_wrong_boxing (P record_form, ty) -> let expected, actual = match record_form with @@ -12264,7 +12624,7 @@ let report_error ~loc env = "The index preceding this unboxed access has element type %a,@ \ which is not an unboxed record with field %a." (Style.as_inline_code Printtyp.type_expr) prev_el_type - (Style.as_inline_code longident) lid + quoted_longident lid end | Block_access_record_unboxed -> Location.error ~loc @@ -12281,7 +12641,7 @@ let report_error ~loc env = | Block_index_modality_mismatch { mut; err } -> let step, Modality.Error(ax, { left; right }) = err in let print_modality_doc id = - Printtyp.modality ~id:(fun ppf -> Format_doc.pp_print_string ppf id) ax + Printtyp.modality ~id:(fun ppf () -> Format_doc.pp_print_string ppf id) ax in let expected, actual = match step with | Left_le_right -> right, left @@ -12319,7 +12679,7 @@ let report_error ~loc env = assert (List.length sub = 0); [ Location.msg "@[Hint: All arguments of the constructor %a@\n\ must cross this axis to use it in this position.@]" - (Style.as_inline_code longident) name ] + quoted_longident name ] | Application _ | Other -> sub in Location.error_of_printer ~loc ~sub (fun ppf e -> diff --git a/upstream/ocaml_flambda/typing/typecore.mli b/upstream/ocaml_flambda/typing/typecore.mli index b431b66d8..3ea3550f4 100644 --- a/upstream/ocaml_flambda/typing/typecore.mli +++ b/upstream/ocaml_flambda/typing/typecore.mli @@ -60,17 +60,22 @@ 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_uid: Uid.t; pv_mode: Mode.Value.l; - pv_kind: value_kind; + pv_value_kind: value_kind; pv_type: type_expr; pv_loc: Location.t; - pv_as_var: bool; + pv_kind: pattern_variable_kind; pv_attributes: Typedtree.attributes; pv_sort: Jkind.Sort.t; + pv_uid: Uid.t; pv_lpoly: Types.Lpoly.t; (** Not yet determined; gets determined during generalization in [type_let]. *) @@ -169,7 +174,6 @@ val type_option_some: val type_option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression 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 @@ -203,15 +207,17 @@ type unsupported_stack_allocation = | List_comprehension | Array_comprehension +type existential_binding = + | Bind_already_bound + | Bind_not_in_scope + | Bind_non_locally_abstract + type mode_mismatch_kind = Parameter | Return type error = | Constructor_arity_mismatch of Longident.t * int * int - | Constructor_labeled_arg - | Partial_tuple_pattern_bad_type - | Extra_tuple_label of string option * type_expr - | Missing_tuple_label of string option * type_expr - | Label_mismatch of record_form_packed * Longident.t * Errortrace.unification_error + | Label_mismatch of + Data_types.record_form_packed * Longident.t * Errortrace.unification_error | Pattern_type_clash : Errortrace.unification_error * Parsetree.pattern_desc option -> error @@ -220,7 +226,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; @@ -235,7 +241,7 @@ type error = } | Apply_wrong_label of arg_label * type_expr * bool | Label_multiply_defined of string - | Label_missing of record_form_packed * Ident.t list + | Label_missing of Data_types.record_form_packed * Ident.t list | Label_not_mutable of Longident.t | Wrong_name of string * type_expected * wrong_name | Name_type_mismatch of @@ -249,7 +255,7 @@ type error = | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr - | Private_constructor of constructor_description * type_expr + | Private_constructor of Data_types.constructor_description * type_expr | Unbound_instance_variable of string * string list | Instance_variable_not_mutable of string | Not_subtype of Errortrace.Subtype.error @@ -280,20 +286,22 @@ 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 | Invalid_extension_constructor_payload | Not_an_extension_constructor + | Invalid_atomic_loc_payload + | Label_not_atomic of Longident.t + | Atomic_in_pattern of Longident.t | Probe_format | Probe_name_format of string | Probe_name_undefined of string (* CR-soon mshinwell: Use an inlined record *) | Probe_is_enabled_format | Extension_not_enabled : _ Language_extension.t -> error - | Atomic_in_pattern of Longident.t - | Invalid_atomic_loc_payload - | Label_not_atomic of Longident.t | Modalities_on_atomic_field of Longident.t | Literal_overflow of string | Unknown_literal of string * char @@ -310,11 +318,20 @@ 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 - | Wrong_expected_record_boxing of wrong_kind_context * record_form_packed * type_expr - | Expr_not_a_record_type of record_form_packed * type_expr - | Expr_record_type_has_wrong_boxing of record_form_packed * type_expr + | Expr_not_a_record_type of Data_types.record_form_packed * type_expr + | Constructor_labeled_arg + | Partial_tuple_pattern_bad_type + | Extra_tuple_label of string option * type_expr + | Missing_tuple_label of string option * type_expr + | Repeated_tuple_exp_label of string + | Repeated_tuple_pat_label of string + | Wrong_expected_record_boxing of + wrong_kind_context * Data_types.record_form_packed * type_expr + | Expr_record_type_has_wrong_boxing of + Data_types.record_form_packed * type_expr | Invalid_unboxed_access of { prev_el_type : type_expr; ua : Parsetree.unboxed_access } | Block_access_record_unboxed @@ -377,8 +394,8 @@ 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 + (Env.t -> Parsetree.module_expr -> package -> + Typedtree.module_expr * package) ref val constant: Parsetree.constant -> (Typedtree.constant, error) result diff --git a/upstream/ocaml_flambda/typing/typedecl.ml b/upstream/ocaml_flambda/typing/typedecl.ml index def4a61bb..8ced7bcca 100644 --- a/upstream/ocaml_flambda/typing/typedecl.ml +++ b/upstream/ocaml_flambda/typing/typedecl.ml @@ -20,6 +20,7 @@ open Asttypes open Parsetree open Primitive open Types +open Data_types open Typetexp module String = Misc.Stdlib.String @@ -414,6 +415,8 @@ in cannot delete it. We haven't separately implemented a fix for ocamlc looping, so we probably have the same issue described in that PR, but users haven't reported it. + rtjoa: It was re-added upsteram in + https://github.com/ocaml/ocaml/pull/13510 *) (* [update_type] performs step 3 of the process described in the comment in [enter_type]: We unify the manifest of each type with the definition of that @@ -433,30 +436,38 @@ in that... These circular types are ruled out just after [update_type] in [transl_type_decl], and then we perform the delayed checks. *) + +(* Update a temporary definition to share recursion *) let update_type temp_env env id loc = + let unify_manifest env type_manifest path type_params = + match type_manifest with + | Some ty -> + (* Since this function is called after generalizing declarations, ty is at + the generic level. Since we need to keep possible sharings in recursive + type definitions, unify without instantiating, but generalize again + after unification. *) + let delayed_jkind_checks, _ = + Ctype.with_local_level_generalize (fun () -> + try + let new_ty = Ctype.newconstr path type_params in + Ctype.unify_delaying_jkind_checks env new_ty ty, new_ty + with Ctype.Unify err -> + raise (Error(loc, Type_clash (env, err)))) + ~before_generalize:(fun (_, new_ty) -> Ctype.generalize new_ty) + in + delayed_jkind_checks + | None -> Misc.fatal_error "Typedecl.update_type" + in let path = Path.Pident id in let decl = Env.find_type path temp_env in - try - let checks = - match decl.type_manifest with - | Some ty -> - Ctype.unify_delaying_jkind_checks - env (Ctype.newconstr path decl.type_params) ty - | None -> Misc.fatal_error "Typedecl.update_type" + let checks = unify_manifest env decl.type_manifest path decl.type_params in + match decl.type_unboxed_version with + | None -> checks + | Some { type_manifest; type_params; _ } -> + let checks_from_unboxed_version = + unify_manifest env type_manifest (Path.unboxed_version path) type_params in - match decl.type_unboxed_version with - | None -> - checks - | Some { type_manifest = Some ty; type_params; _ } -> - let checks_from_unboxed_version = - Ctype.unify_delaying_jkind_checks env - (Ctype.newconstr (Path.unboxed_version path) type_params) ty - in - checks @ checks_from_unboxed_version - | Some { type_manifest = None; _ } -> - Misc.fatal_error "Typedecl.update_type" - with Ctype.Unify err -> - raise (Error(loc, Type_clash (env, err))) + checks @ checks_from_unboxed_version (* Determine if a type's values are represented by floats at run-time. *) (* CR layouts v2.5: Should we check for unboxed float here? Is a record with all @@ -582,7 +593,7 @@ let transl_labels (type rep) ~(record_form : rep record_form) ~new_var_jkind let cty = transl_simple_type ~new_var_jkind env ?univars ~closed Mode.Alloc.Const.legacy 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_modalities = modalities; ld_type = cty; ld_loc = loc; ld_attributes = attrs} @@ -672,13 +683,9 @@ let make_constructor then widen so as to not introduce any new constraints *) (* narrow and widen are now invoked through with_local_scope *) TyVarEnv.with_local_scope begin fun () -> - let closed = - match svars with - | [] -> false - | _ -> true - in + let closed = svars <> [] in let targs, tret_type, args, ret_type, _univars = - Ctype.with_local_level_if closed begin fun () -> + Ctype.with_local_level_generalize_if closed begin fun () -> TyVarEnv.reset (); let univar_list = TyVarEnv.make_poly_univars_jkinds env @@ -713,7 +720,7 @@ let make_constructor end; (targs, tret_type, args, ret_type, univar_list) end - ~post: begin fun (_, _, args, ret_type, univars) -> + ~before_generalize: 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 @@ -737,7 +744,7 @@ let verify_unboxed_attr unboxed_attr sdecl = | [] -> bad "it has no fields" | _::_::_ -> bad "it has more than one field" | [{pld_mutable = Mutable}] -> bad "it is mutable" - | [{pld_mutable = Immutable}] -> () + | [{pld_mutable = Immutable; _}] -> () end | Ptype_record_unboxed_product _ -> bad "[@@unboxed] may not be used on unboxed records" @@ -937,15 +944,14 @@ let transl_declaration env sdecl (id, uid) = verify_unboxed_attr unboxed_attr sdecl; let transl_type sty = let cty = - Ctype.with_local_level begin fun () -> + (* generalize_structure is necessary so that copying during instantiation + traverses inside of any type constructors in the [with]-bound. It's + also necessary because the variables here are at generic level, and so + any containers of them should be, too! *) + Ctype.with_local_level_generalize_structure begin fun () -> Typetexp.transl_simple_type env ~new_var_jkind:Any ~closed:true Mode.Alloc.Const.legacy sty end - (* This call to [generalize_structure] is necessary so that copying - during instantiation traverses inside of any type constructors in the - [with]-bound. It's also necessary because the variables here are at - generic level, and so any containers of them should be, too! *) - ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) in cty.ctyp_type (* CR layouts v2.8: Do this more efficiently. Or probably add with-kinds to Typedtree. Internal ticekt 4435. *) @@ -1043,8 +1049,8 @@ 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_current_unit ()); cd_vars = tvars; - cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); cd_args = targs; cd_res = tret_type; cd_loc = scstr.pcd_loc; @@ -1963,20 +1969,6 @@ let update_constructor_representation raise (Error (loc, Illegal_mixed_product Extension_constructor)); Constructor_mixed shape - -let add_types_to_env ~shapes decls env = - match shapes with - | None -> - List.fold_right - (fun (id, decl) env -> - add_type ~check:true id decl env) - decls env - | Some shapes -> - List.fold_right2 - (fun (id, decl) shape env -> - add_type ~check:true ~shape id decl env) - decls shapes env - (* This function updates jkind stored in kinds with more accurate jkinds. It is called after the circularity checks and the delayed jkind checks have happened, so we can fully compute jkinds of types. @@ -3014,17 +3006,17 @@ 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'; type_ikind = Types.ikinds_todo (Format_doc.asprintf "name_recursion path=%a" Path.print (Path.Pident id)) } -else decl + else decl | _ -> decl let name_recursion_decls sdecls decls = @@ -3045,7 +3037,6 @@ let check_redefined_unit (td: Parsetree.type_declaration) = | _ -> () - (* Note [Quality of jkinds during inference] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3171,6 +3162,19 @@ let normalize_decl_jkinds env decls = env decls +let add_types_to_env ~shapes decls env = + match shapes with + | None -> + List.fold_right + (fun (id, decl) env -> + add_type ~check:true id decl env) + decls env + | Some shapes -> + 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; @@ -3197,21 +3201,24 @@ 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, new_env, delayed_jkind_checks = - Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> + let tdecls, decls, temp_env, new_env = + Ctype.with_local_level_generalize + ~before_generalize:(fun (_, decls, _, _) -> + List.iter (fun (_, decl) -> generalize_decl decl) decls) + 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 + Warnings.(is_active (Unused_type_declaration ("", Declaration))) in let ids_slots (id, _uid as ids) = match rec_flag with | Asttypes.Recursive when warn_unused -> @@ -3255,18 +3262,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 ~shapes:None decls env in - (* Update stubs *) - let delayed_jkind_checks = - match rec_flag with - | Asttypes.Nonrecursive -> [] - | Asttypes.Recursive -> - List.map2 - (fun (id, _) sdecl -> - update_type temp_env new_env id sdecl.ptype_loc, - sdecl.ptype_loc) - ids_list sdecl_list - in - ((tdecls, decls, new_env, delayed_jkind_checks), List.map snd decls) + (tdecls, decls, temp_env, new_env) end in (* Check for ill-formed abbrevs *) @@ -3308,6 +3304,17 @@ let transl_type_decl env rec_flag sdecl_list = (Path.Pident id) decl to_check) decls; + (* Update temporary definitions (for well-founded recursive types) *) + let delayed_jkind_checks = + match rec_flag with + | Asttypes.Nonrecursive -> [] + | Asttypes.Recursive -> + List.map2 + (fun (id, _) sdecl -> + update_type temp_env new_env id sdecl.ptype_loc, + sdecl.ptype_loc) + ids_list sdecl_list + in (* Now that we've ruled out ill-formed types, we can perform the delayed jkind checks *) List.iter (fun (checks,loc) -> @@ -3460,8 +3467,8 @@ let transl_extension_constructor ~scope env type_path type_params (* Remove "_" names from parameters used in the constructor *) if not cdescr.cstr_generalized then begin let vars = - Ctype.free_variables - (Btype.newgenty (Ttuple (List.map (fun {Types.ca_type=t; _} -> None, t) args))) + Ctype.free_variables_list + (List.map (fun {Types.ca_type=t; _} -> t) args) in List.iter (fun ty -> @@ -3482,12 +3489,13 @@ let transl_extension_constructor ~scope env type_path type_params | Ok _ -> () | Error e -> raise (Error (lid.loc, Constructor_submode_failed e))); (* 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_res_type_path = Data_types.cstr_res_type_path cdescr in + let cstr_res_type_params = + (Env.find_type cstr_res_type_path env).type_params in let cstr_types = (Btype.newgenty - (Tconstr(cstr_type_path, cstr_type_params, ref Mnil))) - :: cstr_type_params + (Tconstr(cstr_res_type_path, cstr_res_type_params, ref Mnil))) + :: cstr_res_type_params in let ext_types = (Btype.newgenty @@ -3496,7 +3504,7 @@ let transl_extension_constructor ~scope env type_path 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))); + Rebind_mismatch(lid.txt, cstr_res_type_path, type_path))); (* Disallow rebinding private constructors to non-private *) begin match cdescr.cstr_private, priv with @@ -3543,7 +3551,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 = @@ -3617,7 +3625,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 type_path styext.ptyext_params in let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in @@ -3631,7 +3639,7 @@ let transl_type_extension extend env loc styext = in (ttype_params, type_params, constructors) end - ~post: begin fun (_, type_params, constructors) -> + ~before_generalize: begin fun (_, type_params, constructors) -> (* Generalize types *) List.iter Ctype.generalize type_params; List.iter @@ -3689,12 +3697,12 @@ 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) -> + ~before_generalize: 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 @@ -4254,7 +4262,7 @@ let transl_value_decl env loc ~modal ~why valdecl = Types.val_loc = loc; val_attributes = valdecl.pval_attributes; val_modalities; val_zero_alloc = zero_alloc; - 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)) @@ -4299,7 +4307,7 @@ let transl_value_decl env loc ~modal ~why valdecl = Types.val_loc = loc; val_attributes = valdecl.pval_attributes; val_modalities; val_zero_alloc = Zero_alloc.default; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in let (id, newenv) = @@ -4339,7 +4347,7 @@ let transl_value_decl env ~modal ~why 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]. *) @@ -4404,7 +4412,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env if arity_ok && not sig_decl_abstract && sdecl.ptype_private = Private then Location.deprecated loc "spurious use of private"; - let type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let type_unboxed_version = match get_desc man with | Tconstr (path, args, _) -> @@ -4476,7 +4484,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env type_loc = loc; type_attributes = sdecl.ptype_attributes; type_unboxed_default; - type_uid; + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); type_unboxed_version; } in @@ -4559,7 +4567,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env typ_jkind_annotation = Jkind.get_annotation type_jkind; } end - ~post:(fun ttyp -> generalize_decl ttyp.typ_type) + ~before_generalize:(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., @@ -4582,7 +4590,7 @@ let transl_package_constraint ~loc ty = type_loc = loc; type_attributes = []; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); type_unboxed_version = None; } @@ -4590,7 +4598,7 @@ let transl_package_constraint ~loc ty = let abstract_type_decl ~injective ~jkind ~params = let arity = List.length params in - Ctype.with_local_level ~post:generalize_decl begin fun () -> + Ctype.with_local_level_generalize ~before_generalize:generalize_decl begin fun () -> let params = List.map Ctype.newvar params in { type_params = params; type_arity = arity; @@ -4685,7 +4693,7 @@ let transl_jkind_decl env { pjkind_name; pjkind_manifest; pjkind_attributes; pjkind_loc=loc } = let scope = Ctype.create_scope () in let id = Ident.create_scoped ~scope pjkind_name.txt in - let uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let context = Jkind.History.Jkind_declaration (Pident id) in let jkind_manifest = Option.map (fun annot -> Jkind.Const.of_annotation env ~context annot) @@ -4721,7 +4729,7 @@ let transl_jkind_constraint id env orig_decl new_decl = considerations that require us to re-check the declaration in the inner environment (e.g., [constraint]s) do not occur for lr-jkinds. *) Env.mark_jkind_used orig_decl.jkind_uid; - let jkind_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let jkind_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let context = Jkind.History.Jkind_declaration (Pident id) in let jka = match new_decl.pjkind_manifest with @@ -4749,23 +4757,24 @@ let transl_jkind_constraint id env orig_decl new_decl = 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 = @@ -4783,7 +4792,8 @@ let explain_unbound_single ppf tv ty = (fun (_l,f) -> match row_field_repr f with Rpresent (Some t) -> t | Reither (_,[t],_) -> t - | Reither (_,tl,_) -> Btype.newgenty (Ttuple (List.map (fun e -> None, e) tl)) + | Reither (_,tl,_) -> + Btype.newgenty (Ttuple (List.map (fun e -> None, e) tl)) | _ -> Btype.newgenty (Ttuple[])) "case" (fun (lab,_) -> "`" ^ lab ^ " of ") | _ -> trivial ty @@ -4805,7 +4815,7 @@ module Reaching_path = struct Fmt.(pp_print_list ~pp_sep:comma) pp_step ppf reaching_path let pp_colon ~pp_root ~pp_body ppf path = - Fmt.fprintf ppf ":@;<1 2>@[%a@]" (pp ~pp_root ~pp_body) path + Fmt.fprintf ppf ":@\n @[%a@]" (pp ~pp_root ~pp_body) path (* Type-specific operations *) @@ -4822,7 +4832,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 @@ -4831,13 +4841,13 @@ 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 let pp_type_colon = pp_colon - ~pp_root:Printtyp.prepared_type_expr - ~pp_body:Printtyp.prepared_type_expr + ~pp_root:Out_type.prepared_type_expr + ~pp_body:Out_type.prepared_type_expr (* Kind-specific operations *) @@ -4887,287 +4897,337 @@ let report_jkind_mismatch_due_to_bad_inference ppf env ty violation loc = ~offender:(fun ppf -> Printtyp.type_expr ppf ty) env) violation -let quoted_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty -let report_error_doc 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 quoted_constr = Style.as_inline_code Pprintast.Doc.constr + +let explain_unbounded ty decl ppf = + 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 (List.map (fun t -> None, t) 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_record_unboxed_product (tl, _, _), _ -> + explain_unbound ppf ty tl (fun l -> l.Types.ld_type) + "unboxed record field" (fun l -> Ident.name l.Types.ld_id ^ ": ") + | Type_abstract _, Some ty' -> + explain_unbound_single ppf ty ty' + | _ -> () + +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 + +let variance_context = + let open Typedecl_variance in + function + | Type_declaration { id ; decl ; unboxed_version } -> + let pre, post = + if unboxed_version then + (* Unexpected; errors in the unboxed version should have also + been present and reported first for the boxed version. *) + "In the unboxed version of the definition", + "@ Please report this error to the Jane Street compilers team." + else + "In the definition", "" + in + Out_type.add_type_declaration_to_preparation id decl; + Format_doc.doc_printf "%s@\n @[%a@]@\n%s" + pre + (Style.as_inline_code @@ Out_type.prepared_type_declaration id) + decl + post + | Gadt_constructor c -> + Out_type.add_constructor_to_preparation c; + doc_printf "In the GADT constructor@\n @[%a@]@\n" + (Style.as_inline_code Out_type.prepared_constructor) + c + | Extension_constructor (id, e) -> + Out_type.add_extension_constructor_to_preparation e; + doc_printf "In the extension constructor@\n @[%a@]@\n" + (Out_type.prepared_extension_constructor id) + e + +let variance_variable_error ~v1 ~v2 variable error ppf = + let open Typedecl_variance in + match error with + | Variance_not_reflected -> + fprintf ppf + "the type variable@ %a@ has a variance that@ \ + is not reflected by its occurrence in type parameters.@ \ + It was expected to be %s,@ but it is %s." + (Style.as_inline_code Out_type.prepared_type_expr) variable + (variance v2) (variance v1) + | No_variable -> + fprintf ppf + "the type variable@ %a@ cannot be deduced@ \ + from the type parameters." + (Style.as_inline_code Out_type.prepared_type_expr) variable + | Variance_not_deducible -> + fprintf ppf + "the type variable@ %a@ has a variance that@ \ + cannot be deduced from the type parameters.@ \ + It was expected to be %s,@ but it is %s." + (Style.as_inline_code Out_type.prepared_type_expr) variable + (variance v2) (variance v1) + +let variance_error ~loc ~v1 ~v2 = + let open Typedecl_variance in + function + | Variance_variable_error { error; variable; context } -> + (* CR dkalinichenko: OxCaml changes the [Ident_names] map from + stateless to stateful. Normally, it would be reset by + [Printtyp.wrap_printing_env], but [Variance_variable_error] + lacks the [env]. Therefore, we clear [Ident_names] manually. + It'd be good to come up with a better solution. *) + Out_type.Ident_names.reset (); + Out_type.prepare_for_printing [ variable ]; + let intro = variance_context context in + Location.errorf ~loc "%a%t" pp_doc intro + (variance_variable_error ~v1 ~v2 variable error) + | Variance_not_satisfied n -> + Location.errorf ~loc + "In this definition, expected parameter@ \ + variances are not satisfied.@ \ + The %d%s type parameter was expected to be %s,@ but it is %s." + n (Misc.ordinal_suffix n) + (variance v2) (variance v1) + +let report_error ~loc = function | Repeated_parameter -> - fprintf ppf "A type parameter occurs several times" + Location.errorf ~loc "A type parameter occurs several times" | Duplicate_constructor s -> - fprintf ppf "Two constructors are named %a" Style.inline_code s + Location.errorf ~loc "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" + Location.errorf ~loc + "Too many non-constant constructors@ \ + -- maximum is %i non-constant constructors@]" + (Config.max_tag + 1) | Duplicate_label s -> - fprintf ppf "Two labels are named %a" Style.inline_code s + Location.errorf "Two labels are named %a" Style.inline_code s | Unboxed_mutable_label -> - fprintf ppf "Unboxed record labels cannot be mutable" + Location.errorf ~loc "Unboxed record labels cannot be mutable" | 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@]" + Location.errorf ~loc "The type abbreviation %a is cyclic%a" Style.inline_code s Reaching_path.pp_type_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 () -> - Printtyp.reset (); + Out_type.reset (); Reaching_path.add_to_preparation reaching_path; - fprintf ppf "@[The definition of %a contains a cycle%a@]" + Location.errorf ~loc "The definition of %a contains a cycle%a" Style.inline_code s Reaching_path.pp_type_colon reaching_path | Unboxed_recursion (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 is recursive without boxing%a@]" + Location.errorf ~loc + "@[The definition of %a is recursive without boxing%a@]" Style.inline_code s Reaching_path.pp_type_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" - (Style.as_inline_code Printtyp.type_expr) 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 - (Includecore.report_type_mismatch - "the original" "this" "definition" env) + | Definition_mismatch (ty, env, err) -> + let err ppf = match err with + | None -> () + | Some err -> + Format_doc.fprintf ppf "@\n@[%a@]" + (Includecore.report_type_mismatch "the original" "this" "definition" + env) err + in + Location.errorf ~loc + "@[This variant or record definition@ \ + does not match that of type@;<1 2>%a@]%t" + quoted_type ty err | Constraint_failed (env, err) -> let get_jkind_error : _ Errortrace.elt -> _ = function | Bad_jkind (ty, violation) | Bad_jkind_sort (ty, violation) -> Some (ty, violation) | Unequal_var_jkinds _ | Unequal_tof_kind_jkinds _ | Diff _ | Variant _ - | Obj _ | Escape _ | Incompatible_fields _ | Rec_occur _ -> None + | Obj _ | Escape _ | Incompatible_fields _ | Rec_occur _ + | Function_label_mismatch _ | Tuple_label_mismatch _ + | First_class_module _ -> None in begin match List.find_map get_jkind_error err.trace with | Some (ty, violation) -> - report_jkind_mismatch_due_to_bad_inference ppf env ty violation - Check_constraints + Location.errorf ~loc "%t" (fun ppf -> + report_jkind_mismatch_due_to_bad_inference ppf env ty violation + Check_constraints) | None -> - let msg = Format_doc.Doc.msg in - fprintf ppf "@[Constraints are not satisfied in this type.@ "; - Printtyp.report_unification_error ppf env err - (msg "Type") - (msg "should be an instance of"); - fprintf ppf "@]" + Location.errorf ~loc "Constraints are not satisfied in this type.@\n%t" + (fun ppf -> + Errortrace_report.unification ppf env err + (Doc.msg "Type") + (Doc.msg "should be an instance of") + ) end - | Jkind_mismatch_due_to_bad_inference (env, ty, violation, loc) -> - report_jkind_mismatch_due_to_bad_inference ppf env ty violation loc + | Jkind_mismatch_due_to_bad_inference (env, ty, violation, jkind_loc) -> + Location.errorf ~loc "%t" + (fun ppf -> + report_jkind_mismatch_due_to_bad_inference ppf env ty violation + jkind_loc) | Non_regular { definition; used_as; defined_as; reaching_path } -> let reaching_path = Reaching_path.simplify reaching_path 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; - Printtyp.Naming_context.reset (); - 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\ + Out_type.Ident_names.reset (); + Location.errorf ~loc + "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_type (Printtyp.tree_of_typexp Type defined_as) - quoted_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 - fprintf pp "@ after the following expansion(s)%a@ " + fprintf pp "@ after the following expansion(s)%a" Reaching_path.pp_type_colon reaching_path - else fprintf pp ".@ ") + 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 - (msg "Type") - (msg "is not compatible with type"); - fprintf ppf "@]" + Location.errorf ~loc "The type constraints are not consistent.@\n%t" + (fun ppf -> Errortrace_report.unification ppf env err + (Doc.msg "Type") + (Doc.msg "is not compatible with type") + ) | Type_clash (env, err) -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf env err + Location.errorf ~loc "%t" @@ fun ppf -> + 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" + Location.errorf ~loc "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@]" + Location.errorf ~loc + "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 (List.map (fun t -> None, t) 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_record_unboxed_product (tl, _, _), _ -> - explain_unbound ppf ty tl (fun l -> l.Types.ld_type) - "unboxed record field" (fun l -> Ident.name l.Types.ld_id ^ ": ") - | Type_abstract _, Some ty' -> - explain_unbound_single ppf ty ty' - | _ -> () - end; - fprintf ppf "@]" + Location.errorf ~loc + "A type variable is unbound in this type declaration%t" + (explain_unbounded ty decl) | 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 "@]" + let explain ppf = + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") + in + Location.errorf ~loc + "A type variable is unbound in this extension constructor%t" + explain | Cannot_extend_private_type path -> - fprintf ppf "@[%s@ %a@]" - "Cannot extend private type definition" + Location.errorf ~loc + "Cannot extend private type definition@ %a" Printtyp.path path | Not_extensible_type path -> - fprintf ppf "@[%s@ %a@ %s@]" - "Type definition" + Location.errorf ~loc + "Type definition@ %a@ is not extensible@]" (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" + Location.errorf ~loc + "@[This extension@ does not match the definition of type\ + @;<1 2>%a@]@\n@[%a@]" 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 - Printtyp.report_unification_error ppf env err - (msg "The constructor %a@ has type" - (Style.as_inline_code Printtyp.longident) lid) - (msg "but was expected to be of type") + Location.errorf ~loc "%t" @@ fun ppf -> + Errortrace_report.unification ppf env err + (doc_printf "The constructor %a@ has type" + quoted_constr lid) + (Doc.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') + Location.errorf ~loc + "The constructor@ %a@ extends type@ %a@ \ + whose declaration does not match@ the declaration of type@ %a" + quoted_constr lid + Style.inline_code (Path.name p) + 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" + Location.errorf ~loc "The constructor@ %a@ is private" + quoted_constr lid | 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 } -> - Printtyp.prepare_for_printing [ variable ]; - Printtyp.Naming_context.reset (); - begin match context with - | Type_declaration { id ; decl ; unboxed_version } -> - let pre, post = - if unboxed_version then - (* Unexpected; errors in the unboxed version should have also - been present and reported first for the boxed version. *) - "In the unboxed version of the definition", - "@ Please report this error to the Jane Street compilers team." - else - "In the definition", "" - in - Printtyp.add_type_declaration_to_preparation id decl; - fprintf ppf "@[%s@;<1 2>%a@;%s" - pre - (Style.as_inline_code @@ Printtyp.prepared_type_declaration id) - decl - post - | Gadt_constructor c -> - Printtyp.add_constructor_to_preparation c; - fprintf ppf "@[%s@;<1 2>%a@;" - "In the GADT constructor" - (Style.as_inline_code Printtyp.prepared_constructor) - c - | Extension_constructor (id, e) -> - Printtyp.add_extension_constructor_to_preparation e; - fprintf ppf "@[%s@;<1 2>%a@;" - "In the extension constructor" - (Printtyp.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 - "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 - "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 - "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)) + variance_error ~loc ~v1 ~v2 n | Unavailable_type_constructor p -> - fprintf ppf "The definition of type %a@ is unavailable" + Location.errorf ~loc "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" + | Variance (Typedecl_variance.Varying_anonymous (n, reason)) -> + let reason_text = + match reason with + | Variable_constrained ty -> + dprintf + ", because the type variable %a appears@ in other parameters.@ \ + In GADTS, covariant or contravariant type parameters@ \ + must not depend@ on other parameters." + (Style.as_inline_code Printtyp.type_expr) ty + | Variable_instantiated ty -> + dprintf + ", because it is instantiated to the type %a.@ \ + Covariant or contravariant type parameters@ \ + may only appear@ as type variables@ \ + in GADT constructor definitions." + (Style.as_inline_code Printtyp.type_expr) ty + in + Location.errorf ~loc + "In this GADT constructor definition,@ \ + the variance of the@ %d%s parameter@ \ + cannot be checked%t" + n (Misc.ordinal_suffix n) + reason_text | Val_in_structure -> - fprintf ppf "Value declarations are only allowed in signatures" + Location.errorf ~loc "Value declarations are only allowed in signatures" | Multiple_native_repr_attributes -> - fprintf ppf "Too many %a/%a/%a attributes" + Location.errorf ~loc "Too many %a/%a/%a attributes" Style.inline_code "[@@unboxed]" Style.inline_code "[@@untagged]" Style.inline_code "[@@unpacked]" | Cannot_unbox_or_untag_type Unboxed -> - fprintf ppf "@[Don't know how to unbox this type.@ \ - Only %a, %a, %a, %a, vector primitives, and@ \ - the corresponding unboxed types can be marked unboxed.@]" + Location.errorf ~loc + "Don't know how to unbox this type.@ \ + Only %a, %a, %a, %a, vector primitives, and@ \ + the corresponding unboxed types can be marked 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, %a, %a, \ - and@ other immediate types can be untagged.@]" + Location.errorf ~loc + "Don't know how to untag this type. Only %a, %a, %a, \ + and@ other immediate types can be untagged." Style.inline_code "int8" Style.inline_code "int16" Style.inline_code "int" | Cannot_unbox_or_untag_type Unpacked -> - fprintf ppf "@[Don't know how to unpack this type.@ \ - Only types with product layouts can be marked %a.@]" + Location.errorf ~loc + "Don't know how to unpack this type.@ \ + Only types with product layouts can be marked %a." Style.inline_code "unpacked" | Deep_unbox_or_untag_attribute kind -> - fprintf ppf - "@[The attribute %a should be attached to@ \ + Location.errorf ~loc + "The attribute %a should be attached to@ \ a direct argument or result of the primitive,@ \ - it should not occur deeply into its type.@]" + it should not occur deeply into its type." Style.inline_code (match kind with | Unboxed -> "@unboxed" @@ -5183,13 +5243,15 @@ let report_error_doc ppf = function in fprintf ppf "type %a" Style.inline_code path_end in - Jkind.Violation.report_with_offender ~offender - env ppf v + Location.errorf ~loc "%t" (fun ppf -> + Jkind.Violation.report_with_offender ~offender + env ppf v) | Jkind_mismatch_of_type (env, ty, v) -> let offender ppf = fprintf ppf "type %a" (Style.as_inline_code Printtyp.type_expr) ty in - Jkind.Violation.report_with_offender ~offender - env ppf v + Location.errorf ~loc "%t" (fun ppf -> + Jkind.Violation.report_with_offender ~offender + env ppf v) | Jkind_sort {env; kloc; typ; err} -> let s = match kloc with @@ -5212,17 +5274,17 @@ let report_error_doc ppf = function made representable by %a)" Style.inline_code "[@layout_poly]" in - fprintf ppf "@[%s must have a representable layout%t.@ %a@]" s + Location.errorf ~loc "%s must have a representable layout%t.@ %a" s extra (Jkind.Violation.report_with_offender ~offender:(fun ppf -> Printtyp.type_expr ppf typ) env) err | Jkind_empty_record -> - fprintf ppf "@[Records must contain at least one runtime value.@]" + Location.errorf ~loc "Records must contain at least one runtime value." | Non_representable_in_module (env, err, ty) -> let offender ppf = fprintf ppf "type %a" Printtyp.type_expr ty in - fprintf ppf "@[The type of a module-level value must have a@ \ - representable layout.@ %a@]" + Location.errorf ~loc "The type of a module-level value must have a@ \ + representable layout.@ %a" (Jkind.Violation.report_with_offender ~offender env) err @@ -5239,49 +5301,50 @@ let report_error_doc ppf = function | Cstr_tuple { unboxed = true } -> "Unboxed variants" | External | External_with_layout_poly -> assert false in - fprintf ppf - "@[Type %a has layout %a.@ %s may not yet contain types of this layout.@]" + Location.errorf ~loc + "Type %a has layout %a.@ %s may not yet contain types of this layout." (Style.as_inline_code Printtyp.type_expr) typ (Style.as_inline_code Jkind.Sort.Const.format) sort_const struct_desc | Illegal_mixed_product error -> begin match error with | Runtime_support_not_enabled mixed_product_kind -> - fprintf ppf - "@[This OCaml runtime doesn't support mixed %s.@]" + Location.errorf ~loc + "This OCaml runtime doesn't support mixed %s." (Mixed_product_kind.to_plural_string mixed_product_kind) | Extension_constructor -> - fprintf ppf - "@[Extensible types can't have fields of unboxed type.@ Consider \ - wrapping the unboxed fields in a record.@]" + Location.errorf ~loc + "Extensible types can't have fields of unboxed type.@ Consider \ + wrapping the unboxed fields in a record." | Value_prefix_too_long { value_prefix_len; max_value_prefix_len; mixed_product_kind } -> - fprintf ppf - "@[Mixed %s may contain at most %d value fields prior to the\ - \ flat suffix, but this one contains %d.@]" + Location.errorf ~loc + "Mixed %s may contain at most %d value fields prior to the\ + \ flat suffix, but this one contains %d." (Mixed_product_kind.to_plural_string mixed_product_kind) max_value_prefix_len value_prefix_len | Insufficient_level { required_layouts_level; mixed_product_kind } -> ( - let hint ppf = - fprintf ppf "You must enable -extension %s to use this feature." - (Language_extension.to_command_line_string Layouts - required_layouts_level) + let hint = + [Location.msg + "You must enable -extension %s to use this feature." + (Language_extension.to_command_line_string Layouts + required_layouts_level)] in match Language_extension.is_enabled Layouts with | false -> - fprintf ppf - "@[The appropriate layouts extension is not enabled.@;%t@]" hint + Location.errorf ~loc + "@[The appropriate layouts extension is not enabled.@]" + ~sub:hint | true -> - fprintf ppf - "@[The enabled layouts extension does not allow for mixed %s.@;\ - %t@]" + Location.errorf ~loc + "@[The enabled layouts extension does not allow for mixed %s.@]" (Mixed_product_kind.to_plural_string mixed_product_kind) - hint) + ~sub:hint) end | Bad_unboxed_attribute msg -> - fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg + Location.errorf ~loc "This type cannot be unboxed because@ %s." msg | Poly_not_yet_implemented -> - fprintf ppf "@[The %a annotation is not yet implemented.@]" + Location.errorf ~loc "The %a annotation is not yet implemented." Style.inline_code "val poly_" | Separability (Typedecl_separability.Non_separable_evar evar) -> let pp_evar ppf = function @@ -5290,122 +5353,125 @@ let report_error_doc ppf = function | 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.@]" + Location.errorf ~loc + "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.@]" + Location.errorf ~loc + "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.@]" + Location.errorf ~loc + "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@]" + let sub = [ + Location.msg + "@[@[@{Hint@}: If you intended to define a private \ + type abbreviation,@ \ + write explicitly@]@;<1 2>%a@]" + (Style.as_inline_code pp_private) ty + ] + in + Location.errorf ~sub ~loc + "This private row type declaration is invalid.@\n\ + @[The type expression on the right-hand side reduces to@;<1 2>%a@ \ + which does not have a free row type variable.@]" (Style.as_inline_code Printtyp.type_expr) ty - (Style.as_inline_code pp_private) ty | Local_not_enabled -> - fprintf ppf "@[The local extension is disabled@ \ - To enable it, pass the '-extension local' flag@]" + Location.errorf ~loc + "The local extension is disabled@ \ + To enable it, pass the '-extension local' flag" | Unexpected_layout_any_in_primitive name -> - fprintf ppf - "@[The primitive %a doesn't work well with type variables of@ \ - layout any. Consider using %a.@]" + Location.errorf ~loc + "The primitive %a doesn't work well with type variables of@ \ + layout any. Consider using %a." Style.inline_code name Style.inline_code "[@layout_poly]" | Useless_layout_poly -> - fprintf ppf - "@[%a on this external declaration has no@ \ - effect. Consider removing it or adding a type@ \ - variable for it to operate on.@]" + Location.errorf ~loc + "%a on this external declaration has no@ \ + effect. Consider removing it or adding a type@ \ + variable for it to operate on." Style.inline_code "[@layout_poly]" | Bad_or_null_attribute msg -> - fprintf ppf "@[Invalid [@@or_null] declaration:@ %s.@]" msg + Location.errorf ~loc "Invalid [@@or_null] declaration:@ %s." msg | Zero_alloc_attr_unsupported ca -> let variety = match ca with | Default_zero_alloc | Check _ -> assert false | Assume _ -> "assume" | Ignore_assert_all -> "ignore" in - fprintf ppf - "@[zero_alloc %a attributes are not supported in signatures@]" + Location.errorf ~loc + "zero_alloc %a attributes are not supported in signatures" Style.inline_code variety | Zero_alloc_attr_non_function -> - fprintf ppf - "@[In signatures, zero_alloc is only supported on function declarations.\ - @ Found no arrows in this declaration's type.\ - @ Hint: You can write %a to specify the arity\ - @ of an alias (for n > 0).@]" + Location.errorf ~loc + "In signatures, zero_alloc is only supported on function declarations.\ + @ Found no arrows in this declaration's type.\ + @ Hint: You can write %a to specify the arity\ + @ of an alias (for n > 0).@]" Style.inline_code "[@zero_alloc arity n]" | Zero_alloc_attr_bad_user_arity -> - fprintf ppf - "@[Invalid zero_alloc attribute: arity must be greater than 0.@]" + Location.errorf ~loc + "Invalid zero_alloc attribute: arity must be greater than 0." | Invalid_reexport {definition; expected} -> - fprintf ppf - "@[Invalid reexport declaration.\ - @ Type %s must be defined equal to the primitive type %a.@]" + Location.errorf ~loc + "Invalid reexport declaration.\ + @ Type %s must be defined equal to the primitive type %a." (Path.name definition) Printtyp.path expected | Non_abstract_reexport definition -> - fprintf ppf - "@[Invalid reexport declaration.\ - @ Type %s must not define an explicit representation.@]" + Location.errorf ~loc + "Invalid reexport declaration.\ + @ Type %s must not define an explicit representation." (Path.name definition) | Unsafe_mode_crossing_on_invalid_type_kind -> - fprintf ppf - "@[[%@%@unsafe_allow_any_mode_crossing] is not allowed on this kind of \ + Location.errorf ~loc + "[%@%@unsafe_allow_any_mode_crossing] is not allowed on this kind of \ type declaration.@ Only records, unboxed products, and variants are \ - supported.@]" + supported." | Illegal_baggage (env, jkind) -> - fprintf ppf - "@[Illegal %a in kind annotation of an abbreviation:@ %a@]" + Location.errorf ~loc + "Illegal %a in kind annotation of an abbreviation:@ %a" Style.inline_code "with" (Jkind.format env) jkind | No_unboxed_version p -> - fprintf ppf "@[The type %a@ has no unboxed version.@]" + Location.errorf ~loc "The type %a@ has no unboxed version." (Style.as_inline_code Printtyp.path) p | Atomic_field_must_be_mutable name -> - fprintf ppf - "@[The label %a must be mutable to be declared atomic.@]" + Location.errorf ~loc + "The label %a must be mutable to be declared atomic." Style.inline_code name | Constructor_submode_failed e -> let Mode.Value.Error (ax, {left; right}) = Mode.Value.to_simple_error e in - fprintf ppf "@[This constructor is at mode %a, \ + Location.errorf ~loc "This constructor is at mode %a, \ but expected to be at mode %a.@]" (Style.as_inline_code (Mode.Value.Const.print_axis ax)) left - (Style.as_inline_code (Mode.Value.Const.print_axis ax)) right; - fprintf ppf "@[@[@{Hint@}: all argument types must \ - mode-cross for rebinding to succeed.@]" + (Style.as_inline_code (Mode.Value.Const.print_axis ax)) right + ~sub:[Location.msg "@[@[@{Hint@}: all argument types must \ + mode-cross for rebinding to succeed."] | Atomic_field_in_mixed_block -> - fprintf ppf - "@[Atomic record fields are not permitted in mixed blocks.@]" + Location.errorf ~loc + "Atomic record fields are not permitted in mixed blocks." | Non_value_atomic_field -> - fprintf ppf - "@[Atomic record fields must have layout value.@]" + Location.errorf ~loc + "Atomic record fields must have layout value." | Layout_poly_unsupported -> - fprintf ppf - "@[Layout polymorphism is unsupported in this context.@]" + Location.errorf ~loc + "Layout polymorphism is unsupported in this context." | Recursive_jkind_definition (path, env, reaching_path) -> Printtyp.wrap_printing_env ~error:true env @@ fun () -> - fprintf ppf "@[The kind %a is cyclic%a@]" + Location.errorf ~loc "@[The kind %a is cyclic%a@]" (Style.as_inline_code Printtyp.path) path Reaching_path.pp_kind_colon reaching_path - let () = Location.register_error_of_exn (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error_doc err) + | Error (loc, err) -> Some (report_error ~loc err) | _ -> None ) - -let report_error = Format_doc.compat report_error_doc diff --git a/upstream/ocaml_flambda/typing/typedecl.mli b/upstream/ocaml_flambda/typing/typedecl.mli index ed4fcee06..c997dfa82 100644 --- a/upstream/ocaml_flambda/typing/typedecl.mli +++ b/upstream/ocaml_flambda/typing/typedecl.mli @@ -226,5 +226,4 @@ type error = exception Error of Location.t * error -val report_error: error Format_doc.format_printer -val report_error_doc: error Format_doc.printer +val report_error: loc:Location.t -> error -> Location.report diff --git a/upstream/ocaml_flambda/typing/typedecl_separability.ml b/upstream/ocaml_flambda/typing/typedecl_separability.ml index aa30c375b..81490fa90 100644 --- a/upstream/ocaml_flambda/typing/typedecl_separability.ml +++ b/upstream/ocaml_flambda/typing/typedecl_separability.ml @@ -130,7 +130,7 @@ let rec immediate_subtypes : type_expr -> type_expr list = fun ty -> [ty1; ty2] | Ttuple(tys) -> List.map snd tys | Tunboxed_tuple(tys) -> List.map snd tys - | Tpackage(_, fl) -> (snd (List.split fl)) + | Tpackage pack -> (snd (List.split pack.pack_cstrs)) | Tobject(row,class_ty) -> let class_subtys = match !class_ty with @@ -427,7 +427,7 @@ let check_type | (Tquote(_) , Sep ) | (Tsplice(_) , Sep ) | (Tquote_eval(_) , Sep ) - | (Tpackage(_,_) , Sep ) + | (Tpackage _ , Sep ) | (Tof_kind(_) , Sep ) -> empty (* "Deeply separable" case for these same constructors. *) | (Tarrow _ , Deepsep) @@ -439,7 +439,7 @@ let check_type | (Tquote(_) , Deepsep) | (Tsplice(_) , Deepsep) | (Tquote_eval(_) , Deepsep) - | (Tpackage(_,_) , Deepsep) -> + | (Tpackage _ , Deepsep) -> let tys = immediate_subtypes ty in let on_subtype context ty = context ++ check_type (Hyps.guard hyps) ty Deepsep in diff --git a/upstream/ocaml_flambda/typing/typedecl_variance.ml b/upstream/ocaml_flambda/typing/typedecl_variance.ml index ae2bc01fe..630a8e04f 100644 --- a/upstream/ocaml_flambda/typing/typedecl_variance.ml +++ b/upstream/ocaml_flambda/typing/typedecl_variance.ml @@ -44,9 +44,13 @@ type variance_error = variable : type_expr } +type anonymous_variance_error = + | Variable_constrained of type_expr + | Variable_instantiated of type_expr + type error = | Bad_variance of variance_error * surface_variance * surface_variance - | Varying_anonymous + | Varying_anonymous of int * anonymous_variance_error exception Error of Location.t * error @@ -111,9 +115,10 @@ let compute_variance env visited vari ty = | Tpoly (ty, _) | Trepr (ty, _) -> compute_same ty | Tvar _ | Tnil | Tlink _ | Tunivar _ | Tof_kind _ -> () - | Tpackage (_, fl) -> + | Tpackage pack -> let v = Variance.(compose vari full) in - List.iter (fun (_, ty) -> compute_variance_rec env v ty) fl + List.iter + (fun (_, ty) -> compute_variance_rec env v ty) pack.pack_cstrs in compute_variance_rec env vari ty @@ -130,7 +135,10 @@ let compute_variance_type env ~check (required, loc) decl tyl = 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)) + (* c and n reflects respectively + and - in the syntax, + and maps respectively to `not May_neg` and `not May_pos` + in the {!Types.Variance.f} fields *) + not n, not c, i) required in (* Prepare *) @@ -186,8 +194,7 @@ let compute_variance_type env ~check (required, loc) decl tyl = (c,n,i))))) params required; (* Check propagation from constrained parameters *) - let args = Btype.newgenty (Ttuple (List.map (fun t -> None, t) params)) in - let fvl = Ctype.free_variables args in + let fvl = Ctype.free_variables_list params 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 *) @@ -263,8 +270,12 @@ let add_false = List.map (fun ty -> false, ty) 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 + | Tvar _ -> + begin match List.find_map (List.find_opt (eq_type ty)) vars with + | Some var -> Some (Variable_constrained var) + | None -> None + end + | _ -> Some (Variable_instantiated ty) let for_constr = function | Types.Cstr_tuple l -> List.map (fun {ca_type; _} -> false, ca_type) l @@ -274,8 +285,8 @@ let for_constr = function (Types.is_mutable ld_mutable, ld_type)) l -let compute_variance_gadt env ~check (required, loc as rloc) decl - (tl, ret_type_opt) = +let compute_variance_gadt env ~check (required, _ as rloc) decl + (cloc, tl, ret_type_opt) = match ret_type_opt with | None -> compute_variance_type env ~check rloc {decl with type_private = Private} @@ -287,14 +298,20 @@ let compute_variance_gadt env ~check (required, loc as rloc) decl let fvl = List.map (Ctype.free_variables ?env:None) tyl in let _ = List.fold_left2 - (fun (fv1,fv2) ty (c,n,_) -> + (fun (index, 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 + if (c || n) + then begin + match constrained (fv1 @ fv2) ty with + | None -> () + | Some reason -> + raise (Error(cloc, + Varying_anonymous (index, reason))) + end; + (succ index, fv :: fv1, fv2)) + (1, [], fvl) tyl required in compute_variance_type env ~check rloc {decl with type_params = tyl; type_private = Private} @@ -308,7 +325,7 @@ let compute_variance_extension env decl ext rloc = 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) + (ext.ext_loc, ext.ext_args, ext.ext_ret_type) let compute_variance_gadt_constructor env ~check rloc decl tl = let check = @@ -317,7 +334,7 @@ let compute_variance_gadt_constructor env ~check rloc decl tl = | None -> None in compute_variance_gadt env ~check rloc decl - (tl.Types.cd_args, tl.Types.cd_res) + (tl.Types.cd_loc, tl.Types.cd_args, tl.Types.cd_res) let compute_variance_decl env ~check decl (required, _ as rloc) = let check = @@ -327,11 +344,15 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = check in let abstract = Btype.type_kind_is_abstract decl in - if (abstract || decl.type_kind = Type_open) && decl.type_manifest = None then + match decl with + | {type_kind = Type_abstract _ | Type_open; type_manifest = None} -> List.map (fun (c, n, i) -> make (not n) (not c) (not abstract || i)) required - else begin + | { type_kind = _; type_manifest = Some _ } + | { type_kind = Type_record _ | Type_variant _ + | Type_record_unboxed_product _; + type_manifest = _ } -> let mn = match decl.type_manifest with None -> [] @@ -378,7 +399,6 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = if mn = [] || not abstract then List.map Variance.strengthen vari else vari - end let is_hash id = let s = Ident.name id in @@ -431,6 +451,7 @@ let transl_variance (v, i) = | Covariant -> (true, false) | Contravariant -> (false, true) | NoVariance -> (false, false) + | Bivariant -> (true, true) in (co, cn, match i with Injective -> true | NoInjectivity -> false) diff --git a/upstream/ocaml_flambda/typing/typedecl_variance.mli b/upstream/ocaml_flambda/typing/typedecl_variance.mli index 0b29e6205..e28f1808e 100644 --- a/upstream/ocaml_flambda/typing/typedecl_variance.mli +++ b/upstream/ocaml_flambda/typing/typedecl_variance.mli @@ -49,9 +49,13 @@ type variance_error = variable : type_expr } +type anonymous_variance_error = + | Variable_constrained of type_expr + | Variable_instantiated of type_expr + type error = | Bad_variance of variance_error * surface_variance * surface_variance - | Varying_anonymous + | Varying_anonymous of int * anonymous_variance_error exception Error of Location.t * error diff --git a/upstream/ocaml_flambda/typing/typedtree.ml b/upstream/ocaml_flambda/typing/typedtree.ml index c3c31ebfd..33fe7028b 100644 --- a/upstream/ocaml_flambda/typing/typedtree.ml +++ b/upstream/ocaml_flambda/typing/typedtree.ml @@ -17,6 +17,7 @@ open Asttypes open Types +open Data_types open Mode type constant = @@ -209,7 +210,7 @@ and 'k pattern_desc = (string option * value general_pattern * Jkind.sort) list -> value pattern_desc | Tpat_construct : - Longident.t loc * Types.constructor_description * + Longident.t loc * constructor_description * value general_pattern list * ((Ident.t loc * Parsetree.jkind_annotation option) list * core_type) option -> @@ -288,8 +289,10 @@ and expression_desc = | Texp_apply of expression * (arg_label * apply_arg) list * apply_position * Mode.Locality.l * Zero_alloc.assume option - | Texp_match of expression * Jkind.sort * computation case list * partial - | Texp_try of expression * value case list + | Texp_match of + expression * Jkind.sort * computation case list * value case list + * partial + | Texp_try of expression * value case list * value case list | Texp_unboxed_unit | Texp_unboxed_bool of bool | Texp_tuple of (string option * expression) list * alloc_mode @@ -298,14 +301,14 @@ and expression_desc = Longident.t loc * constructor_description * expression list * alloc_mode option | Texp_variant of label * (expression * alloc_mode) option | Texp_record of { - fields : ( Types.label_description * record_label_definition ) array; + fields : ( Data_types.label_description * record_label_definition ) array; representation : Types.record_representation; extended_expression : (expression * Jkind.sort * Unique_barrier.t) option; alloc_mode : alloc_mode option } | Texp_record_unboxed_product of { fields : - ( Types.unboxed_label_description * record_label_definition ) array; + ( unboxed_label_description * record_label_definition ) array; representation : Types.record_unboxed_product_representation; extended_expression : (expression * Jkind.sort) option; } @@ -389,11 +392,11 @@ and meth = | Tmeth_ancestor of Ident.t * Path.t and block_access = - | Baccess_field of Longident.t loc * Types.label_description + | Baccess_field of Longident.t loc * label_description | Baccess_block of mutable_flag * expression and unboxed_access = - | Uaccess_unboxed_field of Longident.t loc * Types.unboxed_label_description + | Uaccess_unboxed_field of Longident.t loc * unboxed_label_description and comprehension = { @@ -426,6 +429,7 @@ and comprehension_iterator = and 'k case = { c_lhs: 'k general_pattern; + c_cont: Ident.t option; c_guard: expression option; c_rhs: expression; } @@ -655,6 +659,7 @@ and module_coercion = | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of primitive_coercion | Tcoerce_alias of Env.t * Path.t * module_coercion + | Tcoerce_invalid and module_type = { mty_desc: module_type_desc; @@ -831,10 +836,10 @@ and core_type_desc = | Ttyp_call_pos 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; + tpt_path : Path.t; + tpt_cstrs : (Longident.t loc * core_type) list; + tpt_type : Types.module_type; + tpt_txt : Longident.t loc; } and row_field = { @@ -1427,40 +1432,9 @@ let split_pattern pat = 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 nominal_exp_doc lid t = - let open Format_doc.Doc in - let longident l = Format_doc.doc_printer lid l.Location.txt in - let rec nominal_exp_doc doc exp = - match exp.exp_desc with - | _ when exp.exp_attributes <> [] -> None - | Texp_ident { lid; _ } -> - Some (longident lid doc) - | Texp_instvar (_,_,s) -> - Some (string s.Location.txt doc) - | Texp_constant _ -> assert false - | Texp_variant (lbl, None) -> - Some (printf "`%s" lbl doc) - | Texp_construct (l, _, [], _) -> Some (longident l doc) - | Texp_field (parent, _, lbl, _, _, _) -> - Option.map - (printf ".%t" (longident lbl)) - (nominal_exp_doc doc parent) - | Texp_send (parent, meth, _) -> - let name = match meth with - | Tmeth_name name -> name - | Tmeth_val id | Tmeth_ancestor (id,_) -> Ident.name id in - Option.map - (printf "#%s" name) - (nominal_exp_doc doc parent) - | _ -> None - in - nominal_exp_doc empty t +let map_apply_arg f = function + | Arg arg -> Arg (f arg) + | Omitted _ as arg -> arg let loc_of_decl ~uid = let of_option { txt; loc } = @@ -1513,12 +1487,14 @@ let rec fold_antiquote_exp f acc exp = | Texp_apply (exp, list, _, _, _) -> let acc = fold_antiquote_exp f acc exp in fold_antiquote_args f acc list - | Texp_match (exp, _, cases, _) -> + | Texp_match (exp, _, cases, eff_cases, _) -> let acc = fold_antiquote_exp f acc exp in - fold_antiquote_cases f acc cases - | Texp_try (exp, cases) -> + let acc = fold_antiquote_cases f acc cases in + fold_antiquote_cases f acc eff_cases + | Texp_try (exp, cases, eff_cases) -> let acc = fold_antiquote_exp f acc exp in - fold_antiquote_cases f acc cases + let acc = fold_antiquote_cases f acc cases in + fold_antiquote_cases f acc eff_cases | Texp_tuple (list, _) -> List.fold_left (fun acc (_, e) -> fold_antiquote_exp f acc e) acc list | Texp_unboxed_tuple list -> diff --git a/upstream/ocaml_flambda/typing/typedtree.mli b/upstream/ocaml_flambda/typing/typedtree.mli index 24f7be464..6627de87a 100644 --- a/upstream/ocaml_flambda/typing/typedtree.mli +++ b/upstream/ocaml_flambda/typing/typedtree.mli @@ -246,7 +246,8 @@ and 'k pattern_desc = (** #() *) | Tpat_unboxed_bool : bool -> value pattern_desc (** #false, #true *) - | Tpat_tuple : (string option * value general_pattern) list -> value pattern_desc + | Tpat_tuple : + (string option * value general_pattern) list -> value pattern_desc (** (P1, ..., Pn) [(None,P1); ...; (None,Pn)]) (L1:P1, ... Ln:Pn) [(Some L1,P1); ...; (Some Ln,Pn)]) Any mix, e.g. (L1:P1, P2) [(Some L1,P1); ...; (None,P2)]) @@ -263,7 +264,7 @@ and 'k pattern_desc = Invariant: n >= 2 *) | Tpat_construct : - Longident.t loc * Types.constructor_description * + Longident.t loc * Data_types.constructor_description * value general_pattern list * ((Ident.t loc * Parsetree.jkind_annotation option) list * core_type) option -> @@ -287,17 +288,22 @@ and 'k pattern_desc = 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 + (Longident.t loc + * Data_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_record_unboxed_product : - (Longident.t loc * Types.unboxed_label_description * value general_pattern) list * - closed_flag -> + (Longident.t loc + * Data_types.unboxed_label_description + * value general_pattern) list + * closed_flag -> value pattern_desc (** #{ l1=P1; ...; ln=Pn } (flag = Closed) #{ l1=P1; ...; ln=Pn; _} (flag = Open) @@ -305,7 +311,8 @@ and 'k pattern_desc = Invariant: n > 0 *) | Tpat_array : - Types.mutability * Jkind.sort * value general_pattern list -> value pattern_desc + Types.mutability * Jkind.sort * value general_pattern list -> + value pattern_desc (** [| P1; ...; Pn |] (flag = Mutable) [: P1; ...; Pn :] (flag = Immutable) *) | Tpat_lazy : value general_pattern -> value pattern_desc @@ -454,7 +461,7 @@ and expression_desc = (** 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.Pexp_function}[Pexp_function]}. + {{!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 @@ -475,22 +482,29 @@ and expression_desc = The resulting typedtree for the application is: Texp_apply (Texp_ident "f/1037", [(Nolabel, Omitted _); - (Labelled "y", Some (Texp_constant Const_int 3)) + (Labelled "y", Arg (Texp_constant Const_int 3)) ]) The [Zero_alloc.assume option] records the optional [@zero_alloc assume] attribute that may appear on applications. *) - | Texp_match of expression * Jkind.sort * computation case list * partial + | Texp_match of + expression * Jkind.sort * 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, sort_of_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_unboxed_unit (** #() *) | Texp_unboxed_bool of bool @@ -514,7 +528,7 @@ and expression_desc = when [el] is [(Some L1, E1, s1); (None, E2, s2)] *) | Texp_construct of - Longident.t loc * Types.constructor_description * + Longident.t loc * Data_types.constructor_description * expression list * alloc_mode option (** C [] C E [E] @@ -530,7 +544,7 @@ and expression_desc = in which case it does not need allocation. *) | Texp_record of { - fields : ( Types.label_description * record_label_definition ) array; + fields : ( Data_types.label_description * record_label_definition ) array; representation : Types.record_representation; extended_expression : (expression * Jkind.sort * Unique_barrier.t) option; alloc_mode : alloc_mode option @@ -550,7 +564,9 @@ and expression_desc = in which case it does not need allocation. *) | Texp_record_unboxed_product of { - fields : ( Types.unboxed_label_description * record_label_definition ) array; + fields : + ( Data_types.unboxed_label_description + * record_label_definition ) array; representation : Types.record_unboxed_product_representation; extended_expression : (expression * Jkind.sort) option; } @@ -566,20 +582,20 @@ and expression_desc = extended_expression = Some E0 } *) | Texp_atomic_loc of - expression * Jkind.sort * Longident.t loc * Types.label_description * + expression * Jkind.sort * Longident.t loc * Data_types.label_description * alloc_mode | Texp_field of expression * Jkind.sort * Longident.t loc * - Types.label_description * texp_field_boxing * Unique_barrier.t + Data_types.label_description * texp_field_boxing * Unique_barrier.t (** - The sort is the sort of the whole record (which may be non-value if the record is @@unboxed). - [texp_field_boxing] provides extra information depending on if the projection requires boxing. *) | Texp_unboxed_field of - expression * Jkind.sort * Longident.t loc * Types.unboxed_label_description * - unique_use + expression * Jkind.sort * Longident.t loc * + Data_types.unboxed_label_description * unique_use | Texp_setfield of expression * Mode.Locality.l * Longident.t loc * - Types.label_description * expression + Data_types.label_description * expression (** [alloc_mode] translates to the [modify_mode] of the record *) | Texp_array of Types.mutability * Jkind.Sort.t * expression list * alloc_mode | Texp_idx of block_access * unboxed_access list @@ -644,10 +660,23 @@ and expression_desc = | Texp_quotation of expression | Texp_antiquotation of expression +and meth = + Tmeth_name of string + | Tmeth_val of Ident.t + | Tmeth_ancestor of Ident.t * Path.t + and function_curry = | More_args of { partial_mode : Mode.Alloc.l } | Final_arg +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; @@ -721,17 +750,13 @@ and ident_kind = | Id_value | Id_prim of Mode.Locality.l option * Jkind.Sort.t option -and meth = - Tmeth_name of string - | Tmeth_val of Ident.t - | Tmeth_ancestor of Ident.t * Path.t - and block_access = - | Baccess_field of Longident.t loc * Types.label_description + | Baccess_field of Longident.t loc * Data_types.label_description | Baccess_block of mutable_flag * expression and unboxed_access = - | Uaccess_unboxed_field of Longident.t loc * Types.unboxed_label_description + | Uaccess_unboxed_field of + Longident.t loc * Data_types.unboxed_label_description and comprehension = { @@ -769,13 +794,6 @@ and comprehension_iterator = { pattern : pattern ; sequence : expression } -and 'k case = - { - c_lhs: 'k general_pattern; - c_guard: expression option; - c_rhs: expression; - } - and record_label_definition = | Kept of Types.type_expr * Types.mutability * unique_use | Overridden of Longident.t loc * expression @@ -799,6 +817,8 @@ and ('a, 'b) arg_or_omitted = | Arg of 'a (* an argument actually passed to a function *) | Omitted of 'b (* an argument not passed due to partial application *) +and apply_arg = (expression * Jkind.sort, omitted_parameter) arg_or_omitted + and omitted_parameter = { mode_closure : Mode.Alloc.r; mode_arg : Mode.Alloc.l; @@ -806,8 +826,6 @@ and omitted_parameter = sort_arg : Jkind.sort; sort_ret : Jkind.sort } -and apply_arg = (expression * Jkind.sort, omitted_parameter) arg_or_omitted - and apply_position = | Tail (* must be tail-call optimised *) | Nontail (* must not be tail-call optimised *) @@ -992,6 +1010,9 @@ and module_coercion = struct module Sub = Some_alias end ]} Only occurs inside a [Tcoerce_structure] coercion. *) + | Tcoerce_invalid + (** This coercion is only constructed by the recursive module consistency + check, whose result is discarded. It's a bug if it shows up anywhere. *) and module_type = { mty_desc: module_type_desc; @@ -1175,10 +1196,10 @@ and core_type_desc = argument ([lbl:[%call_pos] -> ...]). *) 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; + tpt_path : Path.t; + tpt_cstrs : (Longident.t loc * core_type) list; + tpt_type : Types.module_type; + tpt_txt : Longident.t loc; } and row_field = { @@ -1493,12 +1514,6 @@ val pat_bound_idents_full: val split_pattern: computation general_pattern -> pattern option * pattern option -(** Returns a format document if the expression reads nicely as the subject of a - sentence in a error message. *) -val nominal_exp_doc : - Longident.t Format_doc.printer -> expression - -> Format_doc.t option - (** Calculates the syntactic arity of a function based on its parameters and body. *) val function_arity : function_param list -> function_body -> int @@ -1515,3 +1530,6 @@ val mode_without_locks_exn : mode_with_locks -> Mode.Value.l (** Fold over the antiquotations in an expression. This function defines the evaluation order of antiquotations. *) val fold_antiquote_exp : ('a -> expression -> 'a) -> 'a -> expression -> 'a + +val map_apply_arg: + ('a -> ' b) -> ('a, 'omitted) arg_or_omitted -> ('b, 'omitted) arg_or_omitted diff --git a/upstream/ocaml_flambda/typing/typemod.ml b/upstream/ocaml_flambda/typing/typemod.ml index d57499fdd..3a31a1168 100644 --- a/upstream/ocaml_flambda/typing/typemod.ml +++ b/upstream/ocaml_flambda/typing/typemod.ml @@ -89,6 +89,7 @@ type error = | Invalid_type_subst_rhs | Non_packable_local_modtype_subst of Path.t | With_cannot_remove_packed_modtype of Path.t * module_type + | Cannot_alias of Path.t | Strengthening_mismatch of Longident.t * Includemod.explanation | Cannot_pack_parameter | Compiling_as_parameterised_parameter @@ -975,6 +976,7 @@ module Merge = struct | Covariant -> true, false | Contravariant -> false, true | NoVariance -> false, false + | Bivariant -> true, true in make_variance (not n) (not c) (i = Injective) ) @@ -986,7 +988,7 @@ module Merge = struct type_expansion_scope = Btype.lowest_level; type_attributes = []; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); type_unboxed_version = None; } and id_row = Ident.create_local (s^"#row") in @@ -1164,7 +1166,7 @@ module Merge = struct if destructive then None else 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; mtd_attributes = []; mtd_loc = loc; } @@ -1658,7 +1660,7 @@ and approx_modtype_info env sinfo = mtd_attributes = sinfo.pmtd_attributes; mtd_loc = sinfo.pmtd_loc; mtd_uid = Uid.internal_not_actually_unique; - } + } and approx_constraint env body constr = (* constraints are first approximated then merged, disabling all equivalence @@ -2068,7 +2070,7 @@ and transl_modtype_aux env smty = md_modalities = Mode.Modality.undefined; 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 @@ -2334,7 +2336,10 @@ and transl_signature env {psg_items; psg_modalities; psg_loc} = let tmty = {tmty with mty_type} 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 = { @@ -2342,7 +2347,7 @@ and transl_signature env {psg_items; psg_modalities; psg_loc} = md_modalities = Modality.of_const md_modalities.moda_modalities; 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 = @@ -2385,7 +2390,7 @@ and transl_signature env {psg_items; psg_modalities; psg_loc} = md_modalities = Mode.Modality.(Const.id |> of_const); 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 = @@ -2581,7 +2586,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 @@ -2654,7 +2659,7 @@ and transl_recmodule_modtypes env ~sig_modalities sdecls = let init = List.map2 (fun id (pmd, smmode) -> - 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_type, md_modalities = approx_modtype (approx_env pmd.pmd_name.txt) pmd.pmd_type |> apply_pmd_modalities env ~default_modalities:sig_modalities @@ -3017,30 +3022,38 @@ and package_constraints env loc mty constrs = raise(Error(loc, env, Cannot_scrape_package_type (ident mty))) end -let modtype_of_package env loc p fl = - (* We call Ctype.correct_levels to ensure that the types being added to the +let modtype_of_package env loc pack = + (* 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) + package_constraints env loc (Mty_ident pack.pack_path) + (List.map (fun (n, t) -> n, Ctype.duplicate_type t) pack.pack_cstrs) in Subst.modtype Keep Subst.identity mty (* CR zqian: [package_subtype] should take [modes], but piping this through [ctype] is too much. Instead, we take the conservative approach. *) -let package_subtype env p1 fl1 p2 fl2 = - let mkmty p fl = +let package_subtype env pack1 pack2 = + let mkmty pack = let fl = - List.filter (fun (_n,t) -> Ctype.closed_type_expr t) fl in - modtype_of_package env Location.none p fl + List.filter (fun (_n,t) -> Ctype.closed_type_expr t) pack.pack_cstrs in + modtype_of_package env Location.none {pack with pack_cstrs = fl} in - match mkmty p1 fl1, mkmty p2 fl2 with - | exception Error(_, _, Cannot_scrape_package_type _) -> false + match mkmty pack1, mkmty pack2 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:true env ~modes:All 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 @@ -3105,22 +3118,28 @@ let simplify_app_summary app_view = match app_view.arg with | false, Some p -> Includemod.Error.Named p, mty, mode | false, None -> Includemod.Error.Anonymous, mty, mode +let check_package_closed ~loc ~env ~typ fl = + if List.exists (fun (_n, t) -> not (Ctype.closed_type_expr t)) fl + then + raise (Error (loc, env, Incomplete_packed_module typ)) + let not_principal msg = Warnings.Not_principal (Format_doc.Doc.msg msg) -let rec type_module ?alias sttn funct_body anchor env smod = +let rec type_module ?alias ~strengthen ~funct_body anchor env smod = let md, shape = - type_module_maybe_hold_locks ?alias ~hold_locks:false sttn funct_body anchor - env smod + type_module_maybe_hold_locks ?alias ~hold_locks:false ~strengthen + ~funct_body anchor env smod in md, shape -and type_module_maybe_hold_locks ?(alias=false) ~hold_locks sttn funct_body - anchor env smod = +and type_module_maybe_hold_locks ?(alias=false) ~hold_locks ~strengthen + ~funct_body anchor env smod = Builtin_attributes.warning_scope smod.pmod_attributes - (fun () -> type_module_aux ~alias ~hold_locks sttn funct_body anchor env - smod) + (fun () -> type_module_aux ~alias ~hold_locks ~strengthen ~funct_body + anchor env smod) -and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = +and type_module_aux ~alias ~hold_locks ~strengthen ~funct_body anchor env + smod = (* If the module is an identifier, there might be locks between the declaration site and the use site. - If [hold_locks] is [true], the locks are held and stored in [mod_mode]. @@ -3132,12 +3151,12 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = let path, mode_with_locks = Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env in - type_module_path_aux ~alias ~hold_locks sttn env path mode_with_locks lid - smod + type_module_path_aux ~alias ~hold_locks ~strengthen env path + mode_with_locks lid smod | Pmod_structure sstr -> Env.check_no_open_quotations smod.pmod_loc env Env.Struct_qt; let (str, sg, mode, names, shape, _finalenv) = - type_structure funct_body anchor env sstr in + type_structure ~funct_body anchor env sstr in let md = { mod_desc = Tmod_structure str; mod_type = Mty_signature sg; @@ -3172,7 +3191,7 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = match param.txt with | None -> None, newenv, 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_modalities = Modality.undefined; @@ -3193,7 +3212,9 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = newenv, var, true in - let body, body_shape = type_module true funct_body None newenv sbody in + let body, body_shape = + type_module ~strengthen:true ~funct_body None newenv sbody + in let body_mode = mode_without_locks_exn body.mod_mode in let ret_mode = Alloc.newvar () in Value.submode_exn body_mode (ret_mode |> alloc_as_value); @@ -3215,7 +3236,7 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = 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 + type_application smod.pmod_loc ~strengthen ~funct_body env smod | Pmod_constraint(sarg, smty, smode) -> (* Only hold locks if coercion *) let hold_locks = Option.is_some smty in @@ -3224,8 +3245,8 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = { tmode with mode_modes = new_mode_var_from_annots tmode.mode_modes } in let arg, arg_shape = - type_module_maybe_hold_locks ~alias ~hold_locks true funct_body - anchor env sarg + type_module_maybe_hold_locks ~alias ~hold_locks ~strengthen:true + ~funct_body anchor env sarg in let md, final_shape = match smty with @@ -3248,24 +3269,21 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = | Pmod_unpack sexp -> let mode = Value.newvar () in let exp = - Ctype.with_local_level_if_principal + Ctype.with_local_level_generalize_structure_if_principal (fun () -> Typecore.type_exp env sexp ~mode:(Value.disallow_left mode)) - ~post:Typecore.generalize_structure_exp in let mty = match get_desc (Ctype.expand_head env exp.exp_type) with - Tpackage (p, fl) -> - if List.exists (fun (_n, t) -> not (Ctype.closed_type_expr t)) fl - then - raise (Error (smod.pmod_loc, env, - Incomplete_packed_module exp.exp_type)); + Tpackage pack -> + check_package_closed ~loc:smod.pmod_loc ~env ~typ:exp.exp_type + pack.pack_cstrs; 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 + modtype_of_package env smod.pmod_loc pack | Tvar _ -> raise (Typecore.Error (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) @@ -3298,10 +3316,10 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = in Location.(mkloc (Lident name) (ghostify smod.pmod_loc)) in - type_module_path_aux ~alias ~hold_locks sttn env path mode_with_locks lid - smod + type_module_path_aux ~alias ~hold_locks ~strengthen env path + mode_with_locks lid smod -and type_module_path_aux ~alias ~hold_locks sttn env path +and type_module_path_aux ~alias ~hold_locks ~strengthen env path (mode, locks) (lid : _ loc) smod = let mod_mode = if hold_locks then mode, Some (locks, lid.txt, lid.loc) @@ -3327,13 +3345,13 @@ and type_module_path_aux ~alias ~hold_locks sttn env path (Env.add_required_global path env; md) else begin let mty = Mtype.find_type_of_module - ~strengthen:sttn ~aliasable env path + ~strengthen ~aliasable env path 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 + ~strengthen env p1 in { md with mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit, @@ -3345,13 +3363,13 @@ and type_module_path_aux ~alias ~hold_locks sttn env path in md, shape -and type_application loc strengthen funct_body env smod = - let rec extract_application funct_body env sargs smod = +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) -> + | Pmod_apply (f, sarg) -> let arg, shape = - type_module_maybe_hold_locks ~hold_locks:true true funct_body None env - sarg + type_module_maybe_hold_locks ~hold_locks:true ~strengthen:true + ~funct_body None env sarg in let summary = { loc = smod.pmod_loc; @@ -3364,7 +3382,7 @@ and type_application loc strengthen funct_body env smod = shape; } } in - extract_application funct_body env (summary::sargs) f + extract_application ~funct_body env (summary::sargs) f | Pmod_apply_unit f -> let summary = { loc = smod.pmod_loc; @@ -3372,17 +3390,17 @@ and type_application loc strengthen funct_body env smod = f_loc = f.pmod_loc; arg = None } in - extract_application funct_body env (summary::sargs) f + extract_application ~funct_body env (summary::sargs) f | _ -> smod, sargs in - let sfunct, args = extract_application funct_body env [] smod 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 + type_module ~strengthen ~funct_body None env sfunct in List.fold_left (type_one_application ~ctx:(loc, sfunct, funct, args) funct_body env) @@ -3456,8 +3474,8 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) | { 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:true env arg.mod_type mty_param + try Includemod.modtypes ~loc:arg.mod_loc ~mark:true env + arg.mod_type mty_param ~modes:(Specific (arg.mod_mode, mm_param)) with Includemod.Error _ -> apply_error () in @@ -3488,8 +3506,8 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) raise (Error(app_loc, env, error)) in begin match - Includemod.modtypes - ~loc:app_loc ~mark:false env mty_res nondep_mty + Includemod.modtypes ~loc:app_loc ~mark:false env + mty_res nondep_mty ~modes:(Specific ((mm_res, None), mm_res)) with | Tcoerce_none -> () @@ -3498,8 +3516,8 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) Format.eprintf "[nondep-supertype] unexpected coercion@;original=%a@;\ nondep=%a@." - (Format_doc.compat Printtyp.modtype) mty_res - (Format_doc.compat Printtyp.modtype) nondep_mty; + Printtyp.modtype mty_res + Printtyp.modtype nondep_mty; fatal_error "unexpected coercion from original module type to \ nondep_supertype one" @@ -3508,8 +3526,8 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) Format.eprintf "[nondep-supertype] inclusion failure@;original=%a@;\ nondep=%a@." - (Format_doc.compat Printtyp.modtype) mty_res - (Format_doc.compat Printtyp.modtype) nondep_mty; + Printtyp.modtype mty_res + Printtyp.modtype nondep_mty; fatal_error "nondep_supertype not included in original module type" end; @@ -3539,13 +3557,13 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) 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 = +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 + 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 = +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 -> @@ -3570,7 +3588,9 @@ and type_open_decl_aux ?used_slot ?toplevel funct_body names env od = } in open_descr, Mode.Value.(max |> disallow_right), [], newenv | _ -> - let md, mod_shape = type_module true funct_body None env od.popen_expr in + let md, mod_shape = + type_module ~strengthen:true ~funct_body None env od.popen_expr + in let mode = mode_without_locks_exn md.mod_mode in let scope = Ctype.create_scope () in let sg, newenv = @@ -3609,7 +3629,7 @@ and type_open_decl_aux ?used_slot ?toplevel funct_body names env od = } in open_descr, mode, sg, newenv -and type_structure ?(toplevel = None) funct_body anchor env sstr = +and type_structure ?(toplevel = None) ~funct_body anchor env sstr = (* CR implicit-types: implement implicit variable jkinds in structures. *) let env = Env.clear_implicit_jkinds env in let names = Signature_names.create () in @@ -3620,7 +3640,7 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = 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) + (fun () -> type_module ~strengthen:true ~funct_body None env smodl) in let scope = Ctype.create_scope () in let incl_kind, sg, mode = @@ -3808,7 +3828,7 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = let modl, md_shape = Builtin_attributes.warning_scope attrs (fun () -> - type_module ~alias:true true funct_body + type_module ~alias:true ~strengthen:true ~funct_body (anchor_submodule name.txt anchor) env smodl ) in @@ -3817,7 +3837,7 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = | 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 mode = mode_without_locks_exn modl.mod_mode in let md = { md_type = enrich_module_type anchor name.txt modl.mod_type env; @@ -3896,13 +3916,15 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = let modl, shape = Builtin_attributes.warning_scope attrs (fun () -> - type_module true funct_body (anchor_recmodule id) - newenv smodl + type_module ~strengthen: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', Option.get mode, attrs, loc, shape, uid)) decls sbind in @@ -3965,7 +3987,7 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = | Pstr_open sod -> let toplevel = Option.is_some toplevel in let (od, mode, sg, newenv) = - type_open_decl ~toplevel funct_body names env sod + type_open_decl ~toplevel ~funct_body names env sod in let sg = rebase_modalities_sg ~loc:sod.popen_expr.pmod_loc ~loc_md @@ -4045,9 +4067,6 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pstr_attribute x -> Builtin_attributes.parse_standard_implementation_attributes x; - if Option.is_some toplevel - || not (Warnings.is_active (Misplaced_attribute "")) then - Builtin_attributes.mark_alert_used x; Tstr_attribute x, [], shape_map, env | Pstr_jkind x -> let id, env, decl = Typedecl.transl_jkind_decl env x in @@ -4107,7 +4126,7 @@ let type_toplevel_phrase env sig_acc s = Env.reset_probes (); Typecore.reset_allocations (); let (str, sg, mode, to_remove_from_sg, shape, env) = - type_structure ~toplevel:(Some sig_acc) false None env s in + type_structure ~toplevel:(Some sig_acc) ~funct_body:false None env s in Value.submode_err (Location.none, Structure) mode toplevel_mode; remove_mode_and_jkind_variables env sg; remove_mode_and_jkind_variables_for_toplevel str; @@ -4115,12 +4134,15 @@ let type_toplevel_phrase env sig_acc s = (str, sg, to_remove_from_sg, shape, env) let type_module_alias env smod = - type_module_maybe_hold_locks ~alias:true ~hold_locks:true true false - None env smod + type_module_maybe_hold_locks ~alias:true ~hold_locks:true ~strengthen:true + ~funct_body:false None env smod -let type_module = type_module true false None -let type_module_maybe_hold_locks = type_module_maybe_hold_locks true false None -let type_structure = type_structure false None +let type_module = + type_module ~strengthen:true ~funct_body:false None +let type_module_maybe_hold_locks = + type_module_maybe_hold_locks ~strengthen:true ~funct_body:false None +let type_structure = + type_structure ~funct_body:false None (* Normalize types in a signature *) @@ -4174,7 +4196,7 @@ let rec extend_path path = fun lid -> match lid with | Lident name -> Pdot(path, name) - | Ldot(m, name) -> Pdot(extend_path path m, name) + | Ldot({ txt = m; _ }, { txt = name; _ }) -> Pdot(extend_path path m, name) | Lapply _ -> assert false (* Lookup a type's longident within a signature *) @@ -4196,16 +4218,16 @@ let lookup_type_in_sig sg = in let rec module_path = function | Lident name -> Pident (String.Map.find name modules) - | Ldot(m, name) -> Pdot(module_path m, name) + | Ldot({ txt = m; _ }, { txt = 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) + | Ldot({ txt = m; _ }, { txt = name; _ }) -> Pdot(module_path m, name) | Lapply _ -> assert false -let type_package env m p fl = +let type_package env m pack = (* Same as Pexp_letmodule *) (* remember original level *) let outer_scope = Ctype.get_current_level () in @@ -4223,7 +4245,7 @@ let type_package env m p fl = in Mtype.lower_nongen outer_scope modl.mod_type; let fl', env = - match fl with + match pack.pack_cstrs with | [] -> [], env | fl -> let type_path, env = @@ -4245,7 +4267,7 @@ let type_package env m p fl = let fl' = List.fold_right (fun (lid, _t) fl -> - match type_path lid with + match type_path (Longident.unflatten lid |> Option.get) with | exception Not_found -> fl | path -> begin match Env.find_type path env with @@ -4263,28 +4285,29 @@ let type_package env m p fl = fl', env in let mty = - if fl = [] then (Mty_ident p) - else modtype_of_package env modl.mod_loc p fl' + if pack.pack_cstrs = [] then (Mty_ident pack.pack_path) + else modtype_of_package env modl.mod_loc {pack with pack_cstrs = fl'} in List.iter (fun (n, ty) -> try Ctype.unify env ty (Ctype.newvar (Jkind.Builtin.any ~why:Dummy_jkind)) with Ctype.Unify _ -> - raise (Error(modl.mod_loc, env, Scoping_pack (n,ty)))) + let lid = Longident.unflatten n |> Option.get in + raise (Error(modl.mod_loc, env, Scoping_pack (lid,ty)))) fl'; let _, mode = register_allocation () in let modl = wrap_constraint_package env true modl mty mode Tmodtype_implicit in - modl, fl' + modl, {pack with pack_cstrs = fl'} (* Fill in the forward declarations *) let type_open_decl ?used_slot env od = let od, _, _, env = - type_open_decl ?used_slot ?toplevel:None false (Signature_names.create ()) - env od + type_open_decl ?used_slot ?toplevel:None ~funct_body:false + (Signature_names.create ()) env od in od, env @@ -4648,7 +4671,7 @@ let package_signatures units = md_modalities=Modality.(Const.id |> of_const); 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)) @@ -4745,9 +4768,7 @@ let package_units initial_env objfiles target_cmi modulename = (* Error report *) - - -open Printtyp +open Printtyp.Doc (* A heuristic used in nondep errors: the input describes a declaration that has made invalid, and this says what about it is now invalid. *) @@ -4764,12 +4785,13 @@ 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 ppf = Includemod_errorprinter.err_msgs ppf 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 | Not_included_functor errs -> - let main ppf = Includemod_errorprinter.err_msgs ppf errs in - Location.errorf ~loc - "@[Signature mismatch in included functor's parameter:@ %t@]" main + Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg + "@[Signature mismatch in included functor's parameter:@ %a@]" + Includemod_errorprinter.err_msgs errs | Cannot_eliminate_dependency (dep_type, mty) -> let hint = match dep_type with @@ -4810,7 +4832,7 @@ let report_error ~loc _env = function Style.inline_code "with" (Style.as_inline_code longident) lid | With_mismatch(lid, explanation) -> - 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@ \ @@ -4820,7 +4842,7 @@ let report_error ~loc _env = function (Style.as_inline_code longident) lid Includemod_errorprinter.err_msgs explanation | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> - 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:@]@ \ @@ -4848,7 +4870,7 @@ let report_error ~loc _env = function [ 12; 7; 3 ] in let pp_constraint ppf (p,mty) = - 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" @@ -4860,7 +4882,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 @@ -4869,34 +4891,32 @@ 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; - 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) - item.val_type - (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") - @@ Style.as_inline_code prepared_type_scheme) vars - ] - in - Location.errorf ~loc ~sub + Out_type.prepare_for_printing vars; + Out_type.add_type_to_preparation item.val_type; + Location.errorf ~loc "@[The type of this module,@ %a,@ \ contains non-generalizable type variable(s).@ %a@]" modtype mty Misc.print_see_manual manual_ref + ~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 + ] | Implementation_is_required intf_name -> Location.errorf ~loc "@[The interface %a@ declares values, not just types.@ \ @@ -4940,14 +4960,22 @@ 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_doc err + let report = Typedecl.report_error ~loc err in + let txt = + Format_doc.doc_printf "In %s:@ %a" + context + Format_doc.pp_doc report.main.txt + in + { report with main = { report.main with txt} } | 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/ocaml_flambda/typing/typemod.mli b/upstream/ocaml_flambda/typing/typemod.mli index a1f7a7504..b01b9110b 100644 --- a/upstream/ocaml_flambda/typing/typemod.mli +++ b/upstream/ocaml_flambda/typing/typemod.mli @@ -58,8 +58,7 @@ val type_open_: 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 + Env.t -> Location.t -> package -> module_type val path_of_module : Typedtree.module_expr -> Path.t option @@ -154,6 +153,7 @@ type error = | Invalid_type_subst_rhs | Non_packable_local_modtype_subst of Path.t | With_cannot_remove_packed_modtype of Path.t * module_type + | Cannot_alias of Path.t | Strengthening_mismatch of Longident.t * Includemod.explanation | Cannot_pack_parameter | Compiling_as_parameterised_parameter diff --git a/upstream/ocaml_flambda/typing/typeopt.ml b/upstream/ocaml_flambda/typing/typeopt.ml index 5b864eee3..921e3676a 100644 --- a/upstream/ocaml_flambda/typing/typeopt.ml +++ b/upstream/ocaml_flambda/typing/typeopt.ml @@ -60,57 +60,60 @@ let scrape_ty env ty = match get_desc ty with | Tconstr _ | Tquote _ | Tsplice _ | Tquote_eval _ -> - let ty = Ctype.correct_levels ty in - let ty' = Ctype.expand_head_opt env ty in - begin match get_desc ty' with + let ty = Ctype.expand_head_opt env ty in + begin match get_desc ty with | Tconstr (p, _, _) -> begin match find_unboxed_type (Env.find_type p env) with | Some _ -> begin - match (Ctype.get_unboxed_type_approximation env ty') with + match (Ctype.get_unboxed_type_approximation env ty) with | { ty; or_null = None; modality = _ } -> - ty - | _ -> ty' end - | None -> ty' - | exception Not_found -> ty (* missing cmi file *) + Some ty + | _ -> Some ty end + | None -> Some ty + | exception Not_found -> None end | _ -> - ty' + Some ty end - | _ -> ty + | _ -> Some ty (* See [scrape_ty]; this returns the [type_desc] of a scraped [type_expr]. *) let scrape env ty = - get_desc (scrape_ty env ty) + Option.map 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 + Option.map (fun ty -> + match get_desc ty with + | Tpoly (ty, _) -> get_desc ty + | d -> d) + ty let is_function_type env ty = match scrape env ty with - | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs) + | Some (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 + | Some (Tconstr(p, _, _)) -> Path.same p base_ty_path | _ -> false let maybe_pointer_type env ty = - let ty = scrape_ty env ty in - let immediate_or_pointer = - match Ctype.is_always_gc_ignorable env ty with - | true -> Immediate - | false -> Pointer - in - let nullable = - match Ctype.check_type_nullability env ty Non_null with - | true -> Non_nullable - | false -> Nullable - in - immediate_or_pointer, nullable + match scrape_ty env ty with + | Some ty -> + let immediate_or_pointer = + match Ctype.is_always_gc_ignorable env ty with + | true -> Immediate + | false -> Pointer + in + let nullable = + match Ctype.check_type_nullability env ty Non_null with + | true -> Non_nullable + | false -> Nullable + in + immediate_or_pointer, nullable + | None -> Pointer, Nullable let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type @@ -147,9 +150,11 @@ type 'a classification = [scrape_ty]. Returning [Any] is safe, though may skip some optimizations. See comment on [classification] above to understand [classify_product]. *) let classify ~classify_product env ty sort : _ classification = - let ty = scrape_ty env ty in match (sort : Jkind.Sort.Const.t) with | Base Scannable -> begin + match scrape_ty env ty with + | None -> Any + | Some ty -> if Ctype.is_always_gc_ignorable env ty then if Ctype.check_type_nullability env ty Non_null @@ -158,39 +163,45 @@ let classify ~classify_product env ty sort : _ classification = | 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_iarray - || Path.same p Predef.path_nativeint - || Path.same p Predef.path_float32 - || Path.same p Predef.path_int32 - || Path.same p Predef.path_int64 - || Path.same p Predef.path_int8x16 - || Path.same p Predef.path_int16x8 - || Path.same p Predef.path_int32x4 - || Path.same p Predef.path_int64x2 - || Path.same p Predef.path_float16x8 - || Path.same p Predef.path_float32x4 - || Path.same p Predef.path_float64x2 - || Path.same p Predef.path_int8x32 - || Path.same p Predef.path_int16x16 - || Path.same p Predef.path_int32x8 - || Path.same p Predef.path_int64x4 - || Path.same p Predef.path_float16x16 - || Path.same p Predef.path_float32x8 - || Path.same p Predef.path_float64x4 - || Path.same p Predef.path_int8x64 - || Path.same p Predef.path_int16x32 - || Path.same p Predef.path_int32x16 - || Path.same p Predef.path_int64x8 - || Path.same p Predef.path_float16x32 - || Path.same p Predef.path_float32x16 - || Path.same p Predef.path_float64x8 - then Addr - else begin + begin match Predef.find_type_constr p with + | Some `Float -> Float + | Some `Lazy_t -> Lazy + | Some (`Int | `Char | `Int8 | `Int16) -> + (* This should be unreachable anyway because we check + [is_always_gc_ignorable] above *) + Immediate + | Some (`String | `Bytes + | `Int32 | `Int64 | `Nativeint + | `Extension_constructor | `Continuation + | `Array | `Floatarray | `Iarray + | `Atomic_loc + | `Float32 + | `Int8x16 + | `Int16x8 + | `Int32x4 + | `Int64x2 + | `Float16x8 + | `Float32x4 + | `Float64x2 + | `Int8x32 + | `Int16x16 + | `Int32x8 + | `Int64x4 + | `Float16x16 + | `Float32x8 + | `Float64x4 + | `Int8x64 + | `Int16x32 + | `Int32x16 + | `Int64x8 + | `Float16x32 + | `Float32x16 + | `Float64x8 + ) + -> Addr + | Some (`Lexing_position | `Code) + | Some (#Predef.data_type_constr | #Predef.abstract_non_value_type_constr) + | None -> try match (Env.find_type p env).type_kind with | Type_abstract _ -> @@ -333,10 +344,10 @@ let array_kind_of_elt ~elt_sort env loc ty = let array_type_kind ~elt_sort ~elt_ty env loc ty = match scrape_poly env ty with - | Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array - || Path.same p Predef.path_iarray -> + | Some (Tconstr(p, [elt_ty], _)) + when Path.same p Predef.path_array || Path.same p Predef.path_iarray -> array_kind_of_elt ~elt_sort env loc elt_ty - | Tconstr(p, [], _) when Path.same p Predef.path_floatarray -> + | Some (Tconstr(p, [], _)) when Path.same p Predef.path_floatarray -> Pfloatarray | _ -> begin match elt_ty with @@ -374,7 +385,7 @@ let array_type_kind ~elt_sort ~elt_ty env loc ty = let array_type_mut env ty = match scrape_poly env ty with - | Tconstr(p, [_], _) when Path.same p Predef.path_iarray -> Immutable + | Some (Tconstr(p, [_], _)) when Path.same p Predef.path_iarray -> Immutable | _ -> Mutable let array_kind exp elt_sort = @@ -389,7 +400,7 @@ let array_pattern_kind pat elt_sort = let bigarray_decode_type env ty tbl dfl = match scrape env ty with - | Tconstr(Pdot(Pident mod_id, type_name), [], _) + | Some (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 | _ -> @@ -416,7 +427,7 @@ let layout_table = let bigarray_specialize_kind_and_layout env ~kind ~layout typ = match scrape env typ with - | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) -> + | Some (Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev)) -> let kind = match kind with | Pbigarray_unknown -> @@ -549,7 +560,9 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty || depth >= 2 || num_nodes_visited >= 30 in - let scty = scrape_ty env ty in + match scrape_ty env ty with + | None -> num_nodes_visited, non_nullable Pgenval + | Some scty -> begin (* CR layouts: We want to avoid correcting levels twice, and scrape_ty will correct levels for us. But it may be the case that we could do the @@ -573,8 +586,8 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty | Ok _ -> () | Error _ -> match - Ctype.(check_type_jkind env - (correct_levels ty) (Jkind.Builtin.value_or_null ~why:V1_safety_check)) + Ctype.check_type_jkind env ty + (Jkind.Builtin.value_or_null ~why:V1_safety_check) with | Ok _ -> () | Error violation -> @@ -765,7 +778,9 @@ and value_kind_mixed_block_field env ~loc ~visited ~depth ~num_nodes_visited match ty with | None -> unknown () | Some ty -> - let ty = scrape_ty env ty in + begin match scrape_ty env ty with + | None -> unknown () + | Some ty -> match get_desc ty with | Tunboxed_tuple fields -> Misc.Stdlib.Array.of_list_map (fun (_, field) -> Some field) fields @@ -775,9 +790,6 @@ and value_kind_mixed_block_field env ~loc ~visited ~depth ~num_nodes_visited | { type_kind = Type_record_unboxed_product (lbls, _, _); type_params; _ } -> let type_of_ld { Types.ld_type } = - let ld_type = Ctype.correct_levels ld_type in - let type_params = List.map Ctype.correct_levels type_params in - (* [args] is already corrected by [scrape_ty] *) try Some (Ctype.apply env type_params ld_type args) with Ctype.Cannot_apply -> None in @@ -793,6 +805,7 @@ and value_kind_mixed_block_field env ~loc ~visited ~depth ~num_nodes_visited | Tlink _ | Tsubst _ | Tvariant _ | Tunivar _ | Tpoly _ | Tpackage _ | Tquote _ | Tsplice _ | Tquote_eval _ | Tof_kind _ -> unknown () | Trepr _ -> Misc.fatal_error "value_kind_mixed_block_field: Trepr" + end in let (_, num_nodes_visited), kinds = Array.fold_left_map (fun (i, num_nodes_visited) field -> @@ -1231,18 +1244,18 @@ let report_error ppf = function the Jane Street compilers team."; begin match err with | None -> - fprintf ppf "@ Could not find cmi for: %a" Printtyp.type_expr ty + fprintf ppf "@ Could not find cmi for: %a" Printtyp.Doc.type_expr ty | Some err -> fprintf ppf "@ %a" (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> Printtyp.type_expr ppf ty) + ~offender:(fun ppf -> Printtyp.Doc.type_expr ppf ty) env) err end | Sort_without_extension (sort, maturity, ty) -> fprintf ppf "Non-value layout %a detected" Jkind.Sort.format sort; begin match ty with | None -> () - | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.type_expr ty + | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.Doc.type_expr ty end; fprintf ppf ",@ but this requires extension %s, which is not enabled.@ \ @@ -1254,7 +1267,7 @@ let report_error ppf = function fprintf ppf "Non-value layout %a detected" Jkind.Sort.format sort; begin match ty with | None -> () - | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.type_expr ty + | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.Doc.type_expr ty end; let extension, verb, flags = match Language_extension.(is_at_least Layouts Stable), @@ -1274,7 +1287,7 @@ let report_error ppf = function fprintf ppf "Non-value layout %a detected" Jkind.Sort.format sort; begin match ty with | None -> () - | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.type_expr ty + | Some ty -> fprintf ppf " as sort for type@ %a" Printtyp.Doc.type_expr ty end; let extension, verb, flags = match Language_extension.(is_at_least Layouts Stable), @@ -1293,7 +1306,7 @@ let report_error ppf = function | Not_a_sort (env, ty, err) -> fprintf ppf "A representable layout is required here.@ %a" (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> Printtyp.type_expr ppf ty) + ~offender:(fun ppf -> Printtyp.Doc.type_expr ppf ty) env) err | Unsupported_product_in_lazy const -> fprintf ppf @@ -1317,7 +1330,7 @@ let report_error ppf = function layout %a.@ \ @[Hint: if the array contents should not be scanned, annotating@ \ contained abstract types as [mod external] may resolve this error.@]" - Printtyp.type_expr elt_ty + Printtyp.Doc.type_expr elt_ty Jkind.Sort.Const.format const | Opaque_array_non_value { array_type; elt_kinding_failure } -> begin match elt_kinding_failure with @@ -1326,16 +1339,16 @@ let report_error ppf = function "This array operation cannot tell whether %a is an array type,@ \ possibly because it is abstract. In this case, the element type@ \ %a must be a value:@ @\n@[%a@]" - Printtyp.type_expr array_type - Printtyp.type_expr ty + Printtyp.Doc.type_expr array_type + Printtyp.Doc.type_expr ty (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> Printtyp.type_expr ppf ty) + ~offender:(fun ppf -> Printtyp.Doc.type_expr ppf ty) env) err | None -> fprintf ppf "This array operation expects an array type, but %a does not appear@ \ to be one.@ (Hint: it is abstract?)" - Printtyp.type_expr array_type; + Printtyp.Doc.type_expr array_type; end let () = diff --git a/upstream/ocaml_flambda/typing/types.ml b/upstream/ocaml_flambda/typing/types.ml index cc5b6b64a..77853d756 100644 --- a/upstream/ocaml_flambda/typing/types.ml +++ b/upstream/ocaml_flambda/typing/types.ml @@ -162,7 +162,7 @@ and type_desc = | Tunivar of { name : string option; jkind : jkind_lr } | Tpoly of type_expr * type_expr list | Trepr of type_expr * Jkind_types.Sort.univar list - | Tpackage of Path.t * (Longident.t * type_expr) list + | Tpackage of package | Tof_kind of jkind_lr and arg_label = @@ -174,6 +174,10 @@ and arg_label = and arrow_desc = arg_label * Mode.Alloc.lr * Mode.Alloc.lr +and package = + { pack_path : Path.t; + pack_cstrs : (string list * type_expr) list } + and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; @@ -187,13 +191,14 @@ and fixed_explanation = | Rigid | Fixed_existential 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 @@ -340,18 +345,25 @@ and method_privacy = 0 <= may_pos <= pos 0 <= may_weak <= may_neg <= neg 0 <= inj + may_pos/may_neg mean possible positive/negative occurrences; + thus, may_pos + may_neg = invariant Additionally, the following implications are valid pos => inj neg => inj Examples: - type 'a t : may_pos + may_neg + may_weak + type 'a t : may_pos + may_neg + type +'a t : may_pos + type -'a t : may_neg + type +-'a t : null (no occurrence of 'a assured) + type !'a t : may_pos + may_neg + inj + type +!'a t : may_pos + inj + type -!'a t : may_neg + inj + type +-!'a t : inj 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 *) @@ -377,6 +389,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 = @@ -816,32 +829,6 @@ end include Make_wrapped(struct type 'a t = 'a end) -(* 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: constructor_argument list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: tag; (* Tag for heap blocks *) - cstr_repr: variant_representation; (* Repr of the outer variant *) - cstr_shape: constructor_representation; (* Repr of the constructor itself *) - cstr_constant: bool; - (* True if it's the constructor of a non-[@@unboxed] variant with 0 bits of - payload. (Or equivalently, if it's represented as either a tagged int or - the null pointer) *) - 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; - } - let equal_tag t1 t2 = match (t1, t2) with | Ordinary {src_index=i1}, Ordinary {src_index=i2} -> @@ -966,48 +953,6 @@ let equal_record_representation r1 r2 = match r1, r2 with let equal_record_unboxed_product_representation r1 r2 = match r1, r2 with | Record_unboxed_product, Record_unboxed_product -> true -let may_equal_constr c1 c2 = - c1.cstr_arity = c2.cstr_arity - && (match c1.cstr_tag,c2.cstr_tag with - | Extension _, Extension _ -> - (* extension constructors may be rebindings of each other *) - true - | tag1, tag2 -> - equal_tag tag1 tag2) - -type 'a gen_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: mutability; (* Is this a mutable field? *) - lbl_modalities: Mode.Modality.Const.t;(* Modalities on the field *) - lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) - lbl_pos: int; (* Position in type *) - lbl_all: 'a gen_label_description array; (* All the labels in this type *) - lbl_repres: 'a; (* Representation for outer record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - lbl_uid: Uid.t; - } - -type label_description = record_representation gen_label_description - -type unboxed_label_description = - record_unboxed_product_representation gen_label_description - -type _ record_form = - | Legacy : record_representation record_form - | Unboxed_product : record_unboxed_product_representation record_form - -type record_form_packed = - | P : _ record_form -> record_form_packed - -let record_form_to_string (type rep) (record_form : rep record_form) = - match record_form with - | Legacy -> "record" - | Unboxed_product -> "unboxed record" - let rec mixed_block_element_of_const_sort (sort : Jkind_types.Sort.Const.t) = match sort with | Base Scannable -> Scannable @@ -1351,7 +1296,7 @@ let best_effort_compare_type_expr te1 te2 = | Tfield (_, _, _, _) | Tnil | Tvariant _ - | Tpackage (_, _) + | Tpackage _ | Tarrow (_, _, _, _) | Tquote _ | Tsplice _ @@ -1622,8 +1567,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 ****) @@ -1631,13 +1575,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 *) (**********************************) diff --git a/upstream/ocaml_flambda/typing/types.mli b/upstream/ocaml_flambda/typing/types.mli index a02c9d12f..62d24ae65 100644 --- a/upstream/ocaml_flambda/typing/types.mli +++ b/upstream/ocaml_flambda/typing/types.mli @@ -262,8 +262,7 @@ and type_desc = [Trepr (Tpoly ('a -> 'b, ['a; 'b]), [s1; s2])] where [s1] and [s2] are sort univars that appear in the jkinds of ['a] and ['b] respectively. *) - - | Tpackage of Path.t * (Longident.t * type_expr) list + | Tpackage of package (** Type of a first-class module (a.k.a package). *) | Tof_kind of jkind_lr @@ -287,7 +286,10 @@ and arg_label = and arrow_desc = arg_label * Mode.Alloc.lr * Mode.Alloc.lr - +(** [package] corresponds to the type of a first-class module *) +and package = + { pack_path : Path.t; + pack_cstrs : (string list * type_expr) list } (** See also documentation for [row_more], which enumerates how these constructors arise. *) @@ -554,12 +556,9 @@ 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 *) @@ -700,12 +699,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 @@ -761,6 +763,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 @@ -1233,40 +1236,12 @@ include Wrapped with type 'a wrapped = 'a 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: constructor_argument list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: tag; (* Tag for heap blocks *) - cstr_repr: variant_representation; (* Repr of the outer variant *) - cstr_shape: constructor_representation; (* Repr of the constructor itself *) - cstr_constant: bool; (* True if all args are void *) - 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; - (* [Some decl] here iff the cstr has an inline record (which is decl) *) - cstr_uid: Uid.t; - } - (* Constructors are the same *) val equal_tag : tag -> tag -> bool (* Comparison of tags to store them in sets. *) val compare_tag : tag -> tag -> int -(* Constructors may be the same, given potential rebinding *) -val may_equal_constr : - constructor_description -> constructor_description -> bool - (* Equality *) val equal_record_representation : @@ -1278,44 +1253,6 @@ val equal_record_unboxed_product_representation : val equal_variant_representation : variant_representation -> variant_representation -> bool -type 'a gen_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: mutability; (* Is this a mutable field? *) - lbl_modalities: Mode.Modality.Const.t; - (* Modalities on the field *) - lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) - lbl_pos: int; (* Position in type *) - lbl_all: 'a gen_label_description array; (* All the labels in this type *) - lbl_repres: 'a; (* Representation for outer record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - lbl_uid: Uid.t; - } - -type label_description = record_representation gen_label_description - -type unboxed_label_description = record_unboxed_product_representation gen_label_description - -(** This type tracks the distinction between legacy records ([{ field }]) and unboxed - records ([#{ field }]). Note that [Legacy] includes normal boxed records, as well as - inlined and [[@@unboxed]] records. - - As a GADT, it also lets us avoid duplicating functions that handle both record forms, - such as [Env.find_label_by_name], which has type - ['rep record_form -> Longident.t -> Env.t -> 'rep gen_label_description]. -*) -type _ record_form = - | Legacy : record_representation record_form - | Unboxed_product : record_unboxed_product_representation record_form - -type record_form_packed = - | P : _ record_form -> record_form_packed - -val record_form_to_string : _ record_form -> string - val mixed_block_element_of_const_sort : Jkind_types.Sort.Const.t -> mixed_block_element diff --git a/upstream/ocaml_flambda/typing/typetexp.ml b/upstream/ocaml_flambda/typing/typetexp.ml index a9c20dde9..9856a55fc 100644 --- a/upstream/ocaml_flambda/typing/typetexp.ml +++ b/upstream/ocaml_flambda/typing/typetexp.ml @@ -89,6 +89,7 @@ type error = | Method_mismatch of string * type_expr * type_expr | Opened_object of Path.t option | Not_an_object of type_expr + | Repeated_tuple_label of string | Unsupported_extension : _ Language_extension.t -> error | Polymorphic_optional_param | Non_value of @@ -160,7 +161,7 @@ module TyVarEnv : sig val is_in_scope : string -> bool - val add : string -> type_expr -> jkind_lr -> Env.stage -> unit + val add : ?unused:bool ref -> string -> type_expr -> jkind_lr -> Env.stage -> unit (* add a global type variable to the environment, with the given jkind. Precondition: the [type_expr] must be a [Tvar] with the given jkind. *) @@ -234,7 +235,7 @@ module TyVarEnv : sig Note [Global type variables]. *) val remember_used : - rigid:jkind_lr option + ?check:Location.t -> rigid:jkind_lr option -> string -> type_expr -> Location.t -> Env.stage -> unit (* Remember that a given name is bound to a given type. @@ -262,7 +263,8 @@ end = struct we started processing the current type. See Note [Global type variables]. *) let type_variables = - ref (TyVarMap.empty : (type_expr * jkind_lr * Env.stage) TyVarMap.t) + ref (TyVarMap.empty : + (type_expr * bool ref * jkind_lr * Env.stage) TyVarMap.t) (* These are variables that have been used in the currently-being-checked type, possibly including the variables in [type_variables]. @@ -270,6 +272,7 @@ end = struct type used_info = { ty : type_expr; loc : Location.t; + unused : bool ref; (* Rigid variables are set at a given jkind. Note that a rigid variable can still be unified; if it's unified @@ -277,7 +280,7 @@ end = struct the final expression checks against the rigid jkind. *) rigid : jkind_lr option; - stage : Env.stage + stage : Env.stage; } let used_variables = @@ -296,9 +299,9 @@ end = struct let is_in_scope name = TyVarMap.mem name !type_variables - let add name v jkind stage = + let add ?(unused = ref false) name v jkind stage = assert (not_generic v); - type_variables := TyVarMap.add name (v, jkind, stage) !type_variables + type_variables := TyVarMap.add name (v, unused, jkind, stage) !type_variables let narrow () = (increase_global_level (), !type_variables) @@ -315,11 +318,12 @@ end = struct (* throws Not_found if the variable is not in scope *) let lookup_global name = - let (type_expr, _, stage) = TyVarMap.find name !type_variables in + let (type_expr, unused, _, stage) = TyVarMap.find name !type_variables in + unused := false; (type_expr, stage) let lookup_global_jkind name = - snd3 (TyVarMap.find name !type_variables) + thd4 (TyVarMap.find name !type_variables) let get_in_scope_names () = let add_name name _ l = @@ -506,19 +510,33 @@ end = struct p.univar, s with Not_found -> let info = TyVarMap.find name !used_variables in + info.unused := false; instance info.ty, info.stage (* This call to instance might be redundant; all variables inserted into [used_variables] are non-generic, but some might get generalized. *) - let remember_used ~rigid name v loc stage = + let remember_used ?check ~rigid name v loc stage = assert (not_generic v); let rigid = match TyVarMap.find name !used_variables with | info -> info.rigid | exception Not_found -> rigid in - let info = { ty = v; loc; rigid; stage } in + let unused = match check with + | Some check_loc + when Warnings.(is_active (Unused_type_declaration ("", Alias))) -> + let unused = ref true in + !Env.add_delayed_check_forward begin fun () -> + let warn = Warnings.(Unused_type_declaration ("'" ^ name, Alias)) + in + if !unused && Warnings.is_active warn + then Location.prerr_warning check_loc warn + end; + unused + | _ -> ref false + in + let info = { ty = v; unused; loc; rigid; stage } in used_variables := TyVarMap.add name info !used_variables @@ -581,7 +599,7 @@ end = struct { flavor; unbound_variable_policy; _ } env = let r = ref [] in TyVarMap.iter - (fun name { ty; rigid; loc; stage = s } -> + (fun name { ty; unused; rigid; loc; stage = s } -> (match rigid with | Some original_jkind -> check_jkind env loc name ty { original_jkind; defaulted = false } @@ -589,23 +607,28 @@ end = struct if flavor = Unification || is_in_scope name then let v = new_global_var (Jkind.Builtin.any ~why:Dummy_jkind) in let snap = Btype.snapshot () in - if try unify env v ty; true with _ -> Btype.backtrack snap; false - then try - let (type_expr, stage) = lookup_global name in + if try unify env v ty; true + with + Unify err when is_in_scope name -> + raise (Error(loc, env, Type_mismatch err)) + | _ -> Btype.backtrack snap; false + then match lookup_global name with + | type_expr, stage -> if s <> stage then raise (Error (loc, env, (Invalid_variable_stage {name = Pprintast.tyvar_of_name name; intro_stage = stage; usage_stage = s}))); - r := (loc, v, type_expr) :: !r - with Not_found -> + r := (loc, v, type_expr) :: !r; + unused := false + | exception Not_found -> match unbound_variable_policy, Btype.is_Tvar ty with | Open, _ | (Closed | Closed_for_upstream_compatibility), false -> let jkind = Jkind.Builtin.any ~why:Dummy_jkind in let v2 = new_global_var jkind in r := (loc, v, v2) :: !r; - add name v2 jkind s; + add ~unused name v2 jkind s; | Closed, true -> raise(Error(loc, env, Unbound_type_variable (Pprintast.tyvar_of_name name, @@ -635,7 +658,7 @@ 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 + if Longident.same s1.txt s2.txt then raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); compare s1.txt s2.txt) l @@ -659,6 +682,10 @@ let newvar ?name jkind = let valid_tyvar_name name = name <> "" && name.[0] <> '_' +let check_tyvar_name env loc name = + if not (valid_tyvar_name name) then + raise (Error (loc, env, Invalid_variable_name ("'" ^ name))) + let transl_type_param_var env loc attrs name_opt (jkind : jkind_lr) jkind_annot = let tvar = Ttyp_var (name_opt, jkind_annot) in @@ -666,8 +693,7 @@ let transl_type_param_var env loc attrs name_opt match name_opt with | None -> "_" | Some name -> - if not (valid_tyvar_name name) then - raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + check_tyvar_name Env.empty loc name; if TyVarEnv.is_in_scope name then raise Already_bound; name @@ -912,6 +938,9 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = ctyp desc typ | Ptyp_unboxed_tuple stl -> Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; + assert (List.length stl >= 2); + Option.iter (fun l -> raise (Error (loc, env, Repeated_tuple_label l))) + (Misc.repeated_label stl); let tl = List.map (fun (label, t) -> @@ -985,7 +1014,7 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = let unboxed_lid : Longident.t = match lid.txt with | Lident s -> Lident (s ^ "#") - | Ldot (l, s) -> Ldot (l, s ^ "#") + | Ldot (l, s) -> Ldot (l, { s with txt = s.txt ^ "#" }) | Lapply _ -> fatal_error "Typetexp.transl_type" in match Env.find_type_by_name unboxed_lid env with @@ -1171,40 +1200,18 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = Language_extension.Alpha; Env.check_no_open_quotations loc env Layout_polymorphism_qt; raise (Error (loc, env, Lpoly_unsupported)) - | Ptyp_package (p, l) -> - (* CR layouts: right now we're doing a real gross hack where we demand - everything in a package type with constraint be value. - - An alternative is to walk into the constrained module, using the - longidents, and find the actual things that need jkind checking. - See [Typemod.package_constraints_sig] for code that does a - similar traversal from a longident. - *) - (* CR layouts: and in the long term, rewrite all of this to eliminate - the [create_package_mty] hack that constructs fake source code. *) - 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 Alloc.Const.legacy 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)) + | Ptyp_package ptyp -> + let path, mty, ptys = transl_package env ~policy ~row_context ptyp in + let ty = newty (Tpackage { + pack_path = path; + pack_cstrs = List.map (fun (s, cty) -> + (Longident.flatten s.txt, cty.ctyp_type)) ptys}) in ctyp (Ttyp_package { - pack_path = path; - pack_type = mty; - pack_fields = ptys; - pack_txt = p; + tpt_path = path; + tpt_type = mty; + tpt_cstrs = ptys; + tpt_txt = ptyp.ppt_path; }) ty | Ptyp_open (mod_ident, t) -> let path, new_env = @@ -1236,8 +1243,7 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = and transl_type_var env ~policy ~row_context attrs loc name jkind_annot_opt = let print_name = "'" ^ name in - if not (valid_tyvar_name name) then - raise (Error (loc, env, Invalid_variable_name print_name)); + check_tyvar_name env loc name; let of_annot = jkind_of_annotation env (Type_variable print_name) attrs in let ty, stage = try TyVarEnv.lookup_local ~row_context name @@ -1274,7 +1280,7 @@ and transl_type_var env ~policy ~row_context attrs loc name jkind_annot_opt = and transl_type_poly env ~policy ~row_context mode loc vars st = let typed_vars, new_univars, cty = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let vars = List.map (fun (n, v) -> (n, v, Env.stage env)) vars in let new_univars = transl_bound_vars env vars in let typed_vars = TyVarEnv.ttyp_poly_arg new_univars in @@ -1283,7 +1289,7 @@ and transl_type_poly env ~policy ~row_context mode loc vars st = end in (typed_vars, new_univars, cty) end - ~post:(fun (_,_,cty) -> generalize_ctyp cty) + ~before_generalize:(fun (_,_,cty) -> generalize_ctyp cty) in let ty = cty.ctyp_type in let ty_list = TyVarEnv.check_poly_univars env loc new_univars in @@ -1294,7 +1300,7 @@ and transl_type_poly env ~policy ~row_context mode loc vars st = and transl_type_repr env ~policy ~row_context mode loc vars st = let sort_vars, new_univars, cty = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let vars_with_stage = List.map (fun var -> var, Env.stage env) vars in let sort_vars, new_univars = TyVarEnv.make_repr_univars vars_with_stage in let cty = TyVarEnv.with_univars new_univars begin fun () -> @@ -1302,7 +1308,7 @@ and transl_type_repr env ~policy ~row_context mode loc vars st = end in (sort_vars, new_univars, cty) end - ~post:(fun (_, _, cty) -> generalize_ctyp cty) + ~before_generalize:(fun (_, _, cty) -> generalize_ctyp cty) in let ty = cty.ctyp_type in let ty_list = TyVarEnv.check_poly_univars env loc new_univars in @@ -1334,6 +1340,7 @@ and transl_type_alias env ~row_context ~policy mode attrs styp_loc styp name_opt let cty, jkind_annot = match name_opt with | Some { txt = alias; loc = alias_loc } -> begin try + check_tyvar_name env alias_loc alias; let t, _ = TyVarEnv.lookup_local ~row_context alias in let cty = transl_type env ~policy ~aliased:true ~row_context mode styp @@ -1359,13 +1366,14 @@ and transl_type_alias env ~row_context ~policy mode attrs styp_loc styp name_opt cty, jkind_annot with Not_found -> let t, ty, jkind_annot = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let jkind, rigid = jkind_for_fresh_var env alias alias_loc attrs jkind_annot_opt in let t = newvar jkind in (* Use the whole location, which is used by [Type_mismatch]. *) - TyVarEnv.remember_used ~rigid alias t styp_loc (Env.stage env); + TyVarEnv.remember_used ~check:alias_loc ~rigid + alias t styp_loc (Env.stage env); let ty = transl_type env ~policy ~row_context mode styp in begin try unify_var env t ty.ctyp_type with Unify err -> let err = Errortrace.swap_unification_error err in @@ -1373,7 +1381,6 @@ and transl_type_alias env ~row_context ~policy mode attrs styp_loc styp name_opt end; (t, ty, jkind_annot_opt) end - ~post: (fun (t, _, _) -> generalize_structure t) in let t = instance t in let px = Btype.proxy t in @@ -1410,13 +1417,12 @@ and transl_type_alias env ~row_context ~policy mode attrs styp_loc styp name_opt and transl_type_aux_tuple env ~loc ~policy ~row_context stl = assert (List.length stl >= 2); + Option.iter (fun l -> raise (Error (loc, env, Repeated_tuple_label l))) + (Misc.repeated_label stl); let ctys = List.map - (fun (label, t) -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - label; - label, transl_type env ~policy ~row_context Alloc.Const.legacy t) + (fun (l, t) -> + l, transl_type env ~policy ~row_context Alloc.Const.legacy t) stl in List.iter (fun (_, {ctyp_type; ctyp_loc}) -> @@ -1515,6 +1521,35 @@ and transl_fields env ~policy ~row_context o fields = newty (Tfield (s, field_public, ty', ty))) ty_init fields in ty, object_fields +and transl_package env ~policy ~row_context ptyp = + (* CR layouts: right now we're doing a real gross hack where we demand + everything in a package type with constraint be value. + + An alternative is to walk into the constrained module, using the + longidents, and find the actual things that need jkind checking. + See [Typemod.package_constraints_sig] for code that does a + similar traversal from a longident. + *) + (* CR layouts: and in the long term, rewrite all of this to eliminate + the [create_package_mty] hack that constructs fake source code. *) + let loc = ptyp.ppt_loc in + let l = sort_constraints_no_duplicates loc env ptyp.ppt_cstrs in + let mty = Ast_helper.Mty.mk ~loc (Pmty_ident ptyp.ppt_path) 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 Alloc.Const.legacy 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 ptyp.ppt_path.txt in + path, mty, ptys + (* 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 @@ -1561,12 +1596,13 @@ 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 Alloc.Const.legacy styp in TyVarEnv.globalize_used_variables policy env (); typ end + ~before_generalize:generalize_ctyp end in make_fixed_univars typ.ctyp_type; { typ with ctyp_type = @@ -1575,7 +1611,7 @@ let transl_simple_type_univars env styp = let transl_simple_type_delayed env mode styp = TyVarEnv.reset_locals (); let typ, force = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let policy = TyVarEnv.make_policy Open Any in let typ = transl_type env policy mode styp in make_fixed_univars typ.ctyp_type; @@ -1586,17 +1622,17 @@ let transl_simple_type_delayed env mode styp = (typ, force) end (* Generalize everything except the variables that were just globalized. *) - ~post:(fun (typ,_) -> generalize_ctyp typ) + ~before_generalize:(fun (typ,_) -> generalize_ctyp typ) in (typ, instance typ.ctyp_type, force) let transl_type_scheme_mono env styp = let typ = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> TyVarEnv.reset (); transl_simple_type ~new_var_jkind:Sort env ~closed:false Alloc.Const.legacy styp end - ~post:generalize_ctyp + ~before_generalize:generalize_ctyp in (* This next line is very important: it stops [val] and [external] declarations from having undefaulted jkind variables. Without @@ -1607,7 +1643,7 @@ let transl_type_scheme_mono env styp = let transl_type_scheme_poly env attrs loc vars inner_type = let typed_vars, univars, typ = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> TyVarEnv.reset (); let vars = List.map (fun (n, jkind) -> (n, jkind, Env.stage env)) vars in let univars = transl_bound_vars env vars in @@ -1623,7 +1659,7 @@ let transl_type_scheme_poly env attrs loc vars inner_type = in (typed_vars, univars, typ) end - ~post:(fun (_,_,typ) -> generalize_ctyp typ) + ~before_generalize:(fun (_,_,typ) -> generalize_ctyp typ) in let _ : _ list = TyVarEnv.instance_poly_univars env loc univars in remove_mode_and_jkind_variables typ.ctyp_type; @@ -1711,110 +1747,120 @@ let transl_type_scheme env styp = (* Error report *) open Format_doc -open Printtyp +open Printtyp.Doc module Style = Misc.Style let pp_tag ppf t = fprintf ppf "`%s" t -let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty +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_unbound_variable_reason ppf = function +let report_unbound_variable_reason = function | Some Upstream_compatibility -> - fprintf ppf "@.Hint: Explicit quantification requires quantifying all \ + [Location.msg "Hint: Explicit quantification requires quantifying all \ type variables for compatibility with upstream OCaml.\n\ - Enable non-erasable extensions to disable this check." - | None -> () + Enable non-erasable extensions to disable this check."] + | None -> [] -let report_error_doc env ppf = - function +let report_error_doc loc env = function | Unbound_type_variable (name, in_scope_names, reason) -> - 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 ); - report_unbound_variable_reason ppf reason + Location.aligned_error_hint ~loc + "@{The type variable @}%a is unbound in this type declaration." + Style.inline_code name + (Misc.did_you_mean (Misc.spellcheck in_scope_names name)) + ~sub:(report_unbound_variable_reason reason) | No_type_wildcards reason -> - fprintf ppf "A type wildcard %a is not allowed in this type declaration." - Style.inline_code "_"; - report_unbound_variable_reason ppf reason + Location.errorf ~loc + "A type wildcard %a is not allowed in this type declaration." + Style.inline_code "_" + ~sub:(report_unbound_variable_reason reason) | Undefined_type_constructor p -> - fprintf ppf "The type constructor@ %a@ is not yet completely defined" - (Style.as_inline_code path) p + Location.errorf ~loc + "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 + Location.errorf ~loc + "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" + Location.errorf ~loc "Already bound type parameter %a" (Style.as_inline_code Pprintast.Doc.tyvar) name | Recursive_type -> - fprintf ppf "This type is recursive" + Location.errorf ~loc "This type is recursive" | Type_mismatch trace -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf env trace - (msg "This type") - (msg "should be an instance of type") + Location.errorf ~loc "%t" @@ fun ppf -> + Errortrace_report.unification ppf env trace + (msg "This type") + (msg "should be an instance of type") | Alias_type_mismatch trace -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf Env.empty trace - (msg "This alias is bound to type") - (msg "but is used as an instance of type") + Location.errorf ~loc "%t" @@ fun ppf -> + 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" + Location.errorf ~loc "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@ \ + Location.errorf ~loc + "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.@]@]" + but is present in@ its lower bound (after %a)." (Style.as_inline_code pp_tag) l Style.inline_code "<" Style.inline_code ">" Style.inline_code ">" - (Style.as_inline_code pp_tag) l + ~sub:[ + Location.msg + "@{Hint@}: Either add %a in the upper bound,@ \ + or@ remove@ it@ from the lower bound." + (Style.as_inline_code pp_tag) l + ] | Constructor_mismatch (ty, ty') -> wrap_printing_env ~error:true env (fun () -> - Printtyp.prepare_for_printing [ty; ty']; - fprintf ppf "@[%s %a@ %s@ %a@]" - "This variant type contains a constructor" - pp_type (tree_of_typexp Type ty) - "which should be" - pp_type (tree_of_typexp Type ty')) + Out_type.prepare_for_printing [ty; ty']; + Location.errorf ~loc + "This variant type contains a constructor %a@ \ + which should be@ %a" + pp_out_type (Out_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; - begin match get_desc ty with + Location.aligned_error_hint ~loc + "@{The type @}%a@ does not expand to a polymorphic variant type" + pp_type ty + begin match get_desc ty with | Tvar { name = Some s } -> (* PR#7012: help the user that wrote 'Foo instead of `Foo *) - Misc.did_you_mean ppf (fun () -> ["`" ^ s]) - | _ -> () - end + Misc.did_you_mean ["`" ^ s] + | _ -> None + end | Variant_tags (lab1, lab2) -> - fprintf ppf - "@[Variant tags %a@ and %a have the same hash value.@ %s@]" + Location.errorf ~loc + "Variant tags %a@ and %a have the same hash value.@ \ + Change one of them." (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" + Location.errorf ~loc + "The type variable name %a is not allowed in programs" Style.inline_code name | Cannot_quantify (name, reason) -> - fprintf ppf - "@[The universal type variable %a cannot be generalized:@ " - (Style.as_inline_code Pprintast.Doc.tyvar) name; - begin match reason with - | Unified v -> - fprintf ppf "it is bound to@ %a" - (Style.as_inline_code Printtyp.type_expr) v; - | Univar -> - fprintf ppf "it is already bound to another variable" - | Scope_escape -> - fprintf ppf "it escapes its scope" - end; - fprintf ppf ".@]"; + let explanation ppf reason = + match reason with + | Scope_escape -> + fprintf ppf "it escapes its scope." + | Univar -> + fprintf ppf "it is already bound to another variable." + | Unified v -> + fprintf ppf "it is bound to@ %a." pp_type v + in + Location.errorf ~loc + "The universal type variable %a cannot be generalized:@ %a" + (Style.as_inline_code Pprintast.Doc.tyvar) name + explanation reason | Bad_univar_jkind { name; jkind_info; inferred_jkind } -> - fprintf ppf + Location.errorf ~loc "@[The universal type variable %a was %s to have kind %a.@;%a@]" Pprintast.Doc.tyvar name (if jkind_info.defaulted then "defaulted" else "declared") @@ -1835,7 +1881,7 @@ let report_error_doc env ppf = inferred_jkind))) inferred_jkind | Mismatched_jkind_annotation { name; explicit_jkind; implicit_jkind } -> - fprintf ppf + Location.errorf ~loc "@[The type variable %a has conflicting kind annotations.@;\ It has an explicit annotation %a@ \ but was already implicitly annotated with %a@]" @@ -1843,29 +1889,33 @@ let report_error_doc env ppf = (Jkind.format env) explicit_jkind (Jkind.format env) implicit_jkind | Multiple_constraints_on_type s -> - fprintf ppf "Multiple constraints for type %a" + Location.errorf ~loc "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@]" + Location.errorf ~loc "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 + Location.errorf ~loc "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@]" - (Style.as_inline_code Printtyp.type_expr) ty + Location.errorf ~loc "@[The type %a@ is not an object type@]" + pp_type ty + | Repeated_tuple_label l -> + Location.errorf ~loc "@[This tuple type has two labels named %a@]" + Style.inline_code l | Unsupported_extension ext -> let ext = Language_extension.to_string ext in - fprintf ppf "@[The %s extension is disabled@ \ - To enable it, pass the '-extension %s' flag@]" ext ext + Location.errorf ~loc + "The %s extension is disabled@ \ + To enable it, pass the '-extension %s' flag@]" ext ext | Polymorphic_optional_param -> - fprintf ppf "@[Optional parameters cannot be polymorphic@]" + Location.errorf ~loc "@[Optional parameters cannot be polymorphic@]" | Non_value {vloc; typ; err} -> let s = match vloc with @@ -1873,10 +1923,9 @@ let report_error_doc env ppf = | Poly_variant -> "Polymorphic variant constructor argument" | Object_field -> "Object field" in - fprintf ppf "@[%s types must have layout value.@ %a@]" + Location.errorf ~loc "%s types must have layout value.@ %a" s (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> - Style.as_inline_code Printtyp.type_expr ppf typ) + ~offender:(fun ppf -> pp_type ppf typ) env) err | Non_sort {vloc; typ; err} -> let s = @@ -1884,30 +1933,28 @@ let report_error_doc env ppf = | Fun_arg -> "Function argument" | Fun_ret -> "Function return" in - fprintf ppf "@[%s types must have a representable layout.@ %a@]" + Location.errorf ~loc "%s types must have a representable layout.@ %a" s (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> - Style.as_inline_code Printtyp.type_expr ppf typ) + ~offender:(fun ppf -> pp_type ppf typ) env) err | Bad_jkind_annot(ty, violation) -> - fprintf ppf "@[Bad layout annotation:@ %a@]" + Location.errorf ~loc "@[Bad layout annotation:@ %a@]" (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> - Style.as_inline_code Printtyp.type_expr ppf ty) + ~offender:(fun ppf -> pp_type ppf ty) env) violation | Did_you_mean_unboxed lid -> - fprintf ppf "@[%a isn't a class type.@ \ - Did you mean the unboxed type %a?@]" + Location.errorf ~loc + "%a isn't a class type.@ Did you mean the unboxed type %a?" (Style.as_inline_code longident) lid (Style.as_inline_code (fun ppf lid -> fprintf ppf "%a#" longident lid)) lid | Invalid_label_for_call_pos arg_label -> - fprintf ppf "A position argument must not be %s." + Location.errorf ~loc "A position argument must not be %s." (match arg_label with | Nolabel -> "unlabelled" | Optional _ -> "optional" | Labelled _ -> assert false ) | Invalid_variable_stage {name; intro_stage; usage_stage} -> - fprintf ppf + Location.errorf ~loc "@[@[Type variable %a is used %a,@ \ it already occurs %a.@]@,\ @[@{Hint@}: Consider using %a.@]@]" @@ -1916,7 +1963,7 @@ let report_error_doc env ppf = Env.print_stage intro_stage Env.print_with_quote_promote (name, intro_stage, usage_stage) | Lpoly_unsupported -> - fprintf ppf + Location.errorf ~loc "@[Layout polymorphism is not supported in term-level type \ annotations@]" @@ -1924,11 +1971,9 @@ let () = Location.register_error_of_exn (function | Error (loc, env, err) -> - Some (Location.error_of_printer ~loc (report_error_doc env) err) + Some (report_error_doc loc env err) | Error_forward err -> Some err | _ -> None ) - -let report_error = Format_doc.compat1 report_error_doc diff --git a/upstream/ocaml_flambda/typing/typetexp.mli b/upstream/ocaml_flambda/typing/typetexp.mli index bb6a3b788..943623d4f 100644 --- a/upstream/ocaml_flambda/typing/typetexp.mli +++ b/upstream/ocaml_flambda/typing/typetexp.mli @@ -179,6 +179,7 @@ type error = | Method_mismatch of string * type_expr * type_expr | Opened_object of Path.t option | Not_an_object of type_expr + | Repeated_tuple_label of string | Unsupported_extension : _ Language_extension.t -> error | Polymorphic_optional_param | Non_value of @@ -198,9 +199,6 @@ type error = 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 diff --git a/upstream/ocaml_flambda/typing/uniqueness_analysis.ml b/upstream/ocaml_flambda/typing/uniqueness_analysis.ml index a8de46984..2865e79c0 100644 --- a/upstream/ocaml_flambda/typing/uniqueness_analysis.ml +++ b/upstream/ocaml_flambda/typing/uniqueness_analysis.ml @@ -81,7 +81,7 @@ *) open Asttypes -open Types +open Data_types open Mode open Typedtree module Uniqueness = Mode.Uniqueness @@ -2416,16 +2416,26 @@ let rec check_uniqueness_exp_desc ~borrows ~overwrite (ienv : Ienv.t) ~loc : args in UF.pars (uf_fn :: uf_args) - | Texp_match (arg, _, cases, _) -> + | Texp_match (arg, _, cases, eff_cases, _) -> let value, uf_arg = check_uniqueness_exp_for_match ienv arg in let uf_cases = check_uniqueness_comp_cases ienv value cases in - UF.seq uf_arg uf_cases - | Texp_try (body, cases) -> + let uf_eff_cases = check_uniqueness_cases ienv value eff_cases in + (* CR rtjoa for zqian: uncertain whether this is sound *) + (* Effects can be run multiple times - for uniqueness, this is equivalent to + twice - and can also be run when the non-effect case is run. *) + let uf_all_cases = UF.seqs [uf_eff_cases; uf_eff_cases; uf_cases] in + UF.seq uf_arg uf_all_cases + | Texp_try (body, cases, eff_cases) -> let uf_body = check_uniqueness_exp ~overwrite:None ienv body in let value = Match_single (Paths.fresh ()) in let uf_cases = check_uniqueness_cases ienv value cases in + let uf_eff_cases = check_uniqueness_cases ienv value eff_cases in + (* CR rtjoa for zqian: uncertain whether this is sound *) + (* Effects can be run multiple times - for uniqueness, this is equivalent to + twice - and can also be run when the non-effect case is run. *) + let uf_all_cases = UF.seqs [uf_eff_cases; uf_eff_cases; uf_cases] in (* we don't know how much of e will be run; safe to assume all of them *) - UF.seq uf_body uf_cases + UF.seq uf_body uf_all_cases | Texp_unboxed_unit -> UF.unused | Texp_unboxed_bool _ -> UF.unused | Texp_tuple (es, _) -> diff --git a/upstream/ocaml_flambda/typing/untypeast.ml b/upstream/ocaml_flambda/typing/untypeast.ml index 95066216f..d7ca50f1e 100644 --- a/upstream/ocaml_flambda/typing/untypeast.ml +++ b/upstream/ocaml_flambda/typing/untypeast.ml @@ -89,16 +89,14 @@ Some notes: (** 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 +let rec lident_of_path = + let noloc_lident_of_path p = mknoloc (lident_of_path p) in + function | Path.Pident id -> Longident.Lident (Ident.name id) | Path.Papply (p1, p2) -> - Longident.Lapply (lident_of_path p1, lident_of_path p2) + Longident.Lapply (noloc_lident_of_path p1, noloc_lident_of_path p2) | Path.Pdot (p, s) | Path.Pextra_ty (p, Pcstr_ty s) -> - Longident.Ldot (lident_of_path p, s) + Longident.Ldot (noloc_lident_of_path p, mknoloc s) | Path.Pextra_ty (p, _) -> lident_of_path p let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} @@ -124,25 +122,31 @@ let rec extract_letop_patterns n pat = (** Mapping functions. *) let constant = function - | Const_char c -> Pconst_char c - | Const_untagged_char c -> Pconst_untagged_char c - | Const_string (s,loc,d) -> Pconst_string (s,loc,d) - | Const_int i -> Pconst_integer (Int.to_string i, None) - | Const_int8 i -> Pconst_integer (Int.to_string i, Some 's') - | Const_int16 i -> Pconst_integer (Int.to_string i, Some 'S') - | 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_float32 f -> Pconst_float (f, Some 's') - | Const_unboxed_float f -> Pconst_unboxed_float (f, None) - | Const_unboxed_float32 f -> Pconst_unboxed_float (f, Some 's') - | Const_untagged_int i -> Pconst_unboxed_integer (Int.to_string i, 'm') - | Const_untagged_int8 i -> Pconst_unboxed_integer (Int.to_string i, 's') - | Const_untagged_int16 i -> Pconst_unboxed_integer (Int.to_string i, 'S') - | Const_unboxed_int32 i -> Pconst_unboxed_integer (Int32.to_string i, 'l') - | Const_unboxed_int64 i -> Pconst_unboxed_integer (Int64.to_string i, 'L') - | Const_unboxed_nativeint i -> Pconst_unboxed_integer (Nativeint.to_string i, 'n') + | Const_char c -> Const.char c + | Const_untagged_char c -> Const.mk (Pconst_untagged_char c) + | Const_string (s,loc,d) -> Const.string ?quotation_delimiter:d ~loc s + | Const_int i -> Const.integer (Int.to_string i) + | Const_int8 i -> Const.integer ~suffix:'s' (Int.to_string i) + | Const_int16 i -> Const.integer ~suffix:'S' (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 + | Const_float32 f -> Const.float ~suffix:'s' f + | Const_unboxed_float f -> Const.mk (Pconst_unboxed_float (f, None)) + | Const_unboxed_float32 f -> Const.mk (Pconst_unboxed_float (f, Some 's')) + | Const_untagged_int i -> + Const.mk (Pconst_unboxed_integer (Int.to_string i, 'm')) + | Const_untagged_int8 i -> + Const.mk (Pconst_unboxed_integer (Int.to_string i, 's')) + | Const_untagged_int16 i -> + Const.mk (Pconst_unboxed_integer (Int.to_string i, 'S')) + | Const_unboxed_int32 i -> + Const.mk (Pconst_unboxed_integer (Int32.to_string i, 'l')) + | Const_unboxed_int64 i -> + Const.mk (Pconst_unboxed_integer (Int64.to_string i, 'L')) + | Const_unboxed_nativeint i -> + Const.mk (Pconst_unboxed_integer (Nativeint.to_string i, 'n')) let attribute sub a = { attr_name = map_loc sub a.attr_name; @@ -376,8 +380,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | Tpat_unboxed_bool b -> Ppat_unboxed_bool b | Tpat_tuple list -> Ppat_tuple - ( List.map (fun (label, p) -> label, sub.pat sub p) list - , Closed) + (List.map (fun (label, p) -> label, sub.pat sub p) list, Closed) | Tpat_unboxed_tuple list -> Ppat_unboxed_tuple (List.map (fun (label, p, _) -> label, sub.pat sub p) list, @@ -396,7 +399,10 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> match args with [] -> None | [arg] -> Some (sub.pat sub arg) - | args -> Some (Pat.tuple ~loc (List.map (fun p -> None, sub.pat sub p) args) Closed) + | args -> + Some (Pat.tuple ~loc + (List.map (fun p -> None, sub.pat sub p) args) + Closed) in Ppat_construct (map_loc sub lid, match tyo, arg with @@ -466,7 +472,9 @@ let value_binding sub vb = match pat.ppat_desc with | Ppat_constraint (pat, Some ({ ptyp_desc = Ptyp_poly _; _ } as cty), modes) -> - let constr = Pvc_constraint {locally_abstract_univars = []; typ = cty } in + let constr = + Pvc_constraint { locally_abstract_univars = []; typ = cty } + in pat, Some constr, modes | _ -> pat, None, [] in @@ -623,10 +631,32 @@ let expression sub exp = | Omitted _ -> list | Arg (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_unboxed_unit -> Pexp_unboxed_unit | Texp_unboxed_bool b -> Pexp_unboxed_bool b | Texp_tuple (list, _) -> @@ -730,7 +760,7 @@ let expression sub exp = | Texp_object (cl, _) -> Pexp_object (sub.class_structure sub cl) | Texp_pack (mexpr) -> - Pexp_pack (sub.module_expr sub mexpr) + Pexp_pack (sub.module_expr sub mexpr, None) | Texp_letop {let_; ands; body; _} -> let pat, and_pats = extract_letop_patterns (List.length ands) body.c_lhs @@ -756,7 +786,7 @@ let expression sub exp = Pstr_eval ( { pexp_desc=(Pexp_apply ( { pexp_desc=(Pexp_constant - (Pconst_string(name,loc,None))) + (Const.string ~loc name)) ; pexp_loc=loc ; pexp_loc_stack =[] ; pexp_attributes=[] @@ -776,7 +806,7 @@ let expression sub exp = { pstr_desc= Pstr_eval ( { pexp_desc=(Pexp_constant - (Pconst_string(name,loc,None))) + (Const.string ~loc name)) ; pexp_loc=loc ; pexp_loc_stack =[] ; pexp_attributes=[] @@ -812,9 +842,10 @@ let binding_op sub bop pat = {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) + { ppt_path = map_loc sub pack.tpt_txt; + ppt_cstrs = List.map (fun (s, ct) -> (s, sub.typ sub ct)) pack.tpt_cstrs; + ppt_attrs = []; + ppt_loc = sub.location sub pack.tpt_txt.loc } let module_type_declaration sub mtd = let loc = sub.location sub mtd.mtd_loc in @@ -1068,7 +1099,7 @@ 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_var (None, jkind) -> Ptyp_any jkind + Ttyp_var (None, jkind) -> Ptyp_any jkind | Ttyp_var (Some s, jkind) -> Ptyp_var (s, jkind) | Ttyp_arrow (arg_label, ct1, modes1, ct2, modes2) -> let modes1 = Typemode.untransl_mode modes1 in @@ -1076,10 +1107,10 @@ let core_type sub ct = Ptyp_arrow (label arg_label, sub.typ sub ct1, sub.typ sub ct2, modes1, modes2) | Ttyp_tuple list -> - Ptyp_tuple (List.map (fun (lbl, t) -> lbl, sub.typ sub t) list) + Ptyp_tuple (List.map (fun (l, typ) -> l, sub.typ sub typ) list) | Ttyp_unboxed_tuple list -> Ptyp_unboxed_tuple - (List.map (fun (lbl, t) -> lbl, sub.typ sub t) list) + (List.map (fun (l, typ) -> l, sub.typ sub typ) list) | Ttyp_constr (_path, lid, list) -> Ptyp_constr (map_loc sub lid, List.map (sub.typ sub) list) @@ -1115,7 +1146,7 @@ let core_type sub ct = let class_structure sub cs = let rec remove_self = function | { pat_desc = Tpat_alias { pattern = p; id; _ } } - when string_is_prefix "selfpat-" (Ident.name id) -> + when String.starts_with ~prefix:"selfpat-" (Ident.name id) -> remove_self p | p -> p in @@ -1145,7 +1176,7 @@ let object_field sub {of_loc; of_desc; of_attributes;} = and is_self_pat = function | { pat_desc = Tpat_alias { id; _ } } -> - string_is_prefix "self-" (Ident.name id) + String.starts_with ~prefix:"self-" (Ident.name id) | _ -> false (* [Typeclass] adds a [self] parameter to initializers and methods that isn't diff --git a/upstream/ocaml_flambda/typing/value_rec_check.ml b/upstream/ocaml_flambda/typing/value_rec_check.ml index d2690c0b8..559c59369 100644 --- a/upstream/ocaml_flambda/typing/value_rec_check.ml +++ b/upstream/ocaml_flambda/typing/value_rec_check.ml @@ -158,7 +158,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 @@ -187,17 +187,29 @@ let classify_expression : Typedtree.expression -> sd = | Texp_record _ -> Static + | Texp_variant _ + | Texp_tuple _ + | Texp_atomic_loc _ + | Texp_extension_constructor _ + | Texp_constant _ -> + Static + + | Texp_for _ + | Texp_setfield _ + | Texp_while _ + | Texp_setinstvar _ -> + (* Unit-returning expressions *) + Static + + | Texp_unreachable -> + Static + | Texp_record_unboxed_product { representation = Record_unboxed_product; fields = [| _, Overridden (_,e) |] } -> classify_expression env e | Texp_record_unboxed_product _ -> Dynamic - | Texp_variant _ - | Texp_tuple _ - | Texp_atomic_loc _ - | Texp_extension_constructor _ - | Texp_constant _ | Texp_unboxed_unit | Texp_unboxed_bool _ | Texp_src_pos -> @@ -210,20 +222,10 @@ let classify_expression : Typedtree.expression -> sd = | Texp_hole _ -> Dynamic (* Disallowed for now *) - | Texp_for _ - | Texp_setfield _ - | Texp_while _ - | Texp_setinstvar _ -> - (* Unit-returning expressions *) - Static - | Texp_mutvar _ | Texp_setmutvar _ -> Static - | Texp_unreachable -> - Static - | Texp_probe _ | Texp_probe_is_enabled _ -> (* CR vlaviron: Dynamic would probably be a better choice *) @@ -356,6 +358,8 @@ let classify_expression : Typedtree.expression -> sd = Misc.fatal_error "letrec: primitive coercion on a module" | Tcoerce_alias _ -> Misc.fatal_error "letrec: alias coercion on a module" + | Tcoerce_invalid -> + Misc.fatal_error "letrec: invalid coercion on a module" end | Tmod_unpack (e, _) -> classify_expression env e @@ -664,8 +668,8 @@ let rec expression : Typedtree.expression -> term_judg = value_bindings Nonrecursive [binding] >> 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 ---------------------------------------------- @@ -675,7 +679,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 tf -> (* G1 |- low: m[Dereference] @@ -819,7 +827,7 @@ let rec expression : Typedtree.expression -> term_judg = | Void | Product _ -> Dereference) in - let field (label, field_def) = + let field ((label : Data_types.label_description), field_def) = let env = match field_def with | Kept _ -> empty @@ -962,7 +970,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 -------------------------------------------- @@ -976,6 +984,7 @@ let rec expression : Typedtree.expression -> term_judg = join [ expression e; list case_env cases; + list case_env eff_cases; ] | Texp_override (pth, fields) -> (* @@ -1202,6 +1211,8 @@ and modexp : Typedtree.module_expr -> term_judg = (* Alias coercions ignore their arguments, but they evaluate their alias module 'pth' under another coercion. *) coercion coe (fun m -> path pth << m) + | Tcoerce_invalid -> + Misc.fatal_error "Value_rec_check.modexp: invalid coercion" in coercion coe (fun m -> modexp mexp << m) | Tmod_unpack (e, _) -> diff --git a/upstream/ocaml_flambda/typing/vicuna_traverse_typed_tree.ml b/upstream/ocaml_flambda/typing/vicuna_traverse_typed_tree.ml index cfbb6b052..aa001589e 100644 --- a/upstream/ocaml_flambda/typing/vicuna_traverse_typed_tree.ml +++ b/upstream/ocaml_flambda/typing/vicuna_traverse_typed_tree.ml @@ -72,7 +72,6 @@ let scrape_ty env ty = let ty = match get_desc ty with Tpoly (ty, _) -> ty | _ -> ty in match get_desc ty with | Tconstr _ -> ( - let ty = Ctype.correct_levels ty in let ty' = Ctype.expand_head_opt env ty in match get_desc ty' with | Tconstr (p, _, _) -> ( diff --git a/upstream/ocaml_flambda/utils/ccomp.ml b/upstream/ocaml_flambda/utils/ccomp.ml index 4db4ca19c..c1ed31a2f 100644 --- a/upstream/ocaml_flambda/utils/ccomp.ml +++ b/upstream/ocaml_flambda/utils/ccomp.ml @@ -112,12 +112,11 @@ let compile_file ?output ?(opt="") ?stable_name name = (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 -> "" @@ -225,9 +224,3 @@ let call_linker ?(native_toplevel = false) mode output_name files extra = 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/ocaml_flambda/utils/ccomp.mli b/upstream/ocaml_flambda/utils/ccomp.mli index 5695873a8..d4e0ccee2 100644 --- a/upstream/ocaml_flambda/utils/ccomp.mli +++ b/upstream/ocaml_flambda/utils/ccomp.mli @@ -43,5 +43,3 @@ type link_mode = `link_mode` is `Dll`, but that didn't seem to work. Understand why. *) val call_linker: ?native_toplevel:bool -> link_mode -> string -> string list -> string -> int - -val linker_is_flexlink : bool diff --git a/upstream/ocaml_flambda/utils/clflags.ml b/upstream/ocaml_flambda/utils/clflags.ml index 2237b416f..71249f6a5 100644 --- a/upstream/ocaml_flambda/utils/clflags.ml +++ b/upstream/ocaml_flambda/utils/clflags.ml @@ -79,6 +79,7 @@ and hidden_include_manifests = ref ([] : string list) (* -H-manifest *) and no_std_include = ref false (* -nostdlib *) and no_cwd = ref false (* -nocwd *) and print_types = ref false (* -i *) +and print_variance = ref false (* -i-variance *) and make_archive = ref false (* -a *) and debug = ref false (* -g *) and debug_full = ref false (* For full DWARF support *) @@ -167,8 +168,9 @@ and make_package = ref false (* -pack *) and for_package = ref (None: string option) (* -for-pack *) and error_size = ref 256 (* -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 *) +and no_alias_deps = ref false (* -no-alias-deps *) +let unique_ids = ref true (* -d(no-)unique-ids *) +let canonical_ids = ref false (* -d(no-)canonical-ids *) let locations = ref true (* -d(no-)locations *) let parameters = ref ([] : string list) (* -parameter *) let as_parameter = ref false (* -as-parameter *) @@ -180,6 +182,7 @@ and dump_typedtree = ref false (* -dtypedtree *) and dump_shape = ref false (* -dshape *) and dump_tlambda = ref false (* -dtlambda *) and dump_slambda = ref false (* -dslambda *) +and dump_matchcomp = ref false (* -dmatchcomp *) and dump_rawlambda = ref false (* -drawlambda *) and dump_lambda = ref false (* -dlambda *) and dump_blambda = ref false (* -dblambda *) @@ -194,6 +197,8 @@ and dump_jsir = ref false (* -djsir *) and dump_instr = ref false (* -dinstr *) and keep_camlprimc_file = ref false (* -dcamlprimc *) +let keyword_edition: string option ref = ref None + let keep_asm_file = ref false (* -S *) let optimize_for_speed = ref true (* -compact *) and opaque = ref false (* -opaque *) @@ -233,6 +238,9 @@ let clambda_checks = ref false (* -clambda-checks *) let cmm_invariants = ref Config.with_cmm_invariants (* -dcmm-invariants *) +let parsetree_ghost_loc_invariant = ref false + (* -dparsetree-ghost-loc-invariant *) + let flambda_invariant_checks = let v = if Config.with_flambda_invariants then Light_checks else No_checks in ref v (* -flambda-(no-)invariants *) @@ -253,8 +261,8 @@ let shared = ref false (* -shared *) 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 "" let ocamlrunparam = ref "" @@ -878,6 +886,164 @@ module Register_allocator = struct Format.fprintf ppf "%s" (to_string regalloc) end +module Dump_option = struct + type t = + | Source + | Parsetree + | Typedtree + | Shape + | Match_comp + | Raw_lambda + | Lambda + | Instr + | Raw_clambda + | Clambda + | Raw_flambda + | Flambda + | Cmm + | CSE + | Linear + + 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" + | CSE -> "cse" + | Linear -> "linear" + + 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 + | "cse" -> Some CSE + | "linear" -> Some Linear + | _ -> 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 + | CSE -> dump_cse + | Linear -> dump_linear + + 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 + | CSE + | Linear + -> 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 + +let parse_keyword_edition s = + let parse_version s = + let bad_version () = + raise (Arg.Bad "Ill-formed version in keywords flag,\n\ + the supported format is ., for example 5.2 .") + in + if s = "" then None else match String.split_on_char '.' s with + | [] | [_] | _ :: _ :: _ :: _ -> bad_version () + | [major;minor] -> match int_of_string_opt major, int_of_string_opt minor with + | Some major, Some minor -> Some (major,minor) + | _ -> bad_version () + in + match String.split_on_char '+' s with + | [] -> None, [] + | [s] -> parse_version s, [] + | v :: rest -> parse_version v, rest + module String = Misc.Stdlib.String let arg_spec = ref [] diff --git a/upstream/ocaml_flambda/utils/clflags.mli b/upstream/ocaml_flambda/utils/clflags.mli index ec10911e1..d1d8c5609 100644 --- a/upstream/ocaml_flambda/utils/clflags.mli +++ b/upstream/ocaml_flambda/utils/clflags.mli @@ -146,6 +146,7 @@ val use_prims : string ref val use_runtime : string ref val plugin : bool ref val principal : bool ref +val print_variance : bool ref val real_paths : bool ref val recursive_types : bool ref val strict_sequence : bool ref @@ -159,8 +160,9 @@ 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 no_alias_deps : bool ref val unique_ids : bool ref +val canonical_ids : bool ref val locations : bool ref val parameters : string list ref val as_parameter : bool ref @@ -172,6 +174,7 @@ val dump_typedtree : bool ref val dump_shape : bool ref val dump_tlambda : bool ref val dump_slambda : bool ref +val dump_matchcomp : bool ref val dump_rawlambda : bool ref val dump_lambda : bool ref val dump_blambda : bool ref @@ -244,6 +247,7 @@ 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 parsetree_ghost_loc_invariant : bool ref val default_inline_max_depth : int val inline_max_depth : Int_arg_helper.parsed ref val remove_unused_arguments : bool ref @@ -272,6 +276,9 @@ val dump_into_file : bool ref val dump_into_csv : bool ref val dump_dir : string option ref +val keyword_edition: string option ref +val parse_keyword_edition: string -> (int*int) option * string list + (* Support for flags that can also be set from an environment variable *) type 'a env_reader = { parse : string -> 'a option; @@ -335,6 +342,7 @@ module Compiler_pass : sig 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 @@ -357,6 +365,35 @@ end val is_flambda2 : unit -> 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 + | CSE + | Linear + + 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/ocaml_flambda/utils/compression.ml b/upstream/ocaml_flambda/utils/compression.ml index 384afb3b4..e69de29bb 100644 --- a/upstream/ocaml_flambda/utils/compression.ml +++ b/upstream/ocaml_flambda/utils/compression.ml @@ -1,31 +0,0 @@ -(**************************************************************************) -(* *) -(* 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_flambda/utils/compression.mli b/upstream/ocaml_flambda/utils/compression.mli index bdfb63da7..e69de29bb 100644 --- a/upstream/ocaml_flambda/utils/compression.mli +++ b/upstream/ocaml_flambda/utils/compression.mli @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* 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_flambda/utils/config.mli b/upstream/ocaml_flambda/utils/config.mli index bd44215db..c0d4bdafc 100644 --- a/upstream/ocaml_flambda/utils/config.mli +++ b/upstream/ocaml_flambda/utils/config.mli @@ -60,21 +60,17 @@ val objcopy : string (** The objcopy command (and flags) to use for split debug enabled by [Clflags.dwarf_fission]. *) -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 *) @@ -82,9 +78,21 @@ val bytecomp_c_libraries: string val native_c_libraries: string (** The C libraries to link with native-code programs *) +val compression_c_libraries: string +(** The C libraries needed with -lcomprmarsh (should appear before + {!native_c_libraries} in a call to the C compiler) + + @since 5.4 *) + val native_ldflags : string (* Flags to pass to the system linker *) +val with_nonexecstack_note : bool +(** Whether an explicit ".note.GNU-stack" section is to be added to indicate + the stack should not be executable + + @since 5.4 *) + val native_pack_linker: string (** The linker to use for packaging (ocamlopt -pack) and for partial links (ocamlopt -output-obj). *) @@ -192,6 +200,12 @@ val model: string val system: string (** Name of operating system for the native-code compiler *) +val target_os_type: string +(** Operating system targetted by the native-code compiler. One of +- ["Unix"] (for all Unix versions, including Linux and macOS), +- ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or MinGW-w64), +- ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *) + val asm: string (** The assembler (and flags) to use for assembling ocamlopt-generated code. *) @@ -199,6 +213,11 @@ val asm: string val asm_cfi_supported: bool (** Whether assembler understands CFI directives *) +val asm_size_type_directives: bool +(** Whether the [.size] and [.type] assembler directives can be used + + @since 5.4 *) + val with_frame_pointers : bool (** Whether assembler should maintain frame pointers *) @@ -267,6 +286,9 @@ val with_flambda_invariants : bool val with_cmm_invariants : bool (** Whether the invariants checks for Cmm are enabled *) +val with_codegen_invariants : bool +(** Whether the invariant checks for native code generation are enabled. *) + val reserved_header_bits : int (** How many bits of a block's header are reserved. This is correct regardless of whether we're in runtime 4 or runtime 5. @@ -284,6 +306,13 @@ val flat_float_array : bool (** Whether the compiler and runtime automagically flatten float arrays *) +val align_double : bool +(** Whether the compiler and runtime need to align double values. + If [false], a [floatarray] value can be cast to a C array of doubles. *) + +val align_int64 : bool +(** Whether the compiler and runtime need to align int64 values *) + val function_sections : bool (** Whether the compiler was configured to generate each function in a separate section *) diff --git a/upstream/ocaml_flambda/utils/diffing.ml b/upstream/ocaml_flambda/utils/diffing.ml index ca3a08d62..f2c336d9c 100644 --- a/upstream/ocaml_flambda/utils/diffing.ml +++ b/upstream/ocaml_flambda/utils/diffing.ml @@ -347,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/upstream/ocaml_flambda/utils/format_doc.ml b/upstream/ocaml_flambda/utils/format_doc.ml index e2aaaf555..9b4875cdf 100644 --- a/upstream/ocaml_flambda/utils/format_doc.ml +++ b/upstream/ocaml_flambda/utils/format_doc.ml @@ -251,6 +251,82 @@ module Doc = struct let msg fmt = kmsg Fun.id fmt + + let ralign_tag = Format.String_tag "ralign" + + let rec split_on_open_tag tag rbefore = function + | [] -> rbefore, [] + | Open_tag t :: rest when t = tag -> + rbefore, rest + | elt :: rest -> + split_on_open_tag tag (elt::rbefore) rest + + let rec split_on_close opened rbefore = function + | [] -> rbefore, [] + | Open_tag _ as elt :: rest -> + split_on_close (opened+1) (elt::rbefore) rest + | Close_tag as elt :: rest -> + if opened = 0 then rbefore, rest + else split_on_close (opened-1) (elt::rbefore) rest + | elt :: rest -> + split_on_close opened (elt::rbefore) rest + + let rec approx_len acc = function + | [] -> Some acc + | Text x :: r-> + let len = Format.utf_8_scalar_width ~pos:0 ~len:(String.length x) x in + approx_len (acc + len) r + | With_size n :: Text _ :: r -> approx_len (acc + n) r + | (Open_box _ | Close_box | Open_tag _ | Close_tag + | Open_tbox | Close_tbox | Set_tab | With_size _ + ) :: r -> + approx_len acc r + | (Tab_break _ | Break _ | Simple_break _ | Flush _ | Newline | If_newline + | Deprecated _ ) :: _ -> + None + + type ralign_split = { + close_pos:int; + before: element list; + mid: element list; + after: element list; + } + + let split_ralign (doc, shift) = + let l = to_list doc in + let before, rest = + split_on_open_tag ralign_tag [] l in + let mid, after = split_on_close 0 [] rest in + let len = Option.bind (approx_len 0 before) (fun n -> approx_len n mid) in + match len with + | None -> Error doc + | Some len -> + Ok { close_pos= shift + len; before; mid; after } + + let align_doc max_pos r = + let aligned_before = + let before = Open_tag ralign_tag :: r.before in + if r.close_pos >= max_pos then before + else Text (String.make (max_pos - r.close_pos) ' ') :: before + in + let mid_to_start = Close_tag :: r.mid @ aligned_before in + { rev = List.rev_append r.after mid_to_start } + + let align_prefix l = + let l = List.map split_ralign l in + let max_pos = + List.fold_left (fun mx r -> + match r with + | Ok r -> max mx r.close_pos + | Error _ -> mx + ) 0 l + in + List.map (Result.fold ~ok:(align_doc max_pos) ~error:Fun.id) l + + let align_prefix2 x y = match align_prefix [x;y] with + | [x;y] -> x, y + | _ -> assert false + end (** Compatibility interface *) @@ -456,6 +532,7 @@ 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 semicolon ppf () = fprintf ppf ";@ " let pp_parens_if condition printer ppf arg = fprintf ppf "%s%a%s" diff --git a/upstream/ocaml_flambda/utils/format_doc.mli b/upstream/ocaml_flambda/utils/format_doc.mli index eceefcade..91142d31f 100644 --- a/upstream/ocaml_flambda/utils/format_doc.mli +++ b/upstream/ocaml_flambda/utils/format_doc.mli @@ -140,6 +140,14 @@ module Doc: sig 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 + (** {1 Alignment functions } *) + + (** Align the right side of one ["@{...@}"] tag box by inserting + spaces at the beginning of boxes. Those function do nothing if the tag box + appears after a break hint. *) + val align_prefix: (t * int) list -> t list + val align_prefix2: (t * int) -> (t * int) -> t * t + end (** {1 Compatibility API} *) @@ -269,6 +277,7 @@ val pp_print_newline: unit printer (** {2 Separators }*) val comma: unit printer +val semicolon: unit printer (** {2 List printing helpers} *) diff --git a/upstream/ocaml_flambda/utils/language_extension_kernel.ml b/upstream/ocaml_flambda/utils/language_extension_kernel.ml index 19cd32d55..530999742 100644 --- a/upstream/ocaml_flambda/utils/language_extension_kernel.ml +++ b/upstream/ocaml_flambda/utils/language_extension_kernel.ml @@ -15,7 +15,6 @@ type _ t = | Module_strengthening : unit t | Layouts : maturity t | SIMD : maturity t - | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : unit t | Let_mutable : unit t @@ -34,7 +33,6 @@ let to_string : type a. a t -> string = function | Module_strengthening -> "module_strengthening" | Layouts -> "layouts" | SIMD -> "simd" - | Labeled_tuples -> "labeled_tuples" | Small_numbers -> "small_numbers" | Instances -> "instances" | Let_mutable -> "let_mutable" diff --git a/upstream/ocaml_flambda/utils/language_extension_kernel.mli b/upstream/ocaml_flambda/utils/language_extension_kernel.mli index e0ac8fe7d..ab7d556ed 100644 --- a/upstream/ocaml_flambda/utils/language_extension_kernel.mli +++ b/upstream/ocaml_flambda/utils/language_extension_kernel.mli @@ -26,7 +26,6 @@ type _ t = | Module_strengthening : unit t | Layouts : maturity t | SIMD : maturity t - | Labeled_tuples : unit t | Small_numbers : maturity t | Instances : unit t | Let_mutable : unit t diff --git a/upstream/ocaml_flambda/utils/linkdeps.ml b/upstream/ocaml_flambda/utils/linkdeps.ml new file mode 100644 index 000000000..de1adf63a --- /dev/null +++ b/upstream/ocaml_flambda/utils/linkdeps.ml @@ -0,0 +1,143 @@ +(**************************************************************************) +(* *) +(* 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 = Compilation_unit.t + +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 : compunit) = + 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)" + Compilation_unit.print_as_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@]" + Compilation_unit.print_as_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@]" + Compilation_unit.print_as_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_flambda/utils/linkdeps.mli b/upstream/ocaml_flambda/utils/linkdeps.mli new file mode 100644 index 000000000..97013b8cb --- /dev/null +++ b/upstream/ocaml_flambda/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 = Compilation_unit.t + +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_flambda/utils/load_path.ml b/upstream/ocaml_flambda/utils/load_path.ml index fdb4492b4..605672029 100644 --- a/upstream/ocaml_flambda/utils/load_path.ml +++ b/upstream/ocaml_flambda/utils/load_path.ml @@ -279,12 +279,13 @@ end = struct None) t.files let find_normalized t fn = - let fn = Misc.normalized_unit_filename fn in + match Misc.normalized_unit_filename fn with + | Error _ -> None + | Ok fn -> let search { basename; path } = - if Misc.normalized_unit_filename basename = fn then - Some path - else - None + match Misc.normalized_unit_filename basename with + | Ok basename -> if String.equal basename fn then Some path else None + | Error _ -> None in List.find_map search t.files @@ -323,8 +324,12 @@ module Path_cache : sig val prepend_add_single : hidden:bool -> cmx_guaranteed:bool -> string -> string -> unit - (* Search for a basename in cache. Ignore case if [uncap] is true *) - val find : uncap:bool -> string -> string * visibility + (* Search for a basename in cache by exact name. *) + val find : string -> string * visibility + + (* Search in the uncapitalized tables. [fn_already_uncapped] should have + already been through [Misc.normalized_unit_filename]. *) + val find_uncap : fn_already_uncapped:string -> string * visibility end = struct module STbl = Misc.Stdlib.String.Tbl @@ -345,14 +350,17 @@ end = struct STbl.clear !visible_files_uncap let prepend_add_single ~hidden ~cmx_guaranteed base fn = - if hidden then begin - STbl.replace !hidden_files base fn; - STbl.replace !hidden_files_uncap (Misc.normalized_unit_filename base) fn - end else begin - STbl.replace !visible_files base { Clflags.path = fn; cmx_guaranteed }; - STbl.replace !visible_files_uncap (String.uncapitalize_ascii base) - { Clflags.path = fn; cmx_guaranteed } - end + Result.iter (fun ubase -> + if hidden then begin + STbl.replace !hidden_files base fn; + STbl.replace !hidden_files_uncap ubase fn + end else begin + STbl.replace !visible_files base + { Clflags.path = fn; cmx_guaranteed }; + STbl.replace !visible_files_uncap ubase + { Clflags.path = fn; cmx_guaranteed } + end) + (Misc.normalized_unit_filename base) let prepend_add dir = let hidden, cmx_guaranteed = @@ -377,23 +385,24 @@ end = struct in List.iter (fun ({ basename = base; path = fn } : Dir.entry) -> - 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 -> + update base fn visible_files hidden_files; + update ubase fn visible_files_uncap hidden_files_uncap) + (Misc.normalized_unit_filename base)) (Dir.files dir) - let find fn visible_files hidden_files = + let find_in fn visible_files hidden_files = try let { Clflags.path; cmx_guaranteed } = STbl.find !visible_files fn in (path, Visible { cmx_guaranteed }) with | Not_found -> (STbl.find !hidden_files fn, Hidden) - let find ~uncap fn = - if uncap then - find (String.uncapitalize_ascii fn) visible_files_uncap hidden_files_uncap - else - find fn visible_files hidden_files + let find fn = + find_in fn visible_files hidden_files + + let find_uncap ~fn_already_uncapped = + find_in fn_already_uncapped visible_files_uncap hidden_files_uncap end type auto_include_callback = @@ -546,7 +555,7 @@ let find fn = assert (not Config.merlin || Local_store.is_bound ()); try if is_basename fn && not !Sys.interactive then - fst (Path_cache.find ~uncap:false fn) + fst (Path_cache.find fn) else Misc.find_in_path (get_path_list ()) fn with Not_found -> @@ -562,9 +571,12 @@ let search_dirs dirs 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 - Path_cache.find ~uncap:true fn + Path_cache.find_uncap ~fn_already_uncapped:fn_uncap else match search_dirs (List.rev !visible_dirs) fn with | Some result -> result @@ -573,7 +585,6 @@ let find_normalized_with_visibility fn = | Some result -> result | None -> raise Not_found with Not_found -> - let fn_uncap = String.uncapitalize_ascii fn in (!auto_include_callback Dir.find_normalized fn_uncap, Visible { cmx_guaranteed = false }) diff --git a/upstream/ocaml_flambda/utils/local_store.mli b/upstream/ocaml_flambda/utils/local_store.mli index 3ea05d588..545cf71e0 100644 --- a/upstream/ocaml_flambda/utils/local_store.mli +++ b/upstream/ocaml_flambda/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/upstream/ocaml_flambda/utils/misc.ml b/upstream/ocaml_flambda/utils/misc.ml index f1215f0ca..763612f04 100644 --- a/upstream/ocaml_flambda/utils/misc.ml +++ b/upstream/ocaml_flambda/utils/misc.ml @@ -659,6 +659,246 @@ end module Int = Stdlib.Int +let repeated_label l = + let module Set = Stdlib.String.Set in + let rec go s = function + | [] -> None + | (None, _) :: l -> go s l + | (Some lbl, _) :: l -> + if Set.mem lbl s then Some lbl else go (Set.add lbl s) l + in + go Set.empty l + +(** {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 = @@ -689,10 +929,12 @@ let find_in_path_rel path name = 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 -> @@ -1064,6 +1306,7 @@ module Color = struct let default_setting = Auto let enabled = ref true + let is_enabled () = !enabled end @@ -1134,7 +1377,7 @@ module Style = struct error = no_markup [Bold; FG Red]; loc = no_markup [Bold]; hint = no_markup [Bold; FG Blue]; - inline_code= { ansi=[Bold]; text_open = {|"|}; text_close = {|"|} } + inline_code= no_markup [Bold] } let cur_styles = ref default_styles @@ -1149,6 +1392,7 @@ module Style = struct | Format.String_tag "loc" -> (!cur_styles).loc | Format.String_tag "hint" -> (!cur_styles).hint | Format.String_tag "inline_code" -> (!cur_styles).inline_code + | Format.String_tag "ralign" -> no_markup [] | Style s -> no_markup s | _ -> raise Not_found @@ -1161,6 +1405,8 @@ module Style = struct let inline_code ppf s = as_inline_code Format_doc.pp_print_string ppf s + let hint ppf = Format_doc.fprintf ppf "@{Hint@}" + let as_clflag flag printer ppf x = Format_doc.fprintf ppf "@{%s %a@}" flag printer x @@ -1276,22 +1522,34 @@ let spellcheck env name = let env = List.sort_uniq (fun s1 s2 -> String.compare s2 s1) env in fst (List.fold_left (compare name) ([], max_int) env) +let align_hint ~prefix ~main ~hint = + let prefix_shift = String.length prefix in + Format_doc.Doc.align_prefix2 (main,prefix_shift) (hint,0) -let did_you_mean ppf get_choices = +let align_error_hint ~main ~hint = align_hint ~prefix:"Error: " ~main ~hint + +let aligned_hint ~prefix ppf main_fmt = + let open Format_doc in + kdoc_printf (fun main hint -> + match hint with + | None -> pp_doc ppf main + | Some hint -> + let main, hint = align_hint ~prefix ~main ~hint in + fprintf ppf "%a@.%a" pp_doc main pp_doc hint + ) main_fmt + +let did_you_mean ?(pp=Style.inline_code) 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 - | [] -> () + match choices with + | [] -> None | 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 + Some (doc_printf + "@[@{Hint@}: @{Did you mean @}%a%s%a?@]" + (pp_print_list ~pp_sep:comma pp) rest + (if rest = [] then "" else " or ") + pp last + ) module Error_style = struct type setting = @@ -1340,27 +1598,6 @@ let delete_eol_spaces src = 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 "@]" - let pp_parens_if condition printer ppf arg = Format.fprintf ppf "%s%a%s" (if condition then "(" else "") diff --git a/upstream/ocaml_flambda/utils/misc.mli b/upstream/ocaml_flambda/utils/misc.mli index fcc8eea22..82e0dccce 100644 --- a/upstream/ocaml_flambda/utils/misc.mli +++ b/upstream/ocaml_flambda/utils/misc.mli @@ -105,6 +105,9 @@ val split_last: 'a list -> 'a list * 'a val last : 'a list -> 'a option (** Return the last element of a list if it's nonempty *) +val repeated_label : (string option * 'a) list -> string option + (** Detects a repeated label - for use with labeled tuples. *) + (** {1 Hash table operations} *) val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t @@ -427,8 +430,9 @@ val find_in_path: string list -> string -> string 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, @@ -702,18 +706,59 @@ val spellcheck : string list -> string -> string list list of suggestions taken from [env], that are close enough to [name] that it may be a typo for one of them. *) + +val align_hint: + prefix:string -> main:Format_doc.t -> hint:Format_doc.t -> + Format_doc.t * Format_doc.t +(** [aligned_hint main hint] vertically aligns a [main] message and a hint + message. The vertical alignment is controlled by the use of [@{ ... + @}] boxes: the start of one box, in either the hint or the main message, + will be shifted on the left to ensure that the end of the two boxes are + vertically aligned, taking in account a pre-existing [prefix] before the + main message. For instance, +{[ +let main, sub = + align_hint + ~prefix:"Error: " + (doc_printf "@{The value @}%a is not an instance variable" + Style.inline_code "foobar" + ) + (doc_printf + "@{Did you mean @}%a" Style.inline_code "foobaz" + ) in + printf "Error: %a%a" pp_doc main pp_doc sub +]} + + produces the following text: + +{[ +Error: The value "foobaz" is not an instance variable +Hint: Did you mean "foobar"? +]} + + where the main message has been shifted to the left to align ["foobaz"] and + ["foobar"]. +*) + + +val align_error_hint: + main:Format_doc.t -> hint:Format_doc.t -> Format_doc.t * Format_doc.t +(** Same as [align_hint ~prefix:"Error: "] *) + +val aligned_hint: + prefix:string -> Format_doc.formatter -> + ('a, Format_doc.formatter, unit, Format_doc.t option -> unit) format4 -> 'a +(** [aligned_hint ~prefix fmt ... hint] align the potential hint with the main + error message generated by the format string [fmt] before printing the two + message. *) + 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. + ?pp:string Format_doc.printer -> string list -> Format_doc.t option +(** [did_you_mean ~pp choices] hints that the user may have meant one of the + option in [choices]. + + Each choice is printed with the [pp] function, or [Style.inline_code] if + [pp]=[None]. *) (** {1 Color support detection }*) @@ -722,7 +767,7 @@ module Color: sig type setting = Auto | Always | Never val default_setting : setting - + val is_enabled : unit -> bool end @@ -763,6 +808,7 @@ module Style : sig inline_code: tag_style; } + val hint: Format_doc.formatter -> unit val as_inline_code: 'a Format_doc.printer -> 'a Format_doc.printer val inline_code: string Format_doc.printer @@ -797,32 +843,6 @@ val print_if : (** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [flag] 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 pp_table : Format.formatter -> (string * string list) list -> unit (** [pp_table ppf l] prints the table [l], a list of columns with their header. The function fails with a fatal error if the columns have @@ -1144,6 +1164,66 @@ module type T4 = sig type ('a, 'b, 'c, 'd) t 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/ocaml_flambda/utils/profile_counters_functions.ml b/upstream/ocaml_flambda/utils/profile_counters_functions.ml index d11febca6..552fc2339 100644 --- a/upstream/ocaml_flambda/utils/profile_counters_functions.ml +++ b/upstream/ocaml_flambda/utils/profile_counters_functions.ml @@ -8,7 +8,7 @@ let count_language_extensions typing_input = fun lang_ext -> match lang_ext with | Comprehensions | Include_functor | Immutable_arrays | Module_strengthening - | Labeled_tuples -> + -> Language_extension_kernel.to_string lang_ext | Mode | Unique | Polymorphic_parameters | Layouts | SIMD | Small_numbers | Instances | Overwriting | Let_mutable | Layout_poly @@ -29,20 +29,12 @@ let count_language_extensions typing_input = Include_functor; Immutable_arrays; Module_strengthening; - Labeled_tuples; Immutable_arrays ] in List.iter (fun lang_ext -> counters := Profile.Counters.set (to_string lang_ext) 0 !counters) supported_lang_exts; - let check_for_labeled_tuples label_opt_pair_list = - if - List.exists - (fun (label_opt, _) -> Option.is_some label_opt) - label_opt_pair_list - then incr Labeled_tuples - in let check_array_mutability mutability = if not (Types.is_mutable mutability) then incr Immutable_arrays in @@ -76,8 +68,6 @@ let count_language_extensions typing_input = check_array_mutability mutability | Texp_array (mutability, _, _, _) -> check_array_mutability mutability - | Texp_tuple (label_opt_pair_list, _) -> - check_for_labeled_tuples label_opt_pair_list | _ -> ()); default_iterator.expr sub e); module_type = @@ -89,8 +79,6 @@ let count_language_extensions typing_input = typ = (fun sub ({ ctyp_desc; _ } as ctyp) -> (match ctyp_desc with - | Ttyp_tuple label_opt_pair_list -> - check_for_labeled_tuples label_opt_pair_list (* CR-someday mitom: type occurence of [iarray] double counted in [let a_iarray : int iarray = [: 1; 2; 3; 4; 5 :]] *) | Ttyp_constr (Pident ident, _, _) -> @@ -106,8 +94,6 @@ let count_language_extensions typing_input = ({ pat_desc; _ } as gen_pat : k Typedtree.general_pattern) -> (match pat_desc with - | Tpat_tuple label_opt_pair_list -> - check_for_labeled_tuples label_opt_pair_list | Tpat_array (mutability, _, _) -> check_array_mutability mutability | _ -> ()); default_iterator.pat sub gen_pat) diff --git a/upstream/ocaml_flambda/utils/warnings.ml b/upstream/ocaml_flambda/utils/warnings.ml index eb4021d53..971a63eb0 100644 --- a/upstream/ocaml_flambda/utils/warnings.ml +++ b/upstream/ocaml_flambda/utils/warnings.ml @@ -51,6 +51,10 @@ type name_out_of_scope_warning = | Name of string | Fields of { record_form : string ; fields : string list } +type type_declaration_usage_warning = + | Declaration + | Alias + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -59,7 +63,7 @@ type t = | Ignored_partial_application (* 5 *) | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) - | Partial_match of string (* 8 *) + | Partial_match of Format_doc.t (* 8 *) | Missing_record_field_pattern of { form : string ; unbound : string } (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) @@ -86,7 +90,7 @@ type t = was turned into a hard error *) | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) - | Unused_type_declaration of string (* 34 *) + | Unused_type_declaration of string * type_declaration_usage_warning (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * constructor_usage_warning (* 37 *) @@ -129,6 +133,8 @@ type t = | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) + | Unnecessarily_partial_tuple_pattern (* 75 *) (* Oxcaml specific warnings: numbers should go down from 199 *) | Redundant_kind_modifier of string (* 183 *) | Ignored_kind_modifier of string * string list (* 184 *) @@ -136,7 +142,7 @@ type t = | Unmutated_mutable of string (* 186 *) | Incompatible_with_upstream of upstream_compat_warning (* 187 *) | Unerasable_position_argument (* 188 *) - | Unnecessarily_partial_tuple_pattern (* 189 *) + (* 189 was [Unnecessarily_partial_tuple_pattern], now upstream as 75 *) | Probe_name_too_long of string (* 190 *) | Unused_kind_declaration of string (* 191 *) | Zero_alloc_all_hidden_arrow of string (* 198 *) @@ -147,7 +153,7 @@ type t = | Modal_axis_specified_twice of { axis : string; overriden_by : string; - } (* 213 *) + } (* 213 *) | Atomic_float_record_boxed (* 214 *) | Implied_attribute of { implying: string; implied : string} (* 215 *) | Use_during_borrowing (* 216 *) @@ -239,8 +245,9 @@ let number = function | Overridden_kind_modifier _ -> 185 | Unmutated_mutable _ -> 186 | Incompatible_with_upstream _ -> 187 - | Unerasable_position_argument -> 188 - | Unnecessarily_partial_tuple_pattern -> 189 + | Degraded_to_partial_match -> 74 + | Unnecessarily_partial_tuple_pattern -> 75 + | Unerasable_position_argument -> 188 (* 189 is now upstream as 75 *) | Probe_name_too_long _ -> 190 | Unused_kind_declaration _ -> 191 | Zero_alloc_all_hidden_arrow _ -> 198 @@ -598,6 +605,16 @@ 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 }; + { number = 75; + names = ["unnecessarily-partial-tuple-pattern"]; + description = "A tuple pattern ends in .. but fully matches its expected \ + type."; + since = since 5 4 }; { number = 183; names = ["redundant-kind-modifier"]; (* CR layouts-scannable: As more axes are added, this description (and @@ -630,11 +647,7 @@ let descriptions = [ names = ["unerasable-position-argument"]; description = "Unerasable position argument."; since = since 5 1 }; - { number = 189; - names = ["unnecessarily-partial-tuple-pattern"]; - description = "A tuple pattern ends in .. but fully matches its expected \ - type."; - since = since 5 1 }; + (* 189 was [unnecessarily-partial-tuple-pattern], now upstream as 75 *) { number = 190; names = ["probe-name-too-long"]; description = "Probe name must be at most 100 characters long."; @@ -1008,7 +1021,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-183..185" +let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70-74-183..185" let defaults_warn_error = "-a" let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] @@ -1017,374 +1030,472 @@ let () = ignore @@ parse_options true defaults_warn_error let () = List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts +module Fmt = Format_doc +module Style = Misc.Style +let msg = Fmt.doc_printf +let comma_inline_list = Fmt.(pp_print_list ~pp_sep:comma Style.inline_code) +let space_inline_list ppf l = + let pp_sep = Fmt.pp_print_space in + Fmt.fprintf ppf "@[%a@]" (Fmt.pp_print_list ~pp_sep Style.inline_code) l +let expand ppf s = if s = "" then () else Fmt.fprintf ppf "@ %s" s + 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." + msg + "this %a is the start of a comment.@ \ + %t: Did you forget spaces when writing the infix operator %a?" + Style.inline_code "(*" + Style.hint + Style.inline_code "( * )" + | Comment_not_end -> msg "this is not the end of a comment." | Fragile_match "" -> - "this pattern-matching is fragile." + msg "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 ^ "." + msg "this pattern-matching is fragile.@ \ + It will remain exhaustive when constructors are added to type %a." + Style.inline_code s | Ignored_partial_application -> - "this function application is partial,\n\ - maybe some arguments are missing." + msg "this function application is partial,@ \ + maybe@ some@ arguments@ are@ missing." | Labels_omitted [] -> assert false | Labels_omitted [l] -> - "label " ^ l ^ " was omitted in the application of this function." + msg "label %a@ was omitted@ in@ the@ application@ of@ this@ function." + Style.inline_code l | Labels_omitted ls -> - "labels " ^ String.concat ", " ls ^ - " were omitted in the application of this function." + msg "labels %a@ were omitted@ in@ the@ application@ of@ this@ function." + comma_inline_list ls | Method_override [lab] -> - "the method " ^ lab ^ " is overridden." + msg "the method %a is overridden." + Style.inline_code lab | Method_override (cname :: slist) -> - String.concat " " - ("the following methods are overridden by the class" - :: cname :: ":\n " :: slist) + msg "the following methods are overridden@ by@ the@ class@ %a:@;<1 2>%a" + Style.inline_code cname + space_inline_list 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 + | Partial_match doc -> + if doc = Format_doc.Doc.empty then + msg "this pattern-matching is not exhaustive." + else + msg "this pattern-matching is not exhaustive.@ \ + @[Here is an example of a case that is not matched:@;<1 2>%a@]" + Format_doc.pp_doc doc | Missing_record_field_pattern { form ; unbound } -> - "the following labels are not bound in this " ^ form ^ " pattern:\n" ^ - unbound ^ - "\nEither bind these labels explicitly or add '; _' to the pattern." + msg "the following labels are not bound@ in@ this@ \ + %s@ pattern:@;<1 2>%a.@ \ + @[Either bind these labels explicitly or add %a to the pattern.@]" + form + Style.inline_code unbound + Style.inline_code "; _" | Non_unit_statement -> - "this expression should have type unit." - | Redundant_case -> "this match case is unused." - | Redundant_subpat -> "this sub-pattern is unused." + msg "this expression should have type unit." + | Redundant_case -> msg "this match case is unused." + | Redundant_subpat -> msg "this sub-pattern is unused." | Instance_variable_override [lab] -> - "the instance variable " ^ lab ^ " is overridden." + msg "the instance variable %a is overridden." + Style.inline_code lab | Instance_variable_override (cname :: slist) -> - String.concat " " - ("the following instance variables are overridden by the class" - :: cname :: ":\n " :: slist) + msg + "the following instance variables@ are overridden@ \ + by the class %a:@;<1 2>%a" + Style.inline_code cname + space_inline_list 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: \\\\." + msg "illegal backslash escape in string.@ \ + %t: Single backslashes %a are reserved for escape sequences@ \ + (%a, %a, ...).@ Did you check the list of OCaml escape sequences?@ \ + To get a backslash character, escape it with a second backslash: %a." + Style.hint + Style.inline_code {|\|} + Style.inline_code {|\n|} + Style.inline_code {|\r|} + Style.inline_code {|\\|} | 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." + msg + "the following private methods@ were@ made@ public@ \ + implicitly:@;<1 2>%a." + space_inline_list l + | Unerasable_optional_argument -> + msg "this optional argument cannot be erased." + | Undeclared_virtual_method m -> + msg "the virtual method %a is not declared." + Style.inline_code m + | Not_principal emsg -> + msg "%a@ is@ not@ principal." Fmt.pp_doc emsg + | Non_principal_labels s -> msg "%s without principality." s + | Ignored_extra_argument -> + msg "this argument will not be used by the function." | Nonreturning_statement -> - "this statement never returns (or has an unsound type.)" - | Preprocessor s -> s + msg "this statement never returns (or has an unsound type.)" + | Preprocessor s -> msg "%s" s | Useless_record_with s -> - "all the fields are explicitly listed in this " ^ s ^ ":\n\ - the 'with' clause is useless." + msg "all the fields are explicitly listed in this %s:@ \ + the %a clause is useless." + s + Style.inline_code "with" | Bad_module_name (modname) -> - "bad source file name: \"" ^ modname ^ "\" is not a valid module name." + msg "bad source file name: %a is not a valid module name." + Style.inline_code modname | All_clauses_guarded -> - "this pattern-matching is not exhaustive.\n\ - All clauses in this pattern-matching are guarded." + msg "this pattern-matching is not exhaustive.@ \ + All clauses in this pattern-matching are guarded." | Unused_var { name = v; mutated = false } | Unused_var_strict { name = v; mutated = false } -> - "unused variable " ^ v ^ "." + msg "unused variable %a." + Style.inline_code v | Unused_var { name = v; mutated = true } | Unused_var_strict { name = v; mutated = true } -> - "variable " ^ v ^ " was mutated but never used." + msg "variable %a was mutated but never used." + Style.inline_code v | Wildcard_arg_to_constant_constr -> - "wildcard pattern given as argument to a constant constructor" + msg "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)" + msg "unescaped end-of-line in a string constant@ \ + (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 ^ "." + msg "the %s %a is defined in both types %a and %a." + kind + Style.inline_code cname + Style.inline_code tc1 + Style.inline_code tc2 + | Unused_value_declaration v -> + msg "unused value %a." Style.inline_code v + | Unused_open s -> msg "unused open %a." Style.inline_code s + | Unused_open_bang s -> msg "unused open! %a." Style.inline_code s + | Unused_type_declaration (s, Declaration) -> + msg "unused type %a." Style.inline_code s + | Unused_type_declaration (s, Alias) -> + msg "unused type alias %a." Style.inline_code s + | Unused_for_index s -> msg "unused for-loop index %a." Style.inline_code s + | Unused_ancestor s -> msg "unused ancestor variable %a." Style.inline_code s + | Unused_constructor (s, Unused) -> + msg "unused constructor %a." Style.inline_code s | Unused_constructor (s, Not_constructed) -> - "constructor " ^ s ^ - " is never used to build values.\n\ - (However, this constructor appears in patterns.)" + msg "constructor %a is never used to build values.@ \ + (However, this constructor appears in patterns.)" + Style.inline_code s | Unused_constructor (s, Only_exported_private) -> - "constructor " ^ s ^ - " is never used to build values.\n\ - Its type is exported as a private type." + msg "constructor %a is never used to build values.@ \ + Its type is exported as a private type." + Style.inline_code s | 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 + let kind = + if is_exception then "exception" else "extension constructor" in + begin match complaint with + | Unused -> msg "unused %s %a" kind Style.inline_code s + | Not_constructed -> + msg + "%s %a is never used@ to@ build@ values.@ \ + (However, this constructor appears in patterns.)" + kind Style.inline_code s + | Only_exported_private -> + msg + "%s %a is never used@ to@ build@ values.@ \ + It is exported or rebound as a private extension." + kind Style.inline_code s + end | Unused_rec_flag -> - "unused rec flag." + msg "unused rec flag." | Name_out_of_scope (ty, Name nm) -> - 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." + msg "%a was selected from type %a.@ \ + @[It is not visible in the current scope,@ and@ will@ not@ \ + be@ selected@ if the type becomes unknown@]." + Style.inline_code nm + Style.inline_code ty | Name_out_of_scope (ty, Fields { record_form ; fields }) -> - "this " ^ record_form ^ " of type "^ ty ^" contains fields that are \n\ - not visible in the current scope: " - ^ String.concat " " fields ^ ".\n\ - They will not be selected if the type becomes unknown." + msg "this %s of type %a@ contains@ fields@ that@ are@ \ + not@ visible in the current scope:@;<1 2>%a.@ \ + @[They will not be selected@ if the type@ becomes@ unknown.@]" + record_form + Style.inline_code ty + space_inline_list fields | 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 + msg "%a belongs to several types:@;<1 2>%a.@ \ + The first one was selected.@ \ + @[Please disambiguate@ if@ this@ is wrong.%a@]" + Style.inline_code s + space_inline_list tl + expand 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 + msg "these field labels belong to several types:@;<1 2>%a.@ \ + @[The first one was selected.@ \ + Please disambiguate@ if@ this@ is@ wrong.%a@]" + space_inline_list tl + expand expansion | Disambiguated_name s -> - "this use of " ^ s ^ " relies on type-directed disambiguation,\n\ - it will not compile with OCaml 4.00 or earlier." + msg "this use of %a@ relies@ on@ type-directed@ disambiguation,@ \ + @[it@ will@ not@ compile@ with@ OCaml@ 4.00@ or@ earlier.@]" + Style.inline_code s | Nonoptional_label s -> - "the label " ^ s ^ " is not optional." + msg "the label %a is not optional." + Style.inline_code s | Open_shadow_identifier (kind, s) -> - Printf.sprintf - "this open statement shadows the %s identifier %s (which is later used)" - kind s + msg + "this open statement shadows@ the@ %s identifier@ %a@ \ + (which is later used)" + kind Style.inline_code s | Open_shadow_label_constructor (kind, s) -> - Printf.sprintf - "this open statement shadows the %s %s (which is later used)" - kind s + msg + "this open statement shadows@ the@ %s %a@ (which is later used)" + kind Style.inline_code s | Bad_env_variable (var, s) -> - Printf.sprintf "illegal environment variable %s : %s" var s + msg "illegal environment variable %a : %s" + Style.inline_code var + s | Attribute_payload (a, s) -> - Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s + msg "illegal payload for attribute %a.@ %s" + Style.inline_code a + s | Eliminated_optional_arguments sl -> - Printf.sprintf "implicit elimination of optional argument%s %s" + msg "implicit elimination@ of optional argument%s@ %a" (if List.length sl = 1 then "" else "s") - (String.concat ", " sl) + comma_inline_list 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 + msg "no cmi file was found@ in path for module %a" + Style.inline_code name + | No_cmi_file(name, Some wmsg) -> + msg + "no valid cmi file was found@ in path for module %a.@ %s" + Style.inline_code name + wmsg | Unexpected_docstring unattached -> - if unattached then "unattached documentation comment (ignored)" - else "ambiguous documentation comment" + if unattached then msg "unattached documentation comment (ignored)" + else msg "ambiguous documentation comment" | Wrong_tailcall_expectation b -> - Printf.sprintf "expected %s" + msg "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 + msg + "Code should not depend@ on@ the@ actual@ values of@ \ + this@ constructor's arguments.@ @[They are only for@ information@ \ + and@ may@ change@ in@ future versions.@ %a@]" + Misc.print_see_manual ref_manual | Unreachable_case -> - "this match case is unreachable.\n\ - Consider replacing it with a refutation case ' -> .'" + msg "this match case is unreachable.@ \ + Consider replacing it with a refutation case %a" + Style.inline_code " -> ." | Misplaced_attribute attr_name -> - Printf.sprintf "the %S attribute cannot appear in this context" attr_name + msg "the %a attribute cannot appear in this context" + Style.inline_code attr_name | Duplicated_attribute attr_name -> - Printf.sprintf "the %S attribute is used more than once on this \ - expression" - attr_name + msg "the %a attribute is used more than once@ on@ this@ \ + expression" + Style.inline_code attr_name | Inlining_impossible reason -> - Printf.sprintf "Cannot inline: %s" reason + msg "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 + | [x] -> + Fmt.dprintf + "variable %a appears in@ different@ places@ in@ \ + different@ or-pattern@ alternatives." + Style.inline_code x | _::_ -> - let vars = String.concat ", " vars in - "variables " ^ vars ^ " appear " ^ in_different_places + Fmt.dprintf + "variables %a appears in@ different@ places@ in@ \ + different@ or-pattern@ alternatives." + comma_inline_list vars 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 + msg + "Ambiguous or-pattern variables under@ guard;@ \ + %t@ \ + @[Only the first match will be used to evaluate@ \ + the@ guard@ expression.@ %a@]" + vars_explanation + Misc.print_see_manual ref_manual | No_cmx_file { missing_extension; module_name } -> - Printf.sprintf - "no %s file was found in path for module %s, \ - and its interface was not compiled with -opaque" - missing_extension module_name + msg + "no %s file was found@ in@ path@ for@ module@ %a,@ \ + and@ its@ interface@ was@ not@ compiled@ with %a" + missing_extension + Style.inline_code module_name + Style.inline_code "-opaque" | 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 ^ "." + msg + "A potential@ assignment@ to@ a@ non-mutable@ value@ was@ detected@ \ + in@ this@ source@ file.@ \ + Such@ assignments@ may@ generate@ incorrect@ code@ \ + when@ using@ Flambda." + | Unused_module s -> msg "unused module %a." Style.inline_code 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 + msg + "This primitive declaration uses type %a,@ whose@ representation@ \ + may be either boxed or unboxed.@ Without@ an@ annotation@ to@ \ + indicate@ which@ representation@ is@ intended,@ the@ boxed@ \ + representation@ has@ been@ selected@ by@ default.@ This@ default@ \ + choice@ may@ change@ in@ future@ versions@ of@ the@ compiler,@ \ + breaking@ the@ primitive@ implementation.@ You@ should@ explicitly@ \ + annotate@ the@ declaration@ of@ %a@ with@ %a@ or@ %a,@ so@ that@ its@ \ + external@ interface@ remains@ stable@ in@ the future." + Style.inline_code t + Style.inline_code t + Style.inline_code "[@@boxed]" + Style.inline_code "[@@unboxed]" | Constraint_on_gadt -> - "Type constraints do not apply to GADT cases of variant types." + msg "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." - ^ s - ^ "\nBeware that this warning is purely informational and will not catch\n\ - all instances of erroneous printed interface." + msg + "The printed@ interface@ differs@ from@ the@ inferred@ interface.@ \ + The@ inferred@ interface@ contained@ items@ which@ could@ not@ be@ \ + printed@ properly@ due@ to@ name@ collisions@ between@ identifiers.@ \ + %s@ \ + Beware@ that@ this@ warning@ is@ purely@ informational@ and@ will@ \ + not@ catch@ all@ instances@ of@ erroneous@ printed@ interface." + s | Unsafe_array_syntax_without_parsing -> - "option -unsafe used with a preprocessor returning a syntax tree" + msg "option@ %a@ used with a preprocessor returning@ a@ syntax tree" + Style.inline_code "-unsafe" | 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 ^ "." + let def ppf name = Fmt.fprintf ppf "type %s = unit" name in + msg + "This type declaration is@ defining@ a new %a constructor@ \ + which@ shadows@ the@ existing@ one.@ \ + %t: Did you mean %a?" + Style.inline_code "()" + Style.hint + (Style.as_inline_code def) name + | Unused_functor_parameter s -> + msg "unused functor parameter %a." Style.inline_code 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." + msg + "This pattern depends on@ mutable@ state.@ It prevents@ the@ \ + remaining@ arguments@ from@ being@ uncurried,@ which will@ cause@ \ + additional@ closure@ allocations." | Unused_field { form; field; complaint = Unused } -> - "unused " ^ form ^ " field " ^ field ^ "." + msg "unused %s field %a." form Style.inline_code field | Unused_field { form; field; complaint = Not_read } -> - form ^ " field " ^ field ^ - " is never read.\n\ - (However, this field is used to build or mutate values.)" + msg "%s field %a is never read.@ \ + (However, this field is used to build or mutate values.)" + form Style.inline_code field | Unused_field { form; field; complaint = Not_mutated } -> - "mutable " ^ form ^ " field " ^ field ^ - " is never mutated." + msg "mutable %s field %a is never mutated." + form Style.inline_code field | Missing_mli -> - "Cannot find interface file." + msg "Cannot find interface file." | Unused_tmc_attribute -> - "This function is marked @tail_mod_cons\n\ - but is never applied in TMC position." + msg "This function is marked %a@ \ + but is never applied in TMC position." + Style.inline_code "@tail_mod_cons" | 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." + msg "This call@ is@ in@ tail-modulo-cons@ position@ in@ a@ TMC@ \ + function,@ but@ the@ function@ called@ is@ not@ itself@ \ + specialized@ for@ TMC,@ so@ the@ call@ will@ not@ be@ transformed@ \ + into@ a@ tail@ call.@ \ + @[Please@ either@ mark@ the@ called@ function@ with@ the %a@ \ + attribute,@ or@ mark@ this@ call@ with@ the@ %a@ attribute@ to@ \ + make@ its@ non-tailness@ explicit.@]" + Style.inline_code "[@tail_mod_cons]" + Style.inline_code "[@tailcall false]" | Generative_application_expects_unit -> - "A generative functor\n\ - should be applied to '()'; using '(struct end)' is deprecated." + msg "A generative functor@ \ + should be applied@ to@ %a;@ using@ %a@ is deprecated." + Style.inline_code "()" + Style.inline_code "(struct end)" + | Degraded_to_partial_match -> + let[@manual.ref "ss:warn74"] ref_manual = [ 13; 5; 5 ] in + msg + "This pattern-matching@ is@ compiled@ as@ partial,@ even@ if@ it@ \ + appears@ to@ be@ total.@ It@ may@ generate@ a@ %a@ exception.@ This@ \ + typically@ occurs@ due@ to@ complex@ matches@ on@ mutable@ fields.@ %a" + Style.inline_code "Match_failure" + Misc.print_see_manual ref_manual | Redundant_kind_modifier abbrev -> - "This kind modifier is already implied by the kind \"" ^ abbrev ^ "\"." + msg "This kind modifier is already implied by the kind %a." + Style.inline_code abbrev | Ignored_kind_modifier (abbrev, modifiers) -> - Printf.sprintf - "The kind modifier(s) \"%s\" have no effect on the kind \"%s\"." - (String.concat " " modifiers) abbrev + msg "The kind modifier(s) %a have no effect on the kind %a." + Style.inline_code (String.concat " " modifiers) Style.inline_code abbrev | Overridden_kind_modifier overridden_by -> - "This kind modifier is overridden by \"" ^ overridden_by ^ "\" later." - | Unmutated_mutable v -> "mutable variable " ^ v ^ " was never mutated." + msg "This kind modifier is overridden by %a later." + Style.inline_code overridden_by + | Incompatible_with_upstream Unpacked_attribute -> + msg "[@@unpacked] is not supported by upstream OCaml." + | Unnecessarily_partial_tuple_pattern -> + msg + "This tuple pattern@ unnecessarily@ ends in %a,@ as@ it@ explicitly@ \ + matches@ all@ components@ of@ its@ expected@ type." + Style.inline_code ".." + | Unmutated_mutable v -> + msg "mutable variable %a was never mutated." Style.inline_code v | Incompatible_with_upstream (Non_value_sort layout) -> - Printf.sprintf - "External declaration here is not upstream compatible. \n\ - The only types with non-value layouts allowed are float#, \n\ - int32#, int64#, and nativeint#. Unknown type with layout \n\ - %s encountered." - layout + msg "External declaration here is not upstream compatible.@ \ + @[The only types with non-value layouts allowed are@ \ + float#, int32#, int64#, and nativeint#.@ \ + Unknown type with layout@ %s encountered.@]" layout | Incompatible_with_upstream (Unboxed_attribute layout) -> - Printf.sprintf - "[@unboxed] attribute must be added to external declaration \n\ - argument type with layout %s for upstream compatibility." - layout + msg "%a attribute must be added@ to@ external@ declaration@ \ + argument type with layout %s for upstream compatibility." + Style.inline_code "[@unboxed]" layout | Incompatible_with_upstream Immediate_void_variant -> - "This variant is immediate \n\ - because all its constructors have all-void arguments, but after \n\ - erasure for upstream compatibility, void is no longer zero-width, \n\ - so it won't be immediate." + msg "This variant is immediate@ \ + because all its constructors have all-void arguments,@ \ + @[but after erasure for upstream compatibility,@ \ + void is no longer zero-width,@ so it won't be immediate.@]" | Incompatible_with_upstream Separability_check -> - "This type relies on OxCaml's extended separability checking \n\ - and would not be accepted by upstream OCaml." - | Incompatible_with_upstream Unpacked_attribute -> - "[@unpacked] is not supported by upstream OCaml." - | Unerasable_position_argument -> "this position argument cannot be erased." - | Unnecessarily_partial_tuple_pattern -> - "This tuple pattern\n\ - unnecessarily ends in '..', as it explicitly matches all components\n\ - of its expected type." + msg "This type relies on OxCaml's extended separability checking@ \ + and would not be accepted by upstream OCaml." + | Unerasable_position_argument -> + msg "this position argument cannot be erased." | Probe_name_too_long name -> - Printf.sprintf - "This probe name is too long: `%s'. \ - Probe names must be at most 100 characters long." name + msg "This probe name is too long: %a.@ \ + Probe names must be at most 100 characters long." + Style.inline_code name | Unused_kind_declaration s -> - "unused kind " ^ s ^ "." + msg "unused kind %a." Style.inline_code s | Zero_alloc_all_hidden_arrow s -> - Printf.sprintf - "The type of this item is an\n\ - alias of a function type, but the [@@@zero_alloc %s] attribute for\n\ - this signature does not apply to it because its type is not\n\ - syntactically a function type. If it should be checked, use an\n\ - explicit zero_alloc attribute with an arity. If not, use an explicit\n\ - zero_alloc ignore attribute." s + msg "The type of this item is an@ alias of a function type,@ \ + but the %a attribute for@ this signature does not apply to it@ \ + because its type is not syntactically a function type.@ \ + @[If it should be checked, use an explicit zero_alloc attribute@ \ + with an arity.@ If not, use an explicit zero_alloc ignore attribute.@]" + Style.inline_code (Printf.sprintf "[@@@zero_alloc %s]" s) | Unchecked_zero_alloc_attribute -> - Printf.sprintf "the zero_alloc attribute cannot be checked.\n\ - The function it is attached to was optimized away. \n\ - You can try to mark this function as [@inline never] \n\ - or move the attribute to the relevant callers of this function." + msg "the zero_alloc attribute cannot be checked.@ \ + @[The function it is attached to was optimized away.@ \ + You can try to mark this function as %a@ \ + or move the attribute to the relevant callers of this function.@]" + Style.inline_code "[@inline never]" | Unboxing_impossible -> - Printf.sprintf - "This [@unboxed] attribute cannot be used.\n\ - The type of this value does not allow unboxing." + msg "This %a attribute cannot be used.@ \ + The type of this value does not allow unboxing." + Style.inline_code "[@unboxed]" | Mod_by_top modifier -> - Printf.sprintf - "%s is the top-most modifier.\n\ - Modifying by a top element is a no-op." - modifier + msg "%s is the top-most modifier.@ \ + Modifying by a top element is a no-op." modifier | Modal_axis_specified_twice {axis; overriden_by} -> - Printf.sprintf - "This %s is overriden by %s later." - axis overriden_by + msg "This %s is overridden by %s later." axis overriden_by | Atomic_float_record_boxed -> - Printf.sprintf - "This record contains atomic\n\ - float fields, which prevents the float record optimization. The\n\ - fields of this record will be boxed instead of being\n\ - represented as a flat float array." + msg "This record contains atomic float fields,@ \ + which prevents the float record optimization.@ \ + @[The fields of this record will be boxed instead of being@ \ + represented as a flat float array.@]" | Implied_attribute { implying; implied } -> - Printf.sprintf - "attribute [@%s] is unused because it is implied by [@%s]" - implied implying + msg "attribute %a is unused because it is implied by %a" + Style.inline_code (Printf.sprintf "[@%s]" implied) + Style.inline_code (Printf.sprintf "[@%s]" implying) | Use_during_borrowing -> - "This value is used while being borrowed." + msg "This value is used while being borrowed." | Useless_lpoly -> - "This binding has no layout variables, so \"poly_\" has no effect. \ - Consider using a regular \"let\" instead." + msg "This binding has no layout variables, so poly_ has no effect. \ + Consider using a regular let instead." | Lpoly_in_letrec -> - "\"poly_\" has no effect in recursive bindings, which do not support \ - layout polymorphism. Consider using a regular \"let rec\" instead." + msg "poly_ has no effect in recursive bindings, which do not support \ + layout polymorphism. Consider using a regular let rec instead." ;; let nerrors = ref 0 type reporting_information = { id : string - ; message : string + ; message : Fmt.doc ; is_error : bool - ; sub_locs : (loc * string) list; + ; sub_locs : (loc * Fmt.doc) list; } let id_name w = @@ -1413,7 +1524,7 @@ let report_alert (alert : alert) = | true -> let is_error = alert_is_error alert in if is_error then incr nerrors; - let message = Misc.normalise_eol alert.message in + let message = msg "%s" (Misc.normalise_eol alert.message) in (* Reduce \r\n to \n: - Prevents any \r characters being printed on Unix when processing Windows sources @@ -1423,8 +1534,8 @@ let report_alert (alert : alert) = let sub_locs = if not alert.def.loc_ghost && not alert.use.loc_ghost then [ - alert.def, "Definition"; - alert.use, "Expected signature"; + alert.def, msg "Definition"; + alert.use, msg "Expected signature"; ] else [] diff --git a/upstream/ocaml_flambda/utils/warnings.mli b/upstream/ocaml_flambda/utils/warnings.mli index b49d8e3e9..39b043639 100644 --- a/upstream/ocaml_flambda/utils/warnings.mli +++ b/upstream/ocaml_flambda/utils/warnings.mli @@ -50,6 +50,10 @@ type name_out_of_scope_warning = | Name of string | Fields of { record_form : string ; fields : string list } +type type_declaration_usage_warning = + | Declaration + | Alias + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -58,7 +62,7 @@ type t = | Ignored_partial_application (* 5 *) | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) - | Partial_match of string (* 8 *) + | Partial_match of Format_doc.t (* 8 *) | Missing_record_field_pattern of { form : string ; unbound : string } (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) @@ -89,7 +93,7 @@ type t = | 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_type_declaration of string * type_declaration_usage_warning (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * constructor_usage_warning (* 37 *) @@ -133,6 +137,8 @@ type t = | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) + | Unnecessarily_partial_tuple_pattern (* 75 *) (* Oxcaml specific warnings: numbers should go down from 199 *) | Redundant_kind_modifier of string (* 183 *) | Ignored_kind_modifier of string * string list (* 184 *) @@ -140,7 +146,7 @@ type t = | Unmutated_mutable of string (* 186 *) | Incompatible_with_upstream of upstream_compat_warning (* 187 *) | Unerasable_position_argument (* 188 *) - | Unnecessarily_partial_tuple_pattern (* 189 *) + (* 189 was [Unnecessarily_partial_tuple_pattern], now upstream as 75 *) | Probe_name_too_long of string (* 190 *) | Unused_kind_declaration of string (* 191 *) | Zero_alloc_all_hidden_arrow of string (* 198 *) @@ -178,9 +184,9 @@ val defaults_warn_error : string type reporting_information = { id : string - ; message : string + ; message : Format_doc.t ; is_error : bool - ; sub_locs : (loc * string) list; + ; sub_locs : (loc * Format_doc.t) list; } val report : t -> [ `Active of reporting_information | `Inactive ] From 9ad08140bef83331d667a27a35cff9789b253c3f Mon Sep 17 00:00:00 2001 From: Diana Kalinichenko Date: Tue, 5 May 2026 11:43:36 -0400 Subject: [PATCH 2/2] Commit conflicts --- src/ocaml/parsing/asttypes.ml | 75 + src/ocaml/parsing/builtin_attributes.ml | 63 +- src/ocaml/parsing/location.ml | 138 +- src/ocaml/parsing/location.mli | 64 +- src/ocaml/preprocess/lexer_raw.mll | 573 +++- src/ocaml/preprocess/parser_raw.mly | 584 +++- src/ocaml/typing/cmt_format.ml | 59 +- src/ocaml/typing/data_types.ml | 100 + src/ocaml/typing/data_types.mli | 96 + src/ocaml/typing/env.ml | 656 ++-- src/ocaml/typing/env.mli | 30 +- src/ocaml/typing/errortrace_report.ml | 657 ++++ src/ocaml/typing/errortrace_report.mli | 56 + src/ocaml/typing/gprinttyp.ml | 999 ++++++ src/ocaml/typing/gprinttyp.mli | 326 ++ src/ocaml/typing/ident.ml | 56 + src/ocaml/typing/includemod.ml | 477 +-- src/ocaml/typing/mtype.ml | 17 +- src/ocaml/typing/out_type.ml | 2880 +++++++++++++++++ src/ocaml/typing/out_type.mli | 295 ++ src/ocaml/typing/predef.mli | 72 + src/ocaml/typing/printtyp.ml | 3897 ++++++++++++++++++++++- src/ocaml/typing/printtyp.mli | 387 ++- src/ocaml/typing/printtyped.ml | 78 +- src/ocaml/typing/rawprinttyp.ml | 196 ++ src/ocaml/typing/rawprinttyp.mli | 22 + src/ocaml/typing/tast_iterator.ml | 107 +- src/ocaml/typing/tast_mapper.ml | 132 +- src/ocaml/typing/typeclass.ml | 156 +- src/ocaml/typing/typecore.ml | 2751 ++++++++++------ src/ocaml/typing/typecore.mli | 61 +- src/ocaml/typing/typedecl.ml | 854 ++--- src/ocaml/typing/typemod.ml | 342 +- src/ocaml/typing/types.ml | 111 +- src/ocaml/typing/typetexp.ml | 397 ++- src/ocaml/typing/unit_info.ml | 76 +- src/ocaml/utils/linkdeps.ml | 143 + src/ocaml/utils/linkdeps.mli | 64 + src/ocaml/utils/warnings.ml | 673 ++-- 39 files changed, 15861 insertions(+), 2859 deletions(-) create mode 100644 src/ocaml/parsing/asttypes.ml create mode 100644 src/ocaml/typing/data_types.ml create mode 100644 src/ocaml/typing/data_types.mli create mode 100644 src/ocaml/typing/errortrace_report.ml create mode 100644 src/ocaml/typing/errortrace_report.mli create mode 100644 src/ocaml/typing/gprinttyp.ml create mode 100644 src/ocaml/typing/gprinttyp.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/utils/linkdeps.ml create mode 100644 src/ocaml/utils/linkdeps.mli diff --git a/src/ocaml/parsing/asttypes.ml b/src/ocaml/parsing/asttypes.ml new file mode 100644 index 000000000..bf631bf38 --- /dev/null +++ b/src/ocaml/parsing/asttypes.ml @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* 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 atomic_flag = Nonatomic | Atomic + +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 + | Bivariant + +type injectivity = + | Injective + | NoInjectivity + +let string_of_label = function + Nolabel -> "" + | Labelled s -> s + | Optional s -> "?"^s diff --git a/src/ocaml/parsing/builtin_attributes.ml b/src/ocaml/parsing/builtin_attributes.ml index 270cafbae..b68540836 100644 --- a/src/ocaml/parsing/builtin_attributes.ml +++ b/src/ocaml/parsing/builtin_attributes.ml @@ -32,6 +32,7 @@ let mark_used t = Attribute_table.remove unused_attrs t *) let attr_order a1 a2 = Location.compare a1.loc a2.loc +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let compiler_stops_before_attributes_consumed () = let stops_before_lambda = (* Clflags.stop_after is not a flag that Merlin consumes, so default to the None @@ -45,6 +46,17 @@ let compiler_stops_before_attributes_consumed () = in stops_before_lambda || !Clflags.print_types +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +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 + +======= +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let unchecked_zero_alloc_attributes = Attribute_table.create 1 let mark_zero_alloc_attribute_checked txt loc = Attribute_table.remove unchecked_zero_alloc_attributes { txt; loc } @@ -67,6 +79,14 @@ let warn_unchecked_zero_alloc_attribute () = keys; Warnings.restore w_old +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; @@ -165,11 +185,13 @@ let ident_of_payload = function Some id | _ -> None -let string_of_cst = function +let string_of_cst const = + match const.pconst_desc with | Pconst_string(s, _, _) -> Some s | _ -> None -let int_of_cst = function +let int_of_cst const = + match const.pconst_desc with | Pconst_integer(i, None) -> Some (int_of_string i) | _ -> None @@ -195,7 +217,8 @@ let error_of_extension ext = (({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.msg ~loc "%a" Format_doc.pp_print_text msg | _ -> @@ -215,7 +238,8 @@ let error_of_extension ext = 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_doc.pp_print_text msg @@ -268,7 +292,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[ @@ -382,7 +407,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 @@ -419,7 +444,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)) @@ -521,6 +546,7 @@ let explicit_arity attrs = has_attribute "explicit_arity" attrs let has_unboxed attrs = has_attribute "unboxed" attrs let has_boxed attrs = has_attribute "boxed" attrs +let has_atomic attrs = has_attribute "atomic" attrs let has_unsafe_allow_any_mode_crossing attrs = has_attribute "unsafe_allow_any_mode_crossing" attrs @@ -839,7 +865,9 @@ let get_optional_payload get_from_exp = let get_int_from_exp = let open Parsetree in function - | { pexp_desc = Pexp_constant (Pconst_integer(s, None)) } -> + | { pexp_desc = + Pexp_constant {pconst_desc=Pconst_integer(s, None); _} + } -> begin match Misc.Int_literal_converter.int s with | n -> Result.Ok n | exception (Failure _) -> Result.Error () @@ -879,8 +907,12 @@ let get_id_or_constant_from_exp = let open Parsetree in function | { pexp_desc = Pexp_ident { txt = Longident.Lident id } } -> Result.Ok (Ident, id) - | { pexp_desc = Pexp_constant (Pconst_integer (s,None)) } -> Result.Ok (Const_int, s) - | { pexp_desc = Pexp_constant (Pconst_string (s,_loc,_so)) } -> Result.Ok (Const_string, s) + | { pexp_desc = + Pexp_constant {pconst_desc=Pconst_integer (s,None); _} + } -> Result.Ok (Const_int, s) + | { pexp_desc = + Pexp_constant {pconst_desc=Pconst_string (s,_loc,_so); _} + } -> Result.Ok (Const_string, s) | _ -> Result.Error () let get_ids_and_constants_from_exp exp = @@ -1172,7 +1204,10 @@ let get_tracing_probe_payload (payload : Parsetree.payload) = ({ pexp_desc = (Pexp_apply ({ pexp_desc= - (Pexp_constant (Pconst_string(name,_,None))); + (Pexp_constant + {pconst_desc= + Pconst_string(name,_,None); + _}); pexp_loc = name_loc; _ } , args)) @@ -1198,6 +1233,7 @@ let get_tracing_probe_payload (payload : Parsetree.payload) = | _ -> Error () in Ok { name; name_loc; enabled_at_init; arg } +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let has_atomic attrs = has_attribute "atomic" attrs @@ -1206,3 +1242,8 @@ let has_atomic attrs = has_attribute "atomic" attrs let merlin_punned_let = "merlin.punned-let" let merlin_punned_record_pattern = "merlin.punned-record-pattern" +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + +let has_atomic attrs = has_attribute "atomic" attrs +======= +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml index 4aae21ad1..b03181751 100644 --- a/src/ocaml/parsing/location.ml +++ b/src/ocaml/parsing/location.ml @@ -339,8 +339,25 @@ module Doc = struct if capitalize_first then String.capitalize_ascii s else s) else s in let comma () = +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 if !first then () else Fmt.fprintf ppf ", " in +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + 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 %a" + (capitalize "line") linenum startline +======= + 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 %a" + (capitalize "line") linenum startline +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 Fmt.fprintf ppf "@{"; if file_valid file then @@ -766,7 +783,12 @@ type report = { kind : report_kind; main : msg; sub : msg list; +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 source : error_source; +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +======= + footnote: Fmt.t option; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 } let loc_of_report { main; _ } = main.loc @@ -855,11 +877,12 @@ let batch_mode_printer : report_printer = | Misc.Error_style.Short -> () in - Format.fprintf ppf "@[%a:@ %a@]" print_loc loc + Format.fprintf ppf "%a:@ %a" print_loc loc (Fmt.compat highlight) loc *) () in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let pp_txt ppf txt = Format.fprintf ppf "@[%a@]" Fmt.Doc.format txt in let pp self ppf report = (* setup_tags (); *) @@ -870,14 +893,57 @@ let batch_mode_printer : report_printer = *) print_updating_num_loc_lines ppf (fun ppf () -> Format.fprintf ppf "@[%a%a%a: %a%a%a%a@]@." +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let pp_txt ppf txt = Format.fprintf ppf "@[%a@]" Fmt.Doc.format txt 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@]@." +======= + 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 error_format self ppf report = + Format.fprintf ppf "@[%a%a%a: %a@[%a@]%a%a%a@]@." +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 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 warning_format self ppf report = + Format.fprintf ppf "@[%a@[%a: %a@]%a%a@]@." + (self.pp_main_loc self report) report.main.loc + (self.pp_report_kind self report) report.kind + (self.pp_main_txt self report) report.main.txt + (self.pp_submsgs self report) report.sub + pp_footnote report.footnote + in + let pp self ppf report = + setup_tags (); + separate_new_message ppf; + let printer ppf () = match report.kind with + | Report_warning _ + | Report_warning_as_error _ + | Report_alert _ | Report_alert_as_error _ -> + warning_format self ppf report + | Report_error -> error_format self ppf report + in + (* 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 printer () in let pp_report_kind _self _ ppf = function | Report_error -> Format.fprintf ppf "@{Error@}" @@ -900,9 +966,12 @@ let batch_mode_printer : report_printer = ) 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 + if loc.loc_ghost then + Format.fprintf ppf "@[%a@]" (self.pp_submsg_txt self report) txt + else + 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 @@ -956,15 +1025,53 @@ 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 +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let mkerror loc sub txt source = { kind = Report_error; main = { loc; txt }; sub; source } - +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +let mkerror loc sub txt = + { kind = Report_error; main = { loc; txt }; sub } + +let errorf ?(loc = none) ?(sub = []) = + Fmt.kdoc_printf (mkerror loc sub) + +let error ?(loc = none) ?(sub = []) msg_str = + mkerror loc sub (Fmt.Doc.string msg_str Fmt.Doc.empty) +======= +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 aligned_error_hint + ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) fmt = + Fmt.kdoc_printf (fun main hint -> + match hint with + | None -> mkerror loc sub footnote main + | Some hint -> + let main, hint = Misc.align_error_hint ~main ~hint in + mkerror loc (mknoloc hint :: sub) footnote main + ) fmt + +let error ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) msg_str = + mkerror loc sub footnote Fmt.Doc.(string msg_str empty) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 + +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let errorf ?(loc = none) ?(sub = []) ?(source=Typer) = Fmt.kdoc_printf (fun msg -> mkerror loc sub msg source) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +let error_of_printer ?(loc = none) ?(sub = []) pp x = + mkerror loc sub (Fmt.doc_printf "%a" pp x) +======= +let error_of_printer ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) pp x = + mkerror loc sub footnote (Fmt.doc_printf "%a" pp x) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let error ?(loc = none) ?(sub = []) ?(source=Typer) msg_str = mkerror loc sub (Fmt.Doc.string msg_str Fmt.Doc.empty) source @@ -983,13 +1090,18 @@ 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 = Format_doc.Doc.(empty |> string str) in let kind = mk is_error id in - let main = { loc; txt = msg_of_str message } in + let main = { loc; txt = message } in let sub = List.map (fun (loc, sub_message) -> - { loc; txt = msg_of_str sub_message } + { loc; txt = sub_message } ) sub_locs in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 Some { kind; main; sub; source } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + Some { kind; main; sub } +======= + Some { kind; main; sub; footnote=None } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let default_warning_reporter = @@ -1130,8 +1242,16 @@ let () = | _ -> None ) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let raise_errorf ?(loc = none) ?(sub = []) ?(source = Typer)= Fmt.kdoc_printf (fun txt -> raise (Error (mkerror loc sub txt source))) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +let raise_errorf ?(loc = none) ?(sub = []) = + Fmt.kdoc_printf (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))) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let todo_overwrite_not_implemented ?(kind = "") t = alert ~kind t "Overwrite not implemented."; diff --git a/src/ocaml/parsing/location.mli b/src/ocaml/parsing/location.mli index 218c74e0f..55bf6af8e 100644 --- a/src/ocaml/parsing/location.mli +++ b/src/ocaml/parsing/location.mli @@ -43,7 +43,31 @@ type t = Warnings.loc = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool; -} + } +(** [t] represents a range of characters in the source code. + + loc_ghost=false whenever the AST described by the location can be parsed + from the location. In all other cases, loc_ghost must be true. Most + locations produced by the parser have loc_ghost=false. + When loc_ghost=true, the location is usually a best effort approximation. + + This info is used by tools like merlin that want to relate source code with + parsetrees or later asts. ocamlprof skips instrumentation of ghost nodes. + + Example: in `let f x = x`, we have: + - a structure item at location "let f x = x" + - a pattern "f" at location "f" + - an expression "fun x -> x" at location "x = x" with loc_ghost=true + - a pattern "x" at location "x" + - an expression "x" at location "x" + In this case, every node has loc_ghost=false, except the node "fun x -> x", + since [Parser.expression (Lexing.from_string "x = x")] would fail to parse. + By contrast, in `let f = fun x -> x`, every node has loc_ghost=false. + + Line directives can modify the filenames and line numbers arbitrarily, + which is orthogonal to loc_ghost, which describes the range of characters + from loc_start.pos_cnum to loc_end.pos_cnum in the parsed string. + *) (** Note on the use of Lexing.position in this module. If [pos_fname = ""], then use [!input_name] instead. @@ -250,7 +274,12 @@ type report = { kind : report_kind; main : msg; sub : msg list; +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 source : error_source; +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +======= + footnote: Format_doc.t option +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 } (* Exposed for Merlin *) @@ -382,12 +411,39 @@ val deprecated_script_alert: string -> unit type error = report (** An [error] is a [report] which [report_kind] must be [Report_error]. *) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 val error: ?loc:t -> ?sub:msg list -> ?source:error_source -> string -> error +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +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 +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 val errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +val errorf: ?loc:t -> ?sub:msg list -> +======= +val errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 ('a, Format_doc.formatter, unit, error) format4 -> 'a +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 val error_of_printer: ?loc:t -> ?sub:msg list -> ?source:error_source -> +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +val error_of_printer: ?loc:t -> ?sub:msg list -> +======= +val aligned_error_hint: + ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> + ('a, Format_doc.formatter, unit, Format_doc.t option -> error) format4 -> 'a +(** [aligned_error_hint ?loc ?sub ?footnote fmt ... aligned_hint] produces an + error report where the potential [aligned_hint] message has been aligned + with the main error message before being added to the list of submessages.*) + +val error_of_printer: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (Format_doc.formatter -> 'a -> unit) -> 'a -> error val error_of_printer_file: ?source:error_source -> (Format_doc.formatter -> 'a -> unit) -> 'a -> error @@ -413,7 +469,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 *) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 val raise_errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +val raise_errorf: ?loc:t -> ?sub:msg list -> +======= +val raise_errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 ('a, Format_doc.formatter, unit, 'b) format4 -> 'a val report_exception: formatter -> exn -> unit diff --git a/src/ocaml/preprocess/lexer_raw.mll b/src/ocaml/preprocess/lexer_raw.mll index 1a1b95d77..2ab8e4613 100644 --- a/src/ocaml/preprocess/lexer_raw.mll +++ b/src/ocaml/preprocess/lexer_raw.mll @@ -56,11 +56,31 @@ type preprocessor = (Lexing.lexbuf -> Parser_raw.token) -> Lexing.lexbuf -> Pars type state = { keywords: keywords; +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 mutable buffer: Buffer.t; mutable string_start_loc: Location.t; mutable comment_start_loc: Location.t list; mutable preprocessor: preprocessor option; } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | Unterminated_string_in_comment of Location.t * Location.t + | Empty_character_literal + | Keyword_as_label of string + | Invalid_literal of string + | Invalid_directive of string * string option +======= + | 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 + | Unknown_keyword of string +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let make ?preprocessor keywords = { keywords; @@ -80,6 +100,7 @@ let rec catch m f = match m with (* The table of keywords *) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let keyword_table : keywords = create_hashtable 149 [ "and", AND; @@ -126,7 +147,111 @@ let keyword_table : keywords = "open", OPEN; "or", OR; "overwrite_", OVERWRITE; +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +let keyword_table = + create_hashtable 149 [ + "and", AND; + "as", AS; + "assert", ASSERT; + "begin", BEGIN; + "class", CLASS; + "constraint", CONSTRAINT; + "do", DO; + "done", DONE; + "downto", DOWNTO; + "else", ELSE; + "end", END; + "exception", EXCEPTION; + "exclave_", EXCLAVE; + "external", EXTERNAL; + "false", FALSE; + "for", FOR; + "fun", FUN; + "function", FUNCTION; + "functor", FUNCTOR; + "global_", GLOBAL; + "if", IF; + "in", IN; + "include", INCLUDE; + "inherit", INHERIT; + "initializer", INITIALIZER; + "kind_", KIND; + "kind_of_", KIND_OF; + "layout_", LAYOUT; + "lazy", LAZY; + "let", LET; + "local_", LOCAL; + "match", MATCH; + "method", METHOD; + "mod", MOD; + "module", MODULE; + "mutable", MUTABLE; + "new", NEW; + "nonrec", NONREC; + "object", OBJECT; + "of", OF; + "once_", ONCE; + "open", OPEN; + "or", OR; + "overwrite_", OVERWRITE; +======= +let all_keywords = + let v5_3 = Some (5,3) in + let v1_0 = Some (1,0) in + let v1_6 = Some (1,6) in + let v4_2 = Some (4,2) in + let always = None in + let oxcaml = None in + [ + "and", AND, always; + "as", AS, always; + "assert", ASSERT, v1_6; + "begin", BEGIN, always; + "borrow_", BORROW, oxcaml; + "class", CLASS, v1_0; + "constraint", CONSTRAINT, v1_0; + "do", DO, always; + "done", DONE, always; + "downto", DOWNTO, always; + "effect", EFFECT, v5_3; + "else", ELSE, always; + "end", END, always; + "exception", EXCEPTION, always; + "exclave_", EXCLAVE, oxcaml; + "external", EXTERNAL, always; + "false", FALSE, always; + "for", FOR, always; + "fun", FUN, always; + "function", FUNCTION, always; + "functor", FUNCTOR, always; + "global_", GLOBAL, oxcaml; + "if", IF, always; + "in", IN, always; + "include", INCLUDE, always; + "inherit", INHERIT, v1_0; + "initializer", INITIALIZER, v1_0; + "kind_", KIND, oxcaml; + "kind_of_", KIND_OF, oxcaml; + "layout_", LAYOUT, oxcaml; + "lazy", LAZY, v1_6; + "let", LET, always; + "local_", LOCAL, oxcaml; + "match", MATCH, always; + "method", METHOD, v1_0; + "mod", MOD, always; + "module", MODULE, always; + "mutable", MUTABLE, always; + "new", NEW, v1_0; + "nonrec", NONREC, v4_2; + "object", OBJECT, v1_0; + "of", OF, always; + "once_", ONCE, oxcaml; + "open", OPEN, always; + "or", OR, always; + "overwrite_", OVERWRITE, oxcaml; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* "parser", PARSER; *) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 "poly_", POLY; "private", PRIVATE; "rec", REC; @@ -153,15 +278,85 @@ let keyword_table : keywords = "lsl", INFIXOP4("lsl"); "lsr", INFIXOP4("lsr"); "asr", INFIXOP4("asr"); +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + "poly_", POLY; + "private", PRIVATE; + "rec", REC; + "repr_", REPR; + "sig", SIG; + "stack_", STACK; + "borrow_", BORROW; + "struct", STRUCT; + "then", THEN; + "to", TO; + "true", TRUE; + "try", TRY; + "type", TYPE; + "unique_", UNIQUE; + "val", VAL; + "virtual", VIRTUAL; + "when", WHEN; + "while", WHILE; + "with", WITH; + + "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) + "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) + "land", INFIXOP3("land"); + "lsl", INFIXOP4("lsl"); + "lsr", INFIXOP4("lsr"); + "asr", INFIXOP4("asr") +======= + "poly_", POLY, oxcaml; + "private", PRIVATE, v1_0; + "rec", REC, always; + "repr_", REPR, oxcaml; + "sig", SIG, always; + "stack_", STACK, oxcaml; + "struct", STRUCT, always; + "then", THEN, always; + "to", TO, always; + "true", TRUE, always; + "try", TRY, always; + "type", TYPE, always; + "unique_", UNIQUE, oxcaml; + "val", VAL, always; + "virtual", VIRTUAL, v1_0; + "when", WHEN, always; + "while", WHILE, always; + "with", WITH, always; + + "lor", INFIXOP3("lor"), always; (* Should be INFIXOP2 *) + "lxor", INFIXOP3("lxor"), always; (* Should be INFIXOP2 *) + "land", INFIXOP3("land"), always; + "lsl", INFIXOP4("lsl"), always; + "lsr", INFIXOP4("lsr"), always; + "asr", INFIXOP4("asr"), always +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 ] let keywords l = create_hashtable 11 l -let lookup_keyword name = - match Hashtbl.find keyword_table name with - | kw -> kw - | exception Not_found -> - LIDENT name + +let keyword_table = Hashtbl.create 149 + +let populate_keywords (version,keywords) = + let greater (x:(int*int) option) (y:(int*int) option) = + match x, y with + | None, _ | _, None -> true + | Some x, Some y -> x >= y + in + let tbl = keyword_table in + Hashtbl.clear tbl; + let add_keyword (name, token, since) = + if greater version since then Hashtbl.replace tbl name (Some token) + in + List.iter add_keyword all_keywords; + List.iter (fun name -> + match List.find (fun (n,_,_) -> n = name) all_keywords with + | (_,tok,_) -> Hashtbl.replace tbl name (Some tok) + | exception Not_found -> Hashtbl.replace tbl name None + ) keywords + (* To buffer string literals *) @@ -444,16 +639,74 @@ let keyword_or state s default = 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 = +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 match lookup_keyword name with | LIDENT _ -> false | _ -> true let () = Lexer.is_keyword_ref := is_keyword +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + match lookup_keyword name with + | LIDENT _ -> false + | _ -> true +======= + Hashtbl.mem keyword_table name +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let check_label_name lexbuf name = if is_keyword name then fail lexbuf (Keyword_as_label name) else return name +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +let check_label_name lexbuf name = + if is_keyword name then error lexbuf (Keyword_as_label name) +======= +let find_keyword lexbuf name = + match Hashtbl.find keyword_table name with + | Some x -> x + | None -> error lexbuf (Unknown_keyword name) + | exception Not_found -> LIDENT 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) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* Update the current location with file name and line number. *) @@ -470,12 +723,27 @@ let update_loc lexbuf _file line absolute chars = pos_bol = pos.pos_cnum - chars; } +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (* Warn about Latin-1 characters used in idents *) let warn_latin1 lexbuf = Location.deprecated (Location.curr lexbuf) "ISO-Latin1 characters in identifiers" ;; +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +(* 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 [] +======= +let handle_docstrings = ref true +let comment_list = ref [] +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let float ~maybe_hash lit modifier = match maybe_hash with @@ -539,11 +807,24 @@ let prepare_error loc = function let msg = "Illegal empty character literal ''" in let sub = [Location.msg +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 "Hint: Did you mean ' ' or a type variable 'a?"] in +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + "@{Hint@}: Did you mean ' ' or a type variable 'a?"] in +======= + "@{Hint@}: Did you mean %a or a type variable %a?" + Style.inline_code "' '" + Style.inline_code "'a" + ] in +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 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) -> @@ -551,6 +832,25 @@ let prepare_error loc = function (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+%04X 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 + | Unknown_keyword name -> + Location.errorf ~loc + "%a has been defined as an additional keyword.@ \ + This version of OCaml does not support this keyword." + Style.inline_code name let () = Location.register_error_of_exn @@ -567,11 +867,32 @@ let newline = ('\013'* '\010') let blank = [' ' '\009' '\012'] let lowercase = ['a'-'z' '_'] let uppercase = ['A'-'Z'] +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 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']*) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +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 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 delim_ext = (lowercase | uppercase | utf8)* +(* ascii uppercase letters in quoted string delimiters ({delim||delim}) are + rejected by the delimiter validation function, we accept them temporarily to + have the same error message for ascii and non-ascii uppercase letters *) + +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] let symbolcharnopercent = @@ -583,8 +904,8 @@ let symbolchar_or_hash = 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' '_']* @@ -643,6 +964,7 @@ rule token state = parse | ".~" { fail lexbuf (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 *) | "~" raw_ident_escape (lowercase identchar * as name) ':' { return (LABEL name) } @@ -651,32 +973,89 @@ rule token state = parse | "~" (lowercase_latin1 identchar_latin1 * as name) ':' { warn_latin1 lexbuf; return (LABEL name) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | "~" raw_ident_escape (lowercase identchar * as name) ':' + { LABEL name } + | "~" (lowercase identchar * as name) ':' + { check_label_name lexbuf name; + LABEL name } + | "~" (lowercase_latin1 identchar_latin1 * as name) ':' + { warn_latin1 lexbuf; + 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 } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | "?" +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 { return QUESTION } | "?" raw_ident_escape (lowercase identchar * as name) ':' { return (OPTLABEL name) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + { QUESTION } + | "?" raw_ident_escape (lowercase identchar * as name) ':' + { OPTLABEL name } +======= + { QUESTION } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | "?" (lowercase identchar * as name) ':' +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 { oPTLABEL (check_label_name lexbuf name) } | "?" (lowercase_latin1 identchar_latin1 * as name) ':' { warn_latin1 lexbuf; return (OPTLABEL name) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + { check_label_name lexbuf name; + OPTLABEL name } + | "?" (lowercase_latin1 identchar_latin1 * as name) ':' + { warn_latin1 lexbuf; + OPTLABEL 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 + } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* Lowercase identifiers are split into 3 cases, and the order matters (longest to shortest). *) | (lowercase identchar * as name) ('#' symbolchar_or_hash+ as hashop) (* See Note [Lexing hack for hash operators] *) { enqueue_hashop_from_end_of_lexbuf_window lexbuf ~hashop; +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 return (try Hashtbl.find state.keywords name with Not_found -> lookup_keyword name) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + lookup_keyword name } +======= + find_keyword lexbuf name } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | (lowercase identchar * as name) '#' (* See Note [Lexing hack for float#] *) { enqueue_hash_suffix_from_end_of_lexbuf_window lexbuf; +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 return (try Hashtbl.find state.keywords name with Not_found -> lookup_keyword name) } | raw_ident_escape (lowercase identchar * as name) { return (LIDENT name) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + lookup_keyword name } + | raw_ident_escape (lowercase identchar * as name) + { LIDENT name } +======= + find_keyword lexbuf name } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | lowercase identchar * as name +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 { return (try Hashtbl.find state.keywords name with Not_found -> lookup_keyword name) } @@ -696,7 +1075,29 @@ rule token state = parse return (LIDENT name) } | lowercase_latin1 identchar_latin1 * as name { warn_latin1 lexbuf; return (LIDENT name) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + { lookup_keyword name } + (* Lowercase latin1 identifiers are split into 3 cases, and the order matters + (longest to shortest). + *) + | (lowercase_latin1 identchar_latin1 * as name) + ('#' symbolchar_or_hash+ as hashop) + (* See Note [Lexing hack for hash operators] *) + { warn_latin1 lexbuf; + enqueue_hashop_from_end_of_lexbuf_window lexbuf ~hashop; + LIDENT name } + | (lowercase_latin1 identchar_latin1 * as name) '#' + (* See Note [Lexing hack for float#] *) + { warn_latin1 lexbuf; + enqueue_hash_suffix_from_end_of_lexbuf_window lexbuf; + LIDENT name } + | lowercase_latin1 identchar_latin1 * as name + { warn_latin1 lexbuf; LIDENT name } +======= + { find_keyword lexbuf name } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | uppercase identchar * as name +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 { (* Capitalized keywords for OUnit *) return (try Hashtbl.find state.keywords name with Not_found -> @@ -705,6 +1106,24 @@ rule token state = parse UIDENT name) } | uppercase_latin1 identchar_latin1 * as name { warn_latin1 lexbuf; return (UIDENT name) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + { UIDENT name } (* No capitalized keywords *) + | uppercase_latin1 identchar_latin1 * as name + { warn_latin1 lexbuf; UIDENT 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 *) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* This matches either an integer literal or a directive. If the text "#2" appears at the beginning of a line that lexes as a directive, then it should be treated as a directive and not an unboxed int. This is acceptable @@ -729,6 +1148,7 @@ rule token state = parse | '#'? (float_literal | hex_float_literal | int_literal) identchar+ as invalid { fail lexbuf (Invalid_literal invalid) } | "\"" +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 { wrap_string_lexer string state lexbuf >>= fun (str, loc) -> return (STRING (str, loc, None)) } | "\'\'" @@ -739,25 +1159,100 @@ rule token state = parse >>= fun (str, loc) -> return (STRING (str, loc, Some delim)) } | "{%" (extattrident as id) "|" +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + { 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) "|" +======= + { let s, loc = wrap_string_lexer string lexbuf in + STRING (s, loc, None) } + | "{" (delim_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) "|" +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 { let orig_loc = Location.curr lexbuf in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 wrap_string_lexer (quoted_string "") state lexbuf >>= fun (str, loc) -> +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in +======= + let id = validate_ext lexbuf raw_id in + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let idloc = compute_quoted_string_idloc orig_loc 2 id in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 return (QUOTED_STRING_EXPR (id, idloc, str, loc, Some "")) } | "{%" (extattrident as id) blank+ (lowercase* as delim) "|" +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") } + | "{%" (extattrident as id) blank+ (lowercase* as delim) "|" +======= + QUOTED_STRING_EXPR (id, idloc, s, loc, Some "") } + | "{%" (extattrident as raw_id) blank+ (delim_ext as raw_delim) "|" +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 { let orig_loc = Location.curr lexbuf in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 wrap_string_lexer (quoted_string delim) state lexbuf >>= fun (str, loc) -> +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let s, loc = wrap_string_lexer (quoted_string delim) 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 +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let idloc = compute_quoted_string_idloc orig_loc 2 id in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 return (QUOTED_STRING_EXPR (id, idloc, str, loc, Some delim)) } | "{%%" (extattrident as id) "|" +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) } + | "{%%" (extattrident as id) "|" +======= + QUOTED_STRING_EXPR (id, idloc, s, loc, Some delim) } + | "{%%" (extattrident as raw_id) "|" +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 { let orig_loc = Location.curr lexbuf in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 wrap_string_lexer (quoted_string "") state lexbuf >>= fun (str, loc) -> +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in +======= + let id = validate_ext lexbuf raw_id in + let s, loc = wrap_string_lexer (quoted_string "") lexbuf in +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let idloc = compute_quoted_string_idloc orig_loc 3 id in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 return (QUOTED_STRING_ITEM (id, idloc, str, loc, Some "")) } | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|" +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") } + | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|" +======= + QUOTED_STRING_ITEM (id, idloc, s, loc, Some "") } + | "{%%" (extattrident as raw_id) blank+ (delim_ext as raw_delim) "|" +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 { let orig_loc = Location.curr lexbuf in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + 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) } +======= + 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) } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 wrap_string_lexer (quoted_string delim) state lexbuf >>= fun (str, loc) -> let idloc = compute_quoted_string_idloc orig_loc 3 id in @@ -1023,10 +1518,32 @@ and comment state = parse state.string_start_loc <- Location.none; Buffer.add_string buffer (String.escaped (Buffer.contents state.buffer)); state.buffer <- buffer; +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 Buffer.add_char state.buffer '\"'; comment state lexbuf } | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|" { +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + is_in_string := false; + store_string_char '\"'; + comment lexbuf } + | "{" ('%' '%'? extattrident blank*)? (lowercase* as delim) "|" + { + string_start_loc := Location.curr lexbuf; + store_lexeme lexbuf; + is_in_string := true; +======= + is_in_string := false; + store_string_char '\"'; + comment lexbuf } + | "{" ('%' '%'? extattrident blank*)? (delim_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; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 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 @@ -1151,9 +1668,38 @@ and quoted_string delim state = parse else (Buffer.add_string state.buffer (Lexing.lexeme lexbuf); quoted_string delim state lexbuf) } +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | ident + { store_lexeme lexbuf; comment lexbuf } +======= + | ident_ext + { store_lexeme lexbuf; comment lexbuf } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | _ +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 { Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0); quoted_string delim state lexbuf } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | eof + { is_in_string := false; + error_loc !string_start_loc Unterminated_string } + | "|" (lowercase* as edelim) "}" + { + if delim = edelim then lexbuf.lex_start_p + else (store_lexeme lexbuf; 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) + } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 and skip_sharp_bang state = parse | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" @@ -1176,6 +1722,19 @@ and skip_sharp_bang state = parse lexbuf.lex_curr_p <- end_pos; return token +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let init () = + is_in_string := false; + comment_start_loc := []; + comment_list := []; +======= + let init ?(keyword_edition=None,[]) () = + populate_keywords keyword_edition; + is_in_string := false; + comment_start_loc := []; + comment_list := []; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let rec token_without_comments state lexbuf = token state lexbuf >>= function | COMMENT _ -> diff --git a/src/ocaml/preprocess/parser_raw.mly b/src/ocaml/preprocess/parser_raw.mly index f6cd07929..445d38b18 100644 --- a/src/ocaml/preprocess/parser_raw.mly +++ b/src/ocaml/preprocess/parser_raw.mly @@ -62,6 +62,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) @@ -94,6 +95,8 @@ let mkcf ~loc ?attrs ?docs d = let mkrhs rhs loc = mkloc rhs (make_loc loc) let ghrhs rhs loc = mkloc rhs (ghost_loc loc) +let ldot lid lid_loc name loc = Ldot (mkrhs lid lid_loc, mkrhs name loc) + let push_loc x acc = if x.Location.loc_ghost then acc @@ -105,7 +108,7 @@ let reloc_pat ~loc x = 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 = +let _reloc_typ ~loc x = { x with ptyp_loc = make_loc loc; ptyp_loc_stack = push_loc x.ptyp_loc x.ptyp_loc_stack } @@ -118,9 +121,24 @@ let mkoperator = let mkpatvar ~loc ?attrs name = mkpat ~loc ?attrs (Ppat_var (mkrhs name loc)) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (* See commentary about ghost locations at the declaration of Location.t *) let ghexp ~loc ?attrs d = Exp.mk ~loc:(ghost_loc loc) ?attrs d let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +(* See commentary about ghost locations at the declaration of Location.t *) +let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d +let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d +======= +(* + See ./location.mli for when to use a ghost location or not. + + Every grammar rule that generates an element with a location must + make at most one non-ghost element, the topmost one. +*) +let ghexp ~loc ?attrs d = Exp.mk ~loc:(ghost_loc loc) ?attrs d +let ghpat ~loc ?attrs d = Pat.mk ~loc:(ghost_loc loc) ?attrs d +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let ghtyp ~loc ?attrs d = Typ.mk ~loc:(ghost_loc loc) ?attrs d let ghloc ~loc d = { txt = d; loc = ghost_loc loc } let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d @@ -137,11 +155,14 @@ let neg_string f = then String.sub f 1 (String.length f - 1) else "-" ^ f -let mkuminus ~oploc name arg = +(* 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 = let result = match arg.pexp_desc with | Pexp_constant const -> begin - match name, const with + match name, const.pconst_desc with | "-", Pconst_integer (n, m) -> Some (Pconst_integer (neg_string n, m)) | "-", Pconst_unboxed_integer (n, m) -> @@ -155,16 +176,22 @@ let mkuminus ~oploc name arg = | _ -> None in match result with - | Some desc -> Pexp_constant desc, arg.pexp_attributes + | Some desc -> Pexp_constant (mkconst ~loc:sloc desc), arg.pexp_attributes | None -> 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 _ | Pconst_unboxed_integer _) - | ("+" | "+."), Pexp_constant (Pconst_float _ | Pconst_unboxed_float _) -> - desc, arg.pexp_attributes + | "+", + Pexp_constant + {pconst_desc = (Pconst_integer _ | Pconst_unboxed_integer _) as desc; + pconst_loc=_} + | ("+" | "+."), + Pexp_constant + {pconst_desc = (Pconst_float _ | Pconst_unboxed_float _) as desc; + pconst_loc=_} -> + Pexp_constant (mkconst ~loc:sloc desc), arg.pexp_attributes | _ -> Pexp_apply (mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]), [] @@ -267,7 +294,9 @@ let rec mktailexp nilloc = let open Location in function | 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 [None, e1; None, ghexp ~loc:el_loc exp_el]) in + let arg = + ghexp ~loc (Pexp_tuple [None, e1; None, ghexp ~loc:el_loc exp_el]) + in ghexp_cons_desc loc arg, loc let rec mktailpat nilloc = let open Location in function @@ -277,7 +306,10 @@ let rec mktailpat nilloc = let open Location in function | 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 ([None, p1; None, ghpat ~loc:el_loc pat_pl], Closed)) in + let arg = + ghpat ~loc + (Ppat_tuple ([None, p1; None, ghpat ~loc:el_loc pat_pl], Closed)) + in ghpat_cons_desc loc arg, loc let mkstrexp e attrs = @@ -388,7 +420,13 @@ let mkexp_type_constraint_with_modes ?(ghost=false) ~loc ~modes e t = | Pcoerce(t1, t2) -> match modes with | [] -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let mk = if ghost then ghexp else mkexp in +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let mk = if ghost then ghexp else mkexp ?attrs:None in +======= + let mk = if ghost then ghexp ?attrs:None else mkexp ?attrs:None in +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 mk ~loc (Pexp_coerce(e, t1, t2)) | _ :: _ -> not_expecting loc "mode annotations"; @@ -455,9 +493,9 @@ type ('dot,'index) array_family = { let bigarray_untuplify exp = match exp.pexp_desc with - | Pexp_tuple explist when - List.for_all (function None, _ -> true | _ -> false) explist -> - List.map (fun (_, e) -> e) explist + | Pexp_tuple explist + when List.for_all (fun (l, _) -> Option.is_none l) explist -> + List.map snd explist | _ -> [exp] (* Immutable array indexing is a regular operator, so it doesn't need a special @@ -476,8 +514,8 @@ let builtin_arraylike_name loc _ ~assign paren_kind n = | Two -> "Array2" | Three -> "Array3" | Many -> "Genarray" in - Ldot(Lident "Bigarray", submodule_name) in - ghloc ~loc (Ldot(prefix,opname)) + Ldot(mknoloc (Lident "Bigarray"), mknoloc submodule_name) in + ghloc ~loc (Ldot(mknoloc prefix, mknoloc opname)) let builtin_arraylike_index loc paren_kind index = match paren_kind with | Paren | Bracket -> One, [Nolabel, index] @@ -507,7 +545,7 @@ let user_indexing_operator_name loc (prefix,ext) ~assign paren_kind n = String.concat "" ["."; ext; left; mid; right; assign] in let lid = match prefix with | None -> Lident name - | Some p -> Ldot(p,name) in + | Some p -> Ldot(mknoloc p,mknoloc name) in ghloc ~loc lid let user_index loc _ index = @@ -538,9 +576,9 @@ let indexop_unclosed_error loc_s s loc_e = unclosed left loc_s right loc_e *) -let lapply ~loc p1 p2 = +let lapply ~loc p1 loc_p1 p2 loc_p2 = if !Clflags.applicative_functors - then Lapply(p1, p2) + then Lapply(mkrhs p1 loc_p1, mkrhs p2 loc_p2) else raise (Syntaxerr.Error( Syntaxerr.Applicative_path (make_loc loc))) @@ -583,33 +621,28 @@ let wrap_type_annotation ~loc ?(typloc=loc) ~modes newtypes core_type body = let inner_type = Typ.varify_constructors (List.map fst newtypes) core_type in (exp, ghtyp ~loc:typloc (Ptyp_poly (newtypes, inner_type))) -let wrap_exp_attrs ~loc body (ext, attrs) = - let ghexp = ghexp ~loc in +let pexp_extension ~id e = Pexp_extension (id, PStr [mkstrexp e []]) + +let mkexp_attrs ~loc desc (ext, attrs) = (* 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 ext_attrs = - wrap_exp_attrs ~loc (mkexp ~loc d) ext_attrs + | None -> mkexp ~loc ~attrs desc + | Some id -> + mkexp ~loc (pexp_extension ~id (ghexp ~loc ~attrs desc)) -let wrap_typ_attrs ~loc typ (ext, attrs) = +let mktyp_attrs ~loc desc (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)) + | None -> mktyp ~loc ~attrs desc + | Some id -> + mktyp ~loc (Ptyp_extension (id, PTyp (ghtyp ~loc ~attrs desc))) -let wrap_pat_attrs ~loc pat (ext, attrs) = +let mkpat_attrs ~loc desc (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 + | None -> mkpat ~loc ~attrs desc + | Some id -> + mkpat ~loc (Ppat_extension (id, PPat (ghpat ~loc ~attrs desc, None))) let wrap_class_attrs ~loc:_ body attrs = {body with pcl_attributes = attrs @ body.pcl_attributes} @@ -618,27 +651,24 @@ let wrap_mod_attrs ~loc:_ attrs body = 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 {psg_items=[body]; - psg_modalities=[]; psg_loc=make_loc loc}), [])) + | None -> mkstr ~loc item + | Some id -> mkstr ~loc (Pstr_extension ((id, PStr [ghstr ~loc item]), [])) let wrap_mksig_ext ~loc (item, ext) = - wrap_sig_ext ~loc (mksig ~loc item) ext + match ext with + | None -> mksig ~loc item + | Some id -> + let psig = + {psg_items=[ghsig ~loc item]; psg_modalities=[]; psg_loc=make_loc loc} + in + mksig ~loc (Psig_extension ((id, PSig psig), [])) 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) @@ -813,9 +843,9 @@ let all_params_as_newtypes = | Pparam_newtype _ -> true | Pparam_val _ -> false in - let as_newtype { pparam_desc; _ } = + let as_newtype { pparam_desc; pparam_loc } = match pparam_desc with - | Pparam_newtype (x, jkind) -> Some (x, jkind) + | Pparam_newtype (x, jkind) -> Some (x, jkind, pparam_loc) | Pparam_val _ -> None in fun params -> @@ -830,7 +860,7 @@ let empty_body_constraint = [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 ~loc = +let mkghost_newtype_function_body newtypes body_constraint body = let wrapped_body = let { ret_type_constraint; mode_annotations; ret_mode_annotations } = body_constraint @@ -840,24 +870,30 @@ let mkghost_newtype_function_body newtypes body_constraint body ~loc = let loc = loc_start, loc_end in mkexp_opt_type_constraint_with_modes ~ghost:true ~loc ~modes body ret_type_constraint in - mk_newtypes ~loc newtypes wrapped_body + let expr = + List.fold_right + (fun (newtype, jkind, 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, jkind, e)) ~loc) + newtypes + wrapped_body + in + expr.pexp_desc -let mkfunction ~loc ~attrs params body_constraint body = +let mkfunction params body_constraint body = match body with - | Pfunction_cases _ -> - mkexp_attrs (Pexp_function (params, body_constraint, body)) attrs ~loc + | Pfunction_cases _ -> Pexp_function (params, body_constraint, body) | Pfunction_body body_exp -> begin (* 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 -> - mkexp_attrs (Pexp_function (params, body_constraint, body)) attrs ~loc + | None -> Pexp_function (params, body_constraint, body) | Some newtypes -> - wrap_exp_attrs - ~loc - (mkghost_newtype_function_body newtypes body_constraint body_exp - ~loc) - attrs + mkghost_newtype_function_body newtypes body_constraint body_exp end let mk_functor_typ args mty_mm = @@ -1040,6 +1076,23 @@ let merloc startpos ?endpos x = let default_loc = ref Location.none let default_expr () = +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +%token DOTDOT ".." +%token DOTHASH ".#" +%token DOWNTO "downto" +%token ELSE "else" +%token END "end" +%token EOF "" +======= +%token DOTDOT ".." +%token DOTHASH ".#" +%token DOWNTO "downto" +%token EFFECT "effect" +%token ELSE "else" +%token END "end" +%token EOF "" +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 Exp.mk ~loc:!default_loc Pexp_hole let default_pattern () = Pat.any ~loc:!default_loc () @@ -1233,6 +1286,11 @@ let merloc startpos ?endpos x = %token DOTTILDE [@cost 1] [@symbol ".~"] %token GREATERDOT [@cost 1] [@symbol ">."] +(* 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 @@ -1297,11 +1355,15 @@ The precedences must be listed from low to high. %nonassoc below_DOT %nonassoc DOT DOTHASH DOTOP /* Finally, the first tokens of simple_expr are above everything else. */ -%nonassoc BACKQUOTE BANG BEGIN CHAR HASH_CHAR FALSE FLOAT HASH_FLOAT - INT HASH_INT OBJECT - LBRACE LBRACELESS LBRACKET LBRACKETBAR LBRACKETCOLON LIDENT LPAREN - NEW PREFIXOP STRING TRUE UIDENT LESSLBRACKET DOLLAR - LBRACKETPERCENT QUOTED_STRING_EXPR HASHLBRACE HASHLPAREN UNDERSCORE +%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 + /* OxCaml additions: */ + HASH_CHAR HASH_FLOAT HASH_INT + LBRACKETCOLON LESSLBRACKET DOLLAR + HASHLBRACE HASHLPAREN UNDERSCORE HASHFALSE HASHTRUE DOTLESS DOTTILDE GREATERDOT @@ -1959,13 +2021,12 @@ structure [@recovery []]: { 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) + { let incl, ext = $1 in + (Pstr_include incl, ext) + } ) { $1 } - | include_statement(module_expr) - { let incl, ext = $1 in - let item = mkstr ~loc:$sloc (Pstr_include incl) in - wrap_str_ext ~loc:$sloc item ext - } ; (* A single module binding. *) @@ -2264,13 +2325,12 @@ signature_item: { let (ext, l) = $1 in (Psig_class l, ext) } | class_type_declarations { let (ext, l) = $1 in (Psig_class_type l, ext) } + | include_statement(module_type) modalities = optional_atat_modalities_expr + { let incl, ext = $1 in + Psig_include (incl, modalities), ext + } ) { $1 } - | include_statement(module_type) modalities = optional_atat_modalities_expr - { let incl, ext = $1 in - let item = mksig ~loc:$sloc (Psig_include (incl, modalities)) in - wrap_sig_ext ~loc:$sloc item ext - } (* A module declaration. *) %inline module_declaration: @@ -2659,8 +2719,8 @@ class_signature: class_self_type: LPAREN core_type RPAREN { $2 } - | mktyp((* empty *) { Ptyp_any None }) - { $1 } + | (* empty *) + { ghtyp ~loc:$sloc (Ptyp_any None) } ; %inline class_sig_fields: flatten(text_csig(class_sig_field)*) @@ -2802,8 +2862,10 @@ class_type_declarations: typechecking. For standalone function cases, we want the compiler to respect, e.g., [@inline] attributes. *) - mkfunction [] empty_body_constraint (Pfunction_cases (cases, loc, [])) ~attrs:$2 - ~loc:$sloc + let desc = + mkfunction [] empty_body_constraint (Pfunction_cases (cases, loc, [])) + in + mkexp_attrs ~loc:$sloc desc $2 } ) { $1 } @@ -2824,9 +2886,7 @@ fun_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)) } + { mkexp_attrs ~loc:$sloc (Pexp_sequence ($1, $5)) (Some $4, []) } ; seq_expr: | or_function(fun_seq_expr) { $1 } @@ -2967,7 +3027,7 @@ fun_: | maybe_stack ( FUN ext_attributes fun_params body_constraint = optional_atomic_constraint_ MINUSGREATER fun_body - { mkfunction $3 body_constraint $6 ~loc:$sloc ~attrs:$2 } + { mkexp_attrs ~loc:$sloc (mkfunction $3 body_constraint $6) $2 } ) { $1 } %public fun_expr [@recovery default_expr ()]: @@ -2990,7 +3050,13 @@ fun_: mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) } | fun_expr COLONCOLON expr { mkexp_cons ~loc:$sloc $loc($2) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (ghexp ~loc:$sloc (Pexp_tuple[None, $1; None, (merloc $endpos($2) $3)])) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + (ghexp ~loc:$sloc (Pexp_tuple[None, $1;None, $3])) } +======= + (ghexp ~loc:$sloc (Pexp_tuple[None,$1;None,$3])) } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | mkrhs(label) LESSMINUS expr { mkexp ~loc:$sloc (Pexp_setvar($1, $3)) } | simple_expr DOT mkrhs(label_longident) LESSMINUS expr @@ -3049,10 +3115,10 @@ fun_: | LAZY ext_attributes simple_expr %prec below_HASH { Pexp_lazy $3, $2 } | subtractive expr %prec prec_unary_minus - { let desc, attrs = mkuminus ~oploc:$loc($1) $1 $2 in + { let desc, attrs = mkuminus ~sloc:$sloc ~oploc:$loc($1) $1 $2 in desc, (None, attrs) } | additive expr %prec prec_unary_plus - { let desc, attrs = mkuplus ~oploc:$loc($1) $1 $2 in + { let desc, attrs = mkuplus ~sloc:$sloc ~oploc:$loc($1) $1 $2 in desc, (None, attrs) } ; %inline expr_: @@ -3119,7 +3185,12 @@ spliceable_expr: (* | indexop_error (DOT, seq_expr) { $1 } | indexop_error (qualified_dotop, expr_semi_list) { $1 } +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 *) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +======= + | metaocaml_expr { $1 } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | simple_expr_attrs { let desc, attrs = $1 in mkexp_attrs ~loc:$sloc desc attrs } @@ -3150,10 +3221,20 @@ spliceable_expr: | NEW ext_attributes mkrhs(class_longident) { Pexp_new($3), $2 } | LPAREN MODULE ext_attributes module_expr RPAREN +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 { Pexp_pack $4, $3 } | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), Some $6, []), $3 } (* +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + { Pexp_pack $4, $3 } + | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN + { Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $4), Some $6, []), $3 } +======= + { Pexp_pack ($4, None), $3 } + | LPAREN MODULE ext_attributes module_expr COLON package_type_ RPAREN + { Pexp_pack ($4, Some $6), $3 } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | LPAREN MODULE ext_attributes module_expr COLON error { unclosed "(" $loc($1) ")" $loc($6) } *) @@ -3262,7 +3343,26 @@ block_access: (* | DOT ident _p=LPAREN seq_expr _e=error { indexop_unclosed_error $loc(_p) Paren $loc(_e) } +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 *) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +======= + +(* 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 + { mkexp ~loc:$sloc (pexp_extension ~id:(mknoloc "metaocaml.escape") e) } + | METAOCAML_BRACKET_OPEN e = seq_expr METAOCAML_BRACKET_CLOSE + { mkexp ~loc:$sloc (pexp_extension ~id:(mknoloc "metaocaml.bracket") e) } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 ; %inline simple_expr_: @@ -3363,10 +3463,10 @@ block_access: { unclosed "[" $loc($3) "]" $loc($5) } *) | od=open_dot_declaration DOT LPAREN MODULE ext_attributes module_expr COLON - package_type RPAREN + ptyp = package_type_ RPAREN { let modexp = mkexp_attrs ~loc:($startpos($3), $endpos) - (Pexp_constraint (ghexp ~loc:$sloc (Pexp_pack $6), Some $8, [])) $5 in + (Pexp_pack ($6, Some ptyp)) $5 in Pexp_open(od, modexp) } (* | mod_longident DOT @@ -3565,9 +3665,7 @@ strict_binding_modes: in {mode_annotations; ret_type_constraint ; ret_mode_annotations } in - let exp = mkfunction $1 constraint_ $4 ~loc:$sloc ~attrs:(None, []) in - { exp with pexp_loc = { exp.pexp_loc with loc_ghost = true } } - + ghexp ~loc:$sloc (mkfunction $1 constraint_ $4) } ; %inline strict_binding: @@ -3581,9 +3679,9 @@ fun_body: | 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 - let function_ = mkfunction [] empty_body_constraint cases ~loc:$sloc ~attrs:$2 in - Pfunction_body function_ + let cases = Pfunction_cases ($3, make_loc $sloc, []) in + let function_ = mkfunction [] empty_body_constraint cases in + Pfunction_body (mkexp_attrs ~loc:$sloc function_ $2) } | fun_seq_expr { Pfunction_body $1 } @@ -3637,7 +3735,7 @@ fun_params: | nonempty_concat(fun_param_as_list) { $1 } ; -(* Parsing labeled tuple expressions +(* Parsing labeled tuple expressions: The grammar we want to parse is something like: @@ -3679,8 +3777,8 @@ fun_params: Some label, mkexpvar ~loc label } | TILDE LPAREN label = LIDENT c = type_constraint RPAREN %prec below_HASH { Some label, - mkexp_type_constraint_with_modes - ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(label) label) c } + mkexp_type_constraint_with_modes ~loc:($startpos($2), $endpos) + ~modes:[] (mkexpvar ~loc:$loc(label) label) c } ; reversed_labeled_tuple_body: (* > 2 elements *) @@ -3706,8 +3804,8 @@ reversed_labeled_tuple_body: COMMA x2 = labeled_tuple_element { let x1 = - mkexp_type_constraint_with_modes - ~loc:($startpos($2), $endpos) ~modes:[] (mkexpvar ~loc:$loc(l1) l1) c + mkexp_type_constraint_with_modes ~loc:($startpos($2), $endpos) + ~modes:[] (mkexpvar ~loc:$loc(l1) l1) c in [ x2; Some l1, x1] } ; @@ -3830,6 +3928,8 @@ pattern [@recovery default_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: @@ -3840,8 +3940,7 @@ pattern_no_exn: %inline pattern_(self): | self COLONCOLON pattern { mkpat_cons ~loc:$sloc $loc($2) - (ghpat ~loc:$sloc (Ppat_tuple ([None, $1;None, $3], Closed))) - } + (ghpat ~loc:$sloc (Ppat_tuple ([None, $1; None, $3], Closed))) } | self attribute { Pat.attr $1 $2 } | pattern_gen @@ -3849,6 +3948,22 @@ pattern_no_exn: | mkpat( self AS mkrhs(val_ident) { Ppat_alias($1, $3) } +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | self AS error + { expecting $loc($3) "identifier" } + | self COLONCOLON error + { expecting $loc($3) "pattern" } + | self BAR pattern +======= + | self AS error + { expecting $loc($3) "identifier" } + | labeled_tuple_pattern(self) + { $1 } + | self COLONCOLON error + { expecting $loc($3) "pattern" } + | self BAR pattern +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (*| self AS error { expecting $loc($3) "identifier" } *) (*| self COLONCOLON error @@ -3858,12 +3973,9 @@ pattern_no_exn: (*| self BAR error { expecting $loc($3) "pattern" } *) ) { $1 } - | reversed_labeled_tuple_pattern(self) - { let closed, pats = $1 in - mkpat ~loc:$sloc (Ppat_tuple (List.rev pats, closed)) - } ; +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (* Parsing labeled tuple patterns Here we play essentially the same game we did for expressions - see the @@ -3921,6 +4033,66 @@ reversed_labeled_tuple_pattern(self): | labeled_tuple_pat_element_noprec(self) COMMA DOTDOT { Open, [ $1 ] } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +(* Parsing labeled tuple patterns + + Here we play essentially the same game we did for expressions - see the + comment beginning "Parsing labeled tuple expressions". + + One difference is that we would need to manually inline the definition of + individual elements in two places: Once in the base case for lists 2 or more + elements, and once in the special case for open patterns with just one + element (e.g., [~x, ..]). Rather than manually inlining + [labeled_tuple_pat_element] twice, we simply define it twice: once with the + [%prec] annotations needed for its occurrences in tail position, and once + without them suitable for use in other locations. +*) +%inline labeled_tuple_pat_element(self): + | self { None, $1 } + | LABEL simple_pattern %prec COMMA + { Some $1, $2 } + | TILDE label = LIDENT + { let loc = $loc(label) in + Some label, mkpatvar ~loc label } + | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN %prec COMMA + { let lbl_loc = $loc(label) in + let pat_loc = $startpos($2), $endpos in + let pat = mkpatvar ~loc:lbl_loc label in + Some label, mkpat_with_modes ~loc:pat_loc ~modes:[] ~pat ~cty:(Some cty) } + +(* If changing this, don't forget to change its copy just above. *) +%inline labeled_tuple_pat_element_noprec(self): + | self { None, $1 } + | LABEL simple_pattern + { Some $1, $2 } + | TILDE label = LIDENT + { let loc = $loc(label) in + Some label, mkpatvar ~loc label } + | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN + { let lbl_loc = $loc(label) in + let pat_loc = $startpos($2), $endpos in + let pat = mkpatvar ~loc:lbl_loc label in + Some label, mkpat_with_modes ~loc:pat_loc ~modes:[] ~pat ~cty:(Some cty) } + +labeled_tuple_pat_element_list(self): + | labeled_tuple_pat_element_list(self) COMMA labeled_tuple_pat_element(self) + { $3 :: $1 } + | labeled_tuple_pat_element_noprec(self) COMMA labeled_tuple_pat_element(self) + { [ $3; $1 ] } + | self COMMA error + { expecting $loc($3) "pattern" } +; + +reversed_labeled_tuple_pattern(self): + | labeled_tuple_pat_element_list(self) %prec below_COMMA + { Closed, $1 } + | labeled_tuple_pat_element_list(self) COMMA DOTDOT + { Open, $1 } + | labeled_tuple_pat_element_noprec(self) COMMA DOTDOT + { Open, [ $1 ] } + +======= +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 pattern_gen: simple_pattern { $1 } @@ -3940,6 +4112,7 @@ pattern_gen: | 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) }) @@ -4041,6 +4214,68 @@ simple_delimited_pattern: Ppat_unboxed_tuple (List.rev fields, closed) } ) { $1 } +(* Parsing labeled tuple patterns: + + Here we play essentially the same game we did for expressions - see the + comment beginning "Parsing labeled tuple expressions". + + One difference is that we would need to manually inline the definition of + individual elements in two places: Once in the base case for lists 2 or more + elements, and once in the special case for open patterns with just one + element (e.g., [~x, ..]). Rather than manually inlining + [labeled_tuple_pat_element] twice, we simply define it twice: once with the + [%prec] annotations needed for its occurrences in tail position, and once + without them suitable for use in other locations. +*) +%inline labeled_tuple_pat_element(self): + | self { None, $1 } + | LABEL simple_pattern %prec COMMA + { Some $1, $2 } + | TILDE label = LIDENT + { let loc = $loc(label) in + Some label, mkpatvar ~loc label } + | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN %prec COMMA + { let lbl_loc = $loc(label) in + let pat_loc = $startpos($2), $endpos in + let pat = mkpatvar ~loc:lbl_loc label in + Some label, + mkpat_with_modes ~loc:pat_loc ~modes:[] ~pat ~cty:(Some cty) } +; +(* If changing this, don't forget to change its copy just above. *) +%inline labeled_tuple_pat_element_noprec(self): + | self { None, $1 } + | LABEL simple_pattern + { Some $1, $2 } + | TILDE label = LIDENT + { let loc = $loc(label) in + Some label, mkpatvar ~loc label } + | TILDE LPAREN label = LIDENT COLON cty = core_type RPAREN + { let lbl_loc = $loc(label) in + let pat_loc = $startpos($2), $endpos in + let pat = mkpatvar ~loc:lbl_loc label in + Some label, mkpat_with_modes ~loc:pat_loc ~modes:[] ~pat ~cty:(Some cty) } +; +labeled_tuple_pat_element_list(self): + | labeled_tuple_pat_element_list(self) COMMA labeled_tuple_pat_element(self) + { $3 :: $1 } + | labeled_tuple_pat_element_noprec(self) COMMA labeled_tuple_pat_element(self) + { [ $3; $1 ] } + | self COMMA error + { expecting $loc($3) "pattern" } +; +reversed_labeled_tuple_pattern(self): + | labeled_tuple_pat_element_list(self) %prec below_COMMA + { Closed, $1 } + | labeled_tuple_pat_element_list(self) COMMA DOTDOT + { Open, $1 } + | labeled_tuple_pat_element_noprec(self) COMMA DOTDOT + { Open, [ $1 ] } +; +labeled_tuple_pattern(self): + | reversed_labeled_tuple_pattern(self) + { let closed, pat = $1 in + Ppat_tuple(List.rev pat, closed) } +; %inline pattern_semi_list: ps = separated_or_terminated_nonempty_list(SEMI, pattern) { ps } @@ -4378,13 +4613,31 @@ type_variance: | INFIXOP2 { if $1 = "+!" then Covariant, Injective else if $1 = "-!" then Contravariant, Injective else +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (expecting $loc($1) "type_variance"; NoVariance, NoInjectivity) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + expecting $loc($1) "type_variance" } +======= + if $1 = "+-" then Bivariant, NoInjectivity else + if $1 = "-+" then Bivariant, NoInjectivity else + if $1 = "+-!" then Bivariant, Injective else + if $1 = "-+!" then Bivariant, Injective else + expecting $loc($1) "type_variance" } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | PREFIXOP { if $1 = "!+" then Covariant, Injective else if $1 = "!-" then Contravariant, Injective else +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (expecting $loc($1) "type_variance"; NoVariance, NoInjectivity) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + expecting $loc($1) "type_variance" } +======= + if $1 = "!+-" then Bivariant, Injective else + if $1 = "!-+" then Bivariant, Injective else + expecting $loc($1) "type_variance" } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 ; (* A sequence of constructor declarations is either a single BAR, which @@ -4535,7 +4788,8 @@ label_declaration_semi: attrs2 = post_item_attributes { let docs = symbol_docs $sloc in let attrs = attrs1 @ attrs2 in - Te.mk tid cs ~params ~priv ~attrs ~docs, + let loc = make_loc $sloc in + Te.mk tid cs ~params ~priv ~attrs ~docs ~loc, ext } ; %inline extension_constructor(opening): @@ -4793,18 +5047,16 @@ strict_function_or_labeled_tuple_type: maybe_curry_typ codomain codomain_loc, arg_modes, ret_modes) } ) { $1 } - (* These next three cases are for labled tuples - see comment on [tuple_type] + (* The next three cases are for labled tuples - see comment on [tuple_type] below. - The first two cases are present just to resolve a shift reduce conflict - in a module type [S with t := x:t1 * t2 -> ...] which might be the - beginning of + The first two cases are present just to resolve a shift/reduce conflict in a + module type [S with t := x:t1 * t2 -> ...] which might be the beginning of [S with t := x:t1 * t2 -> S'] or [S with t := x:t1 * t2 -> t3] - They are the same as the previous two cases, but with [arg_label] replaced - with the more specific [LIDENT COLON] and [param_type] replaced with the - more specific [proper_tuple_type]. Apparently, this is sufficient for - menhir to be able to delay a decision about which of the above module type - cases we are in. *) + They are the same as the previous two cases, but with [arg_label] specialized + to [LIDENT COLON] and the domain type specialized to [proper_tuple_type]. + Apparently, this is sufficient for menhir to be able to delay a decision + about which of the above module type cases we are in. *) | mktyp( label = LIDENT COLON tuple_with_modes = with_optional_mode_expr(proper_tuple_type) @@ -4959,9 +5211,9 @@ optional_atat_modalities_expr: However, the special case of labeled tuples where the first element has a label is not parsed as a proper_tuple_type, but rather as a case of - strict_function_or_labled_tuple_type above. This helps in dealing with - ambiguities around [x:t1 * t2 -> t3] which must continue to parse as a - function with one labeled argument even in the presense of labled tuples. + strict_function_or_labeled_tuple_type above. This resolves ambiguities + around [x:t1 * t2 -> t3] which must continue to parse as a function with one + labeled argument even in the presence of labled tuples. *) tuple_type: | ty = atomic_type @@ -4969,16 +5221,14 @@ tuple_type: { ty } | proper_tuple_type %prec below_FUNCTOR { let ty, ltys = $1 in - mktyp ~loc:$sloc (Ptyp_tuple ((None, ty) :: ltys)) - } + mktyp ~loc:$sloc (Ptyp_tuple ((None, ty) :: ltys)) } ; - %inline proper_tuple_type: | ty = atomic_type STAR ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element) { ty, ltys } - +; (* In the case of an unboxed tuple, we don't need the nonsense above because the [#( ... )] disambiguates. However, we still must write out the first element explicitly because [labeled_tuple_typ_element] is @@ -4994,13 +5244,13 @@ tuple_type: STAR ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element) { (Some label, ty1) :: ltys } - +; %inline labeled_tuple_typ_element : | atomic_type %prec STAR { None, $1 } | label = LIDENT COLON ty = atomic_type %prec STAR { Some label, ty } - +; (* Atomic types are the most basic level in the syntax of types. Atomic types include: - types between parentheses: (int -> int) @@ -5036,8 +5286,8 @@ tuple_type: 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 } + | LPAREN MODULE ext_attrs = ext_attributes package_type = package_type_ RPAREN + { mktyp_attrs ~loc:$sloc (Ptyp_package package_type) ext_attrs } | mktyp( LBRACKET field = tag_field RBRACKET { Ptyp_variant([ field ], Closed, None) } @@ -5166,10 +5416,12 @@ atomic_type: | UNDERSCORE COLON jkind=jkind_annotation { mktyp ~loc:$sloc (Ptyp_any (Some jkind)) } -%inline package_type: module_type +%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 } + Typ.package_type ~loc:(make_loc $sloc) ~attrs lid cstrs } + +%inline package_type: package_type_ + { mktyp ~loc:$sloc (Ptyp_package $1) } ; %inline row_field_list: separated_nonempty_llist(BAR, row_field) @@ -5247,16 +5499,19 @@ meth_list: /* Constants */ value_constant: - | INT { let (n, m) = $1 in Pconst_integer (n, m) } - | CHAR { Pconst_char $1 } + | 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 - Pconst_string (s, strloc, d) } - | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } + mkconst ~loc:$sloc (Pconst_string (s, strloc, d)) } + | FLOAT { let (f, m) = $1 in + mkconst ~loc:$sloc (Pconst_float (f, m)) } ; unboxed_constant: - | HASH_INT { unboxed_int $sloc $sloc Positive $1 } - | HASH_FLOAT { unboxed_float Positive $1 } - | HASH_CHAR { Pconst_untagged_char $1 } + | HASH_INT { mkconst ~loc:$sloc + (unboxed_int $sloc $sloc Positive $1) } + | HASH_FLOAT { mkconst ~loc:$sloc (unboxed_float Positive $1) } + | HASH_CHAR { mkconst ~loc:$sloc (Pconst_untagged_char $1) } ; constant: value_constant { $1 } @@ -5264,18 +5519,24 @@ constant: ; signed_value_constant: value_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)) } ; signed_constant: signed_value_constant { $1 } | unboxed_constant { $1 } - | MINUS HASH_INT { unboxed_int $sloc $loc($2) Negative $2 } - | MINUS HASH_FLOAT { unboxed_float Negative $2 } - | PLUS HASH_INT { unboxed_int $sloc $loc($2) Positive $2 } - | PLUS HASH_FLOAT { unboxed_float Positive $2 } + | MINUS HASH_INT { mkconst ~loc:$sloc + (unboxed_int $sloc $loc($2) Negative $2) } + | MINUS HASH_FLOAT { mkconst ~loc:$sloc (unboxed_float Negative $2) } + | PLUS HASH_INT { mkconst ~loc:$sloc + (unboxed_int $sloc $loc($2) Positive $2) } + | PLUS HASH_FLOAT { mkconst ~loc:$sloc (unboxed_float Positive $2) } ; /* Identifiers and long identifiers */ @@ -5359,14 +5620,34 @@ constr_ident: | constr_extra_nonprefix_ident { $1 } ; constr_longident: +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 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 } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + 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 } +======= + mod_longident %prec below_DOT { $1 } /* A.B.x vs (A).B.x */ + | mod_longident DOT constr_extra_ident { ldot $1 $loc($1) $3 $loc($3) } + | constr_extra_ident { Lident $1 } + | constr_extra_nonprefix_ident { Lident $1 } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 ; mk_longident(prefix,final): +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 | final { Lident $1 } | prefix DOT final { Ldot($1,$3) } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | final { Lident $1 } + | prefix DOT final { Ldot($1,$3) } +======= + | final { Lident $1 } + | prefix DOT final { ldot $1 $loc($1) $3 $loc($3) } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 ; val_longident: mk_longident(mod_longident, val_ident) { $1 } @@ -5393,8 +5674,14 @@ mod_longident: mod_ext_longident: mk_longident(mod_ext_longident, UIDENT) { $1 } | mod_ext_longident LPAREN mod_ext_longident RPAREN +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 { lapply ~loc:$sloc $1 $3 } (* +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + { lapply ~loc:$sloc $1 $3 } +======= + { lapply ~loc:$sloc $1 $loc($1) $3 $loc($3) } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | mod_ext_longident LPAREN error { expecting $loc($3) "module path" } *) @@ -5571,6 +5858,7 @@ single_attr_id: | DO { "do" } | DONE { "done" } | DOWNTO { "downto" } + | EFFECT { "effect" } | ELSE { "else" } | END { "end" } | EXCEPTION { "exception" } diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml index 4f758c839..d0f4853f1 100644 --- a/src/ocaml/typing/cmt_format.ml +++ b/src/ocaml/typing/cmt_format.ml @@ -170,28 +170,30 @@ let iter_on_occurrences let path_in_type typ name = match Types.get_desc typ with | Tconstr (type_path, _, _) -> - Some (Path.Pdot (type_path, name)) + Some (Path.Pextra_ty (type_path, Pcstr_ty name)) | _ -> None in let add_constructor_description env lid = function - | { Types.cstr_tag = Extension path; _ } -> + | { Data_types.cstr_tag = Extension path; _ } -> f ~namespace:Extension_constructor env path lid - | { Types.cstr_uid = Predef name; _} -> + | { Data_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; _ } -> + | { Data_types.cstr_res; cstr_name; _ } -> let path = path_in_type cstr_res cstr_name in Option.iter ~f:(fun path -> f ~namespace:Constructor env path lid) path in - let add_label ~namespace env lid { Types.lbl_name; lbl_res; _ } = + let add_label ~namespace env lid { Data_types.lbl_name; lbl_res; _ } = let path = path_in_type lbl_res lbl_name in Option.iter ~f:(fun path -> f ~namespace env path lid) path in let iter_field_exps ~namespace exp_env fields = Array.iter (fun (label_descr, record_label_definition) -> match record_label_definition with - | Overridden ({ Location.txt; loc}, {exp_loc; _}) + | 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 -> @@ -294,8 +296,8 @@ let iter_on_occurrences (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_package {tpt_path; tpt_txt} -> + f ~namespace:Module_type ctyp_env tpt_path tpt_txt | Ttyp_class (path, lid, _typs) -> (* Deprecated syntax to extend a polymorphic variant *) f ~namespace:Type ctyp_env path lid @@ -318,9 +320,9 @@ let iter_on_occurrences iter_field_pats ~namespace:Label pat_env fields | Tpat_record_unboxed_product (fields, _) -> iter_field_pats ~namespace:Unboxed_label pat_env fields - | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ + | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ | Tpat_fun_layout _ - | Tpat_unboxed_unit | Tpat_unboxed_bool _ | Tpat_tuple _ + | Tpat_unboxed_unit | Tpat_unboxed_bool _ | Tpat_unboxed_tuple _ | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ | Tpat_exception _ | Tpat_or _ -> ()); List.iter ~f:(fun (pat_extra, _, _) -> @@ -422,14 +424,35 @@ let index_occurrences binary_annots = let index : (Longident.t Location.loc * Shape_reduce.result) list ref = ref [] in - let f ~namespace env path (lid : _ Location.loc) = - if not (Location.is_none lid.loc) then + let f ~namespace env path lid = + (* Unlike upstream (which uses [not loc_ghost]), we only filter the [_none_] + sentinel location, to avoid filtering useful ghost locations; see #3137. *) + let not_none { Location.loc; _ } = not (Location.is_none loc) in + let reduce_and_store ~namespace lid path = if not_none 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 + (* Shape reduction can be expensive, but the persistent memoization tables + should make these successive reductions fast. *) + let rec index_components namespace lid path = + let module_ = Shape.Sig_component_kind.Module in + let scraped_path = Path.scrape_extra_ty path in + match lid.Location.txt, scraped_path with + | Longident.Ldot (lid', _), Path.Pdot (path', _) -> + reduce_and_store ~namespace lid path; + index_components module_ lid' path' + | Longident.Lapply (lid', lid''), Path.Papply (path', path'') -> + index_components module_ lid'' path''; + index_components module_ lid' path' + | Longident.Lident _, _ -> + reduce_and_store ~namespace lid path; + | _, _ -> () + in + index_components namespace lid path in iter_on_annots (iter_on_occurrences ~f) binary_annots; Array.of_list !index @@ -539,12 +562,24 @@ let save_cmt target cu binary_annots initial_env cmi shape = Array.sort compare_imports imports; imports in + let cmt_args = + let cmt_args = Array.copy Sys.argv in + cmt_args.(0) <- Location.rewrite_absolute_path Sys.argv.(0); + cmt_args in let cmt = { cmt_modname = cu; cmt_annots; cmt_declaration_dependencies = !uids_deps; +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 cmt_comments = []; cmt_args = Sys.argv; +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + cmt_comments = Lexer.comments (); + cmt_args = Sys.argv; +======= + cmt_comments = Lexer.comments (); + cmt_args; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 cmt_sourcefile = sourcefile; cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); cmt_loadpath = Load_path.get_paths (); diff --git a/src/ocaml/typing/data_types.ml b/src/ocaml/typing/data_types.ml new file mode 100644 index 000000000..e385eed25 --- /dev/null +++ b/src/ocaml/typing/data_types.ml @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Picube, 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 Asttypes +open Types + +(* 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: constructor_argument list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: tag; (* Tag for heap blocks *) + cstr_repr: variant_representation; (* Repr of the outer variant *) + cstr_shape: constructor_representation; (* Repr of the constructor itself *) + cstr_constant: bool; + (* True if it's the constructor of a non-[@@unboxed] variant with 0 bits of + payload. (Or equivalently, if it's represented as either a tagged int or + the null pointer) *) + 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; + } + +let equal_constr c1 c2 = + equal_tag c1.cstr_tag c2.cstr_tag + +let may_equal_constr c1 c2 = + c1.cstr_arity = c2.cstr_arity + && (match c1.cstr_tag,c2.cstr_tag with + | Extension _, Extension _ -> + (* extension constructors may be rebindings of each other *) + true + | tag1, tag2 -> + equal_tag tag1 tag2) + +let cstr_res_type_path cstr = + match get_desc cstr.cstr_res with + | Tconstr (p, _, _) -> p + | _ -> assert false + +type 'a gen_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: mutability; (* Is this a mutable field? *) + lbl_modalities: Mode.Modality.Const.t;(* Modalities on the field *) + lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) + lbl_pos: int; (* Position in type *) + lbl_all: 'a gen_label_description array; (* All the labels in this type *) + lbl_repres: 'a; (* Representation for outer record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +type label_description = record_representation gen_label_description + +type unboxed_label_description = + record_unboxed_product_representation gen_label_description + +type _ record_form = + | Legacy : record_representation record_form + | Unboxed_product : record_unboxed_product_representation record_form + +type record_form_packed = + | P : _ record_form -> record_form_packed + +let record_form_to_string (type rep) (record_form : rep record_form) = + match record_form with + | Legacy -> "record" + | Unboxed_product -> "unboxed record" + +let gen_lbl_res_type_path lbl = + match get_desc lbl.lbl_res with + | Tconstr (p, _, _) -> p + | _ -> assert false + +let lbl_res_type_path lbl = gen_lbl_res_type_path lbl diff --git a/src/ocaml/typing/data_types.mli b/src/ocaml/typing/data_types.mli new file mode 100644 index 000000000..7d5509764 --- /dev/null +++ b/src/ocaml/typing/data_types.mli @@ -0,0 +1,96 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Picube, 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 Asttypes +open Types + +(* 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: constructor_argument list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: tag; (* Tag for heap blocks *) + cstr_repr: variant_representation; (* Repr of the outer variant *) + cstr_shape: constructor_representation; (* Repr of the constructor itself *) + cstr_constant: bool; (* True if all args are void *) + 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; + (* [Some decl] here iff the cstr has an inline record (which is decl) *) + cstr_uid: Uid.t; + } + +(* Constructors are the same: they return (structurally)-equal values + when applied to equal arguments. *) +val equal_constr : + constructor_description -> constructor_description -> bool + +(* Constructors may be the same, given potential rebinding. *) +val may_equal_constr : + constructor_description -> constructor_description -> bool + +(* Type constructor of the constructor's result type. *) +val cstr_res_type_path : constructor_description -> Path.t + +type 'a gen_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: mutability; (* Is this a mutable field? *) + lbl_modalities: Mode.Modality.Const.t; + (* Modalities on the field *) + lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) + lbl_pos: int; (* Position in type *) + lbl_all: 'a gen_label_description array; (* All the labels in this type *) + lbl_repres: 'a; (* Representation for outer record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +type label_description = record_representation gen_label_description + +type unboxed_label_description = + record_unboxed_product_representation gen_label_description + +(** This type tracks the distinction between legacy records ([{ field }]) and + unboxed records ([#{ field }]). Note that [Legacy] includes normal boxed + records, as well as inlined and [[@@unboxed]] records. + + As a GADT, it also lets us avoid duplicating functions that handle both + record forms, such as [Env.find_label_by_name], which has type + ['rep record_form -> Longident.t -> Env.t -> 'rep gen_label_description]. +*) +type _ record_form = + | Legacy : record_representation record_form + | Unboxed_product : record_unboxed_product_representation record_form + +type record_form_packed = + | P : _ record_form -> record_form_packed + +val record_form_to_string : _ record_form -> string + +(* Type constructor of the label record type. *) +val lbl_res_type_path : label_description -> Path.t +val gen_lbl_res_type_path : _ gen_label_description -> Path.t diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml index fbdf2d6e9..a5c7d4b4b 100644 --- a/src/ocaml/typing/env.ml +++ b/src/ocaml/typing/env.ml @@ -27,6 +27,7 @@ open Asttypes open Longident open Path open Types +open Data_types open Local_store @@ -1189,49 +1190,59 @@ let rec address_head = function | Adot (a, _, _) -> address_head a (* The name of the compilation unit currently compiled. *) -module Current_unit_name : sig +module Current_unit : sig val get : unit -> Unit_info.t option - val set : Unit_info.t option -> unit - val is : string -> bool - val is_ident : Ident.t -> bool - val is_path : Path.t -> bool + val set : Unit_info.t -> unit + val unset : unit -> unit + + module Name : sig + val get : unit -> string + val is : string -> 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 unit_info = - current_unit := unit_info - let get_cu () = - Option.map Unit_info.modname (get ()) - let get_name () = - Option.map Compilation_unit.name (get_cu ()) - let is name = - let current_name_string = - Option.map Compilation_unit.Name.to_string (get_name ()) - in - Option.equal String.equal current_name_string (Some name) - let is_ident id = - Ident.is_global 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 -> + Compilation_unit.Name.to_string + (Compilation_unit.name (Unit_info.modname cu)) + let is name = + get () = name + let is_ident id = + Ident.is_global 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_without_locks id tbl with | x -> x | exception Not_found - when Ident.is_global id && not (Current_unit_name.is_ident id) -> + when Ident.is_global id && not (Current_unit.Name.is_ident id) -> Mod_persistent let find_name_module ~mark name tbl = match IdTbl.find_name_and_locks wrap_module ~mark name tbl with | Ok x -> x - | Error locks when not (Current_unit_name.is name) -> + | Error locks when not (Current_unit.Name.is name) -> let path = Pident(Ident.create_persistent name) in path, locks, Mod_persistent | _ -> @@ -1249,7 +1260,7 @@ let short_paths_components name pm = let add_persistent_structure id env = if not (Ident.is_global 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 @@ -1270,7 +1281,7 @@ let add_persistent_structure id env = 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 + if material || not !Clflags.no_alias_deps then IdTbl.add id Mod_persistent env.modules else env.modules @@ -1408,7 +1419,7 @@ let reset_declaration_caches () = () let reset_cache ~preserve_persistent_env = - Current_unit_name.set None; + Current_unit.unset (); if not preserve_persistent_env then Persistent_env.clear !persistent_env; reset_declaration_caches (); @@ -1897,7 +1908,7 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = properly populated. *) assert false | exception Not_found - when Ident.is_global id && not (Current_unit_name.is_ident id) -> + when Ident.is_global id && not (Current_unit.Name.is_ident id) -> Shape.for_persistent_unit (Ident.name id) end | Module_type -> @@ -1934,7 +1945,7 @@ let add_required_unit cu = if not (List.exists (Compilation_unit.equal cu) !required_globals) then required_globals := cu :: !required_globals let add_required_ident id env = - if not !Clflags.transparent_modules && Ident.is_global id then + if not !Clflags.no_alias_deps && Ident.is_global id then let address = find_ident_module_address id env in match address_head address with | AHlocal _ -> () @@ -1962,7 +1973,7 @@ and expand_module_path lax env path = try match find_module_lazy ~alias:true path env with {md_type=Mty_alias path1} -> let path' = normalize_module_path lax env path1 in - if not (lax || !Clflags.transparent_modules) then begin + if not (lax || !Clflags.no_alias_deps) then begin let id = Path.head path in if Ident.is_global_or_predef id && not (Ident.same id (Path.head path')) then add_required_global (Pident id) env @@ -2396,16 +2407,6 @@ let module_declaration_address env id presence md = | Mp_present -> Lazy_backtrack.create_forced (Alocal 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_mode; cm_shape} : _ result = @@ -2467,7 +2468,7 @@ let rec components_of_module_maker | Type_variant (_,repr,umc) -> 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 -> @@ -2521,7 +2522,7 @@ let rec components_of_module_maker | Sig_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 @@ -2652,7 +2653,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)) @@ -2771,13 +2773,21 @@ and store_type ~check ~long_path ~predef id info shape env = let loc = info.type_loc in if check then check_usage loc id info.type_uid +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (fun s -> Warnings.Unused_type_declaration s) type_declarations; +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + (fun s -> Warnings.Unused_type_declaration s) + !type_declarations; +======= + (fun s -> Warnings.Unused_type_declaration (s, Warnings.Declaration)) + !type_declarations; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let store_decl path info env = match info.type_kind with | Type_variant (_,repr,umc) -> 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, umc), List.fold_left @@ -2850,7 +2860,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; @@ -3363,7 +3374,7 @@ let register_parameter modname = 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 @@ -3514,7 +3525,7 @@ let mark_label_used usage uid = | exception Not_found -> () let mark_constructor_description_used usage env cstr = - let ty_path = Btype.cstr_type_path cstr in + let ty_path = cstr_res_type_path cstr in mark_type_path_used env ty_path; match stamped_find used_constructors cstr.cstr_uid with | mark -> mark usage @@ -4042,7 +4053,8 @@ let rec lookup_module_components ~errors ~use ~loc lid env = !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env in Papply (f_path, arg), fcomp_res_mode_with_locks, comps -and lookup_structure_components ~errors ~use ~loc ?(reason = Project) lid env = +and lookup_structure_components ~errors ~use ?(reason = Project) l env = + let { txt=lid; loc } = l in let path, mode_with_locks, comps = lookup_module_components ~errors ~use ~loc lid env in @@ -4070,7 +4082,7 @@ and get_functor_components ~errors ~loc lid env comps = | 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 = +and lookup_all_args ~errors ~use lid0 env = let rec loop_lid_arg args = function | Lident _ | Ldot _ as f_lid -> (f_lid, args) @@ -4079,19 +4091,21 @@ and lookup_all_args ~errors ~use ~loc lid0 env = application at runtime and thus both the functor and the arguments are not closed over. Therefore, they all remains at legacy mode which don't need to be tracked. *) + let { txt = arg_lid; loc } = arg_lid in 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 + loop_lid_arg ((f_lid,arg_path,arg_md.md_type)::args) f_lid.txt 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 f0_lid, args0 = lookup_all_args ~errors ~use 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 = + let { txt = f_lid; loc } = f_lid in get_functor_components ~errors ~loc f_lid env f_comp in check_functor_appl @@ -4150,11 +4164,11 @@ and lookup_module ~errors ~use ~loc lid env = and lookup_dot_module ~errors ~use ~loc l s env = let p, (_, locks), comps = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_modules with + match NameMap.find s.txt comps.comp_modules with | mda -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_module ~use ~loc path mda; (path, locks, mda) | exception Not_found -> @@ -4162,11 +4176,11 @@ and lookup_dot_module ~errors ~use ~loc l s env = let lookup_dot_value ~errors ~use ~loc l s env = let (path, (_, locks), comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_values with + match NameMap.find s.txt comps.comp_values with | vda -> - let path = Pdot(path, s) in + let path = Pdot(path, s.txt) in use_value ~use ~loc path vda; (path, locks, vda) | exception Not_found -> @@ -4174,11 +4188,11 @@ let lookup_dot_value ~errors ~use ~loc l s env = let lookup_dot_type ~errors ~use ~loc l s env = let (p, _, comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_types with + match NameMap.find s.txt comps.comp_types with | tda -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_type ~use ~loc path tda; (path, tda) | exception Not_found -> @@ -4186,11 +4200,11 @@ let lookup_dot_type ~errors ~use ~loc l s env = let lookup_dot_modtype ~errors ~use ~loc l s env = let (p, _, comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_modtypes with + match NameMap.find s.txt comps.comp_modtypes with | mta -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_modtype ~use ~loc path mta.mtda_declaration; (path, mta.mtda_declaration) | exception Not_found -> @@ -4198,39 +4212,39 @@ let lookup_dot_modtype ~errors ~use ~loc l s env = let lookup_dot_class ~errors ~use ~loc l s env = let (p, (_, locks), comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_classes with + match NameMap.find s.txt comps.comp_classes with | clda -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_class ~use ~loc path clda; (path, locks, 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 + let (p, _, comps) = lookup_structure_components ~errors ~use l env in + match NameMap.find s.txt comps.comp_cltypes with | cltda -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) 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_dot_jkind ~errors ~use ~loc l s env = - let (p, _, comps) = lookup_structure_components ~errors ~use ~loc l env in - match NameMap.find s comps.comp_jkinds with + let (p, _, comps) = lookup_structure_components ~errors ~use l env in + match NameMap.find s.txt comps.comp_jkinds with | jkind -> - let path = Pdot(p, s) in + let path = Pdot(p, s.txt) in use_jkind ~use ~loc path jkind; (path, jkind.jkda_declaration) | exception Not_found -> may_lookup_error errors loc env (Unbound_jkind (Ldot(l, s))) let lookup_all_dot_labels ~record_form ~errors ~use ~loc usage l s env = - let (_, _, comps) = lookup_structure_components ~errors ~use ~loc l env in - match NameMap.find s (comp_labels record_form comps) with + let (_, _, comps) = lookup_structure_components ~errors ~use l env in + match NameMap.find s.txt (comp_labels record_form comps) with | [] | exception Not_found -> may_lookup_error errors loc env (Unbound_label (Ldot(l, s), P record_form, usage)) @@ -4243,15 +4257,16 @@ let lookup_all_dot_labels ~record_form ~errors ~use ~loc usage l s env = let lookup_all_dot_constructors ~errors ~use ~loc usage l s env = match l with - | Longident.Lident "*predef*" -> + | { txt=Longident.Lident "*predef*"; _ } -> (* Hack to support compilation of default arguments *) + let { txt=s; loc } = s in lookup_all_ident_constructors ~errors ~use ~loc usage s (Lazy.force initial) | _ -> let (_, (_, locks), comps) = - lookup_structure_components ~errors ~use ~loc l env + lookup_structure_components ~errors ~use l env in - match NameMap.find s comps.comp_constrs with + match NameMap.find s.txt comps.comp_constrs with | [] | exception Not_found -> may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s))) | cstrs -> @@ -4350,9 +4365,9 @@ let open_signature_by_path path env0 = let comps = find_structure_components path env0 in add_components None path env0 comps locks_empty -let open_signature ~errors ~loc slot lid env0 = +let open_signature ~errors slot lid env0 = let (root, mode_with_locks, comps) = - lookup_structure_components ~errors ~use:true ~loc ~reason:Open lid env0 + lookup_structure_components ~errors ~use:true ~reason:Open lid env0 in let _, locks = mode_with_locks in root, mode_with_locks, add_components slot root env0 comps locks @@ -4399,7 +4414,7 @@ let remove_last_open root env0 = (* Open a signature from a file *) let open_pers_signature name env = - open_signature ~errors:false ~loc:Location.none None (Lident name) env + open_signature ~errors:false None (Location.mknoloc (Lident name)) env let open_signature ~used_slot @@ -4447,16 +4462,16 @@ let open_signature end; used := true in - open_signature ~errors:true ~loc:lid.loc (Some slot) lid.txt env + open_signature ~errors:true (Some slot) lid env end - else open_signature ~errors:true ~loc:lid.loc None lid.txt env + else open_signature ~errors:true None lid env (* General forms of the lookup functions *) let lookup_module_path ~errors ~use ~loc ~load lid env = match lid with | Lident s -> - if !Clflags.transparent_modules && not load then + if !Clflags.no_alias_deps && not load then let path, mode_with_locks, () = lookup_ident_module Don't_load ~errors ~use ~loc s env in @@ -4479,7 +4494,7 @@ let lookup_module_instance_path ~errors ~use ~loc ~load name env = [lookup_module_path] on a module not found in the environment *) let locks = IdTbl.get_all_locks env.modules in let path, loc_def = - if !Clflags.transparent_modules && not load then + if !Clflags.no_alias_deps && not load then let path, () = lookup_global_name_module_no_locks Don't_load ~errors ~use ~loc name env in @@ -4529,8 +4544,8 @@ let lid_without_hash = function | None -> None end | Ldot(l, s) -> begin - match string_without_hash s with - | Some s -> Some (Ldot(l, s)) + match string_without_hash s.txt with + | Some txt -> Some (Ldot(l, { s with txt })) | None -> None end | Lapply _ -> None @@ -4825,7 +4840,7 @@ let bound_module name env = match IdTbl.find_name_and_locks wrap_module ~mark:false name env.modules with | Ok _ -> true | Error _ -> - 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 ~allow_excess_args:false @@ -5082,27 +5097,31 @@ end (* 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 print_type_expr : Types.type_expr printer ref = ref (fun _ _ -> assert false) -let spellcheck ppf extract env lid = +module Style = Misc.Style + +let quoted_longident = Style.as_inline_code Pprintast.Doc.longident +let quoted_constr = Style.as_inline_code Pprintast.Doc.constr + +let spellcheck extract env lid = let choices ~path name = Misc.spellcheck (extract path env) name in - match lid with - | Longident.Lapply _ -> () + match lid with + | Longident.Lapply _ -> None | Longident.Lident s -> - Misc.did_you_mean ppf (fun () -> choices ~path:None s) + Misc.did_you_mean (choices ~path:None s) | Longident.Ldot (r, s) -> - Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) + let pp ppf s = + quoted_longident ppf (Longident.Ldot(r, Location.mknoloc s)) + in + Misc.did_you_mean ~pp (choices ~path:(Some r.txt) s.txt) -let spellcheck_name ppf extract env name = - Misc.did_you_mean ppf - (fun () -> Misc.spellcheck (extract env) name) +let spellcheck_name extract env name = + Misc.did_you_mean (Misc.spellcheck (extract env) name) let extract_values path env = fold_values (fun name _ _ _ acc -> name :: acc) path env [] @@ -5133,18 +5152,16 @@ let print_lock_item ppf (item, lid) = match (item : Mode.Hint.lock_item) with | Module -> fprintf ppf "The module %a is" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Class -> fprintf ppf "%a is a class, and classes are always" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Value -> fprintf ppf "The value %a is" - (Style.as_inline_code !print_longident) lid + quoted_longident lid | Constructor -> fprintf ppf "The constructor %a is" - (Style.as_inline_code !print_longident) lid - -module Style = Misc.Style + quoted_longident lid let print_stage ppf stage = if stage = 0 then fprintf ppf "outside any quotations" @@ -5197,134 +5214,160 @@ let print_unbound_in_quotation ppf = | Label -> fprintf ppf "Label" | Constructor -> fprintf ppf "Constructor" -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 +let report_lookup_error_doc loc env = function + | Unbound_value(lid, hint) -> + Location.aligned_error_hint ~loc + "@{Unbound value @}%a" quoted_longident lid + (spellcheck extract_values env lid) + ~sub:( + match hint with + | No_hint ->[] + | Missing_rec def_loc -> + let (_, line, _) = + Location.get_pos_info def_loc.Location.loc_start + in + [Location.msg + "@[@{Hint@}: If this is a recursive definition,@ \ + you should add the %a keyword on line %i@]" + Style.inline_code "rec" + line + ] + ) | Unbound_type lid -> - fprintf ppf "Unbound type constructor %a" - quoted_longident lid; - spellcheck ppf extract_types env lid; + Location.aligned_error_hint ~loc + "@{Unbound type constructor @}%a" + quoted_longident lid + (spellcheck extract_types env lid) | Unbound_module lid -> begin - fprintf ppf "Unbound module %a" - quoted_longident lid; - match find_modtype_by_name_lazy lid env with - | exception Not_found -> spellcheck ppf extract_modules env lid; + let main ppf = + fprintf ppf "@{Unbound module @}%a" quoted_longident lid in + match find_modtype_by_name_lazy lid env with + | exception Not_found -> + Location.aligned_error_hint ~loc "%t" main + (spellcheck extract_modules env lid) | _ -> - fprintf ppf - "@.@[@{Hint@}: There is a module type named %a, %s@]" - quoted_longident lid - "but module types are not modules" + Location.errorf ~loc "%t" main + ~sub:[Location.msg + "@{Hint@}: There is a module type named %a,@ \ + but module types are not modules" + quoted_longident lid + ] end | Unbound_constructor lid -> - fprintf ppf "Unbound constructor %a" - quoted_longident lid; - spellcheck ppf extract_constructors env lid; + Location.aligned_error_hint ~loc + "@{Unbound constructor @}%a" + quoted_constr lid + (spellcheck extract_constructors env lid) | Unbound_label (lid, record_form, usage) -> - let P record_form = record_form in - fprintf ppf "Unbound %s field %a" - (record_form_to_string record_form) - quoted_longident lid; - spellcheck ppf (extract_labels record_form) env lid; - let label_of_other_form = match record_form with - | Legacy -> - (match find_label_by_name Unboxed_product lid env with - | _ -> Some "an unboxed record" - | exception Not_found -> None) - | Unboxed_product -> - (match find_label_by_name Legacy lid env with - | _ -> Some "a boxed record" - | exception Not_found -> None) - in - (match label_of_other_form with - | Some other_form -> - fprintf ppf - "@\n@{Hint@}: @[There is %s field with this name." other_form; - (match record_form, usage with - | Unboxed_product, _ -> - (* If an unboxed field isn't in scope but a boxed field is, then - the boxed field must come from a record that didn't get an unboxed - version. *) - fprintf ppf - "@ Note that float- and [%@%@unboxed]- records don't get unboxed \ - versions." - | Legacy, Projection -> - let print_projection ppf (op, lid) = - fprintf ppf "%s%a" op !print_longident lid - in - fprintf ppf "@ To project an unboxed record field, use %a instead of \ - %a." - (Style.as_inline_code print_projection) (".#", lid) - (Style.as_inline_code print_projection) (".", lid) - | _ -> ()); - fprintf ppf "@]" - | None -> ()); + let P record_form = record_form in + let label_of_other_form = match record_form with + | Legacy -> + (match find_label_by_name Unboxed_product lid env with + | _ -> Some "an unboxed record" + | exception Not_found -> None) + | Unboxed_product -> + (match find_label_by_name Legacy lid env with + | _ -> Some "a boxed record" + | exception Not_found -> None) + in + let sub = + match label_of_other_form with + | Some other_form -> + [ Location.msg + "@{Hint@}: There is %s field with this name." other_form ] + @ + (match record_form, usage with + | Unboxed_product, _ -> + (* If an unboxed field isn't in scope but a boxed field is, then the + boxed field must come from a record that didn't get an unboxed + version. *) + [ Location.msg + "Note that float- and [@@@@unboxed]- records don't get \ + unboxed versions." ] + | Legacy, Projection -> + let print_projection ppf (op, lid) = + fprintf ppf "%s%a" op Pprintast.Doc.longident lid + in + [ Location.msg + "To project an unboxed record field, use %a instead of %a." + (Style.as_inline_code print_projection) (".#", lid) + (Style.as_inline_code print_projection) (".", lid) ] + | _ -> []) + | None -> [] + in + Location.aligned_error_hint ~loc + "@{Unbound %s field @}%a" + (record_form_to_string record_form) + quoted_longident lid + (spellcheck (extract_labels record_form) env lid) + ~sub | Unbound_class lid -> begin - fprintf ppf "Unbound class %a" - quoted_longident lid; + let main ppf = + fprintf ppf "@{Unbound class @}%a" quoted_longident lid + in match find_cltype_by_name lid env with - | exception Not_found -> spellcheck ppf extract_classes env lid; + | exception Not_found -> + Location.aligned_error_hint ~loc "%t" main + (spellcheck extract_classes env lid) | _ -> - fprintf ppf - "@.@[@{Hint@}: There is a class type named %a, %s@]" - quoted_longident lid - "but classes are not class types" + Location.errorf ~loc "%t" main + ~sub:[ + Location.msg + "@{Hint@}: There is a class type named %a,@ \ + but classes are not class types." + quoted_longident lid + ] end | Unbound_modtype lid -> begin - fprintf ppf "Unbound module type %a" - quoted_longident lid; + let main ppf = + fprintf ppf "@{Unbound module type @}%a" + quoted_longident lid in match find_module_by_name_lazy lid env with - | exception Not_found -> spellcheck ppf extract_modtypes env lid; + | exception Not_found -> + Location.aligned_error_hint ~loc "%t" main + (spellcheck extract_modtypes env lid) | _ -> - fprintf ppf - "@.@[@{Hint@}: There is a module named %a, %s@]" - quoted_longident lid - "but modules are not module types" - end + Location.errorf ~loc "%t" main + ~sub:[ + Location.msg + "@{Hint@}: There is a module named %a,@ \ + but modules are not module types" + quoted_longident lid + ] + end | Unbound_cltype lid -> - fprintf ppf "Unbound class type %a" - quoted_longident lid; - spellcheck ppf extract_cltypes env lid + Location.aligned_error_hint ~loc + "@{Unbound class type @}%a" quoted_longident lid + (spellcheck extract_cltypes env lid) | Unbound_jkind lid -> - fprintf ppf "Unbound kind %a" - (Style.as_inline_code !print_longident) lid; - spellcheck ppf extract_jkinds env lid + Location.aligned_error_hint ~loc + "@{Unbound kind @}%a" quoted_longident lid + (spellcheck extract_jkinds env lid) | Unbound_settable_variable s -> - fprintf ppf "Unbound instance variable or mutable variable %a" - Style.inline_code s; - spellcheck_name ppf extract_settable_variables env s + Location.aligned_error_hint ~loc + "@{Unbound instance variable or mutable variable @}%a" + Style.inline_code s + (spellcheck_name extract_settable_variables env s) | Not_a_settable_variable s -> - fprintf ppf "The value %a is not an instance variable or mutable variable" - Style.inline_code s; - spellcheck_name ppf extract_settable_variables env s + Location.aligned_error_hint ~loc + "@{The value @}%a is not an instance variable or mutable \ + variable" + Style.inline_code s + (spellcheck_name extract_settable_variables env s) | Masked_instance_variable lid -> - fprintf ppf - "The instance variable %a@ \ - cannot be accessed from the definition of another instance variable" + Location.errorf ~loc + "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" + Location.errorf ~loc + "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" + Location.errorf ~loc + "The ancestor variable %a@ cannot@ be@ accessed@ from@ \ + the definition of an instance variable" quoted_longident lid | Illegal_reference_to_recursive_module { container; unbound } -> let container = Option.value ~default:"_" container in @@ -5335,7 +5378,7 @@ let report_lookup_error_doc _loc env ppf = function dprintf "the definition of the module %a" Style.inline_code container, dprintf "the module type of %a" Style.inline_code unbound in - fprintf ppf + Location.errorf ~loc "@[This module type is recursive.@ \ This use of the recursive module %a@ \ within %t@ \ @@ -5353,7 +5396,7 @@ let report_lookup_error_doc _loc env ppf = function then dprintf "itself" else dprintf "the module type of %a" Style.inline_code unbound in - fprintf ppf + Location.errorf ~loc "@[This class type is recursive.@ This use of the class type %a@ \ from the recursive module %a@ within the definition of@ \ the class type %a@ in the recursive module %a@ \ @@ -5367,87 +5410,95 @@ let report_lookup_error_doc _loc env ppf = function Style.inline_code container self_or_unbound | Structure_used_as_functor lid -> - fprintf ppf "@[The module %a is a structure, it cannot be applied@]" + Location.errorf ~loc + "The module %a is a structure, it cannot be applied" quoted_longident lid | Abstract_used_as_functor (lid, p) -> - fprintf ppf "@[The module %a is of abstract type %a, it cannot be applied@]" - quoted_longident lid - (Style.as_inline_code !print_path) p + Location.errorf ~loc + "The module %a is of abstract type %a, it cannot be applied" + quoted_longident lid + (Style.as_inline_code pp_path) p | Functor_used_as_structure (lid, reason) -> - fprintf ppf "@[The module %a is a functor, \ - it cannot %a@]" - quoted_longident lid - print_structure_components_reason reason + Location.errorf ~loc + "The module %a is a functor, it cannot %a" + quoted_longident lid + print_structure_components_reason reason | Abstract_used_as_structure (lid, p, reason) -> - fprintf ppf "@[The module %a is of abstract type %a, \ - it cannot %a@]" - quoted_longident lid - (Style.as_inline_code !print_path) p - print_structure_components_reason reason + Location.errorf ~loc + "The module %a is of abstract type %a, it cannot %a" + quoted_longident lid + (Style.as_inline_code pp_path) p + print_structure_components_reason reason | Generative_used_as_applicative lid -> - fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ - applied@ in@ type@ expressions@]" + Location.errorf ~loc + "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" + if Current_unit.Name.is_path p then "is the current compilation unit" else "is missing" in - fprintf ppf + Location.errorf ~loc "The module %a is an alias for module %a, which %s" quoted_longident lid - (Style.as_inline_code !print_path) p cause + (Style.as_inline_code pp_path) p cause | Local_value_used_in_exclave (item, lid) -> - fprintf ppf "@[%a local, so it cannot be used \ - inside an exclave_@]" + Location.errorf ~loc + "%a local, so it cannot be used inside an exclave_" print_lock_item (item, lid) | Non_value_used_in_object (lid, typ, err) -> - fprintf ppf "@[%a must have a type of layout value because it is \ - captured by an object.@ %a@]" + Location.errorf ~loc + "%a must have a type of layout value because it is captured by an \ + object.@ %a" quoted_longident lid - (fun v -> !report_jkind_violation_with_offender + (fun ppf v -> !report_jkind_violation_with_offender ~offender:(fun ppf -> !print_type_expr ppf typ) - env v) + env ppf v) err | No_unboxed_version (lid, decl) -> - fprintf ppf "@[The type %a has no unboxed version.@]" - quoted_longident lid; - begin match decl.type_kind with - | Type_record (_, Record_unboxed, _) -> - fprintf ppf - "@.@[@{Hint@}: \ - [%@%@unboxed] records don't get unboxed versions.@]" - | Type_record (_, (Record_float | Record_ufloat | Record_mixed _), _) -> - fprintf ppf - "@.@[@{Hint@}: Float records don't get unboxed versions.@]"; - | Type_record_unboxed_product _ -> - fprintf ppf "@.@[@{Hint@}: It is already an unboxed record.@]"; - | _ -> () - end + let sub = + match decl.type_kind with + | Type_record (_, Record_unboxed, _) -> + [Location.msg + "@{Hint@}: [@@@@unboxed] records don't get unboxed \ + versions."] + | Type_record (_, (Record_float | Record_ufloat | + Record_mixed _), _) -> + [Location.msg + "@{Hint@}: Float records don't get unboxed versions."] + | Type_record_unboxed_product _ -> + [Location.msg + "@{Hint@}: It is already an unboxed record."] + | _ -> [] + in + Location.errorf ~loc ~sub + "The type %a has no unboxed version." + quoted_longident lid | Error_from_persistent_env err -> - Persistent_env.report_error_doc ppf err + Location.error_of_printer ~loc Persistent_env.report_error_doc err | Mutable_value_used_in_closure ctx -> - fprintf ppf - "@[Mutable variable cannot be used inside %t.@]" + Location.errorf ~loc + "Mutable variable cannot be used inside %t." ((Mode.print_pinpoint ctx |> Option.get) ~definite:false ~capitalize:false) | Incompatible_stage (lid, usage_loc, usage_stage, intro_loc, intro_stage) -> - fprintf ppf - "@[Identifier %a is used at %a,@ \ + Location.errorf ~loc + "Identifier %a is used at %a,@ \ %a;@ \ it is introduced at %a,@ \ - %a.@]" + %a." quoted_longident lid (Location.Doc.loc ~capitalize_first:false) usage_loc print_stage usage_stage (Location.Doc.loc ~capitalize_first:false) intro_loc print_stage intro_stage | Unbound_in_stage (context, lid, usage_loc, usage_stage, avail_stage) -> - fprintf ppf - "@[%a %a used at %a@ \ + Location.errorf ~loc + "%a %a used at %a@ \ cannot be used in this context;@ \ %a is not defined %a.@]\ - @.@[@{Hint@}: %a %a is defined %a.@]" + @.@[@{Hint@}: %a %a is defined %a." print_unbound_in_quotation context quoted_longident lid (Location.Doc.loc ~capitalize_first:false) usage_loc @@ -5457,9 +5508,9 @@ let report_lookup_error_doc _loc env ppf = function quoted_longident lid print_stage avail_stage -let report_error_doc ppf = function - | Missing_module(_, path1, path2) -> - fprintf ppf "@[@["; +let report_error_doc = function + | Missing_module(loc, path1, path2) -> + let pp_path path1 path2 ppf = if Path.same path1 path2 then fprintf ppf "Internal path@ %a@ is dangling." Style.inline_code (Path.name path1) @@ -5467,37 +5518,90 @@ let report_error_doc ppf = function 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" + in + Location.errorf ~loc + "%t@ @[The compiled interface for module@ %a@ was not found.@]" + (pp_path path1 path2) 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." + | Illegal_value_name(loc, name) -> + Location.errorf ~loc "%a is not a valid value identifier." Style.inline_code name - | Implicit_jkind_already_defined { name; defined_at; loc = _ } -> - fprintf ppf + | Lookup_error(loc, t, err) -> report_lookup_error_doc loc t err + | Implicit_jkind_already_defined { name; defined_at; loc } -> + Location.errorf ~loc "@[The implicit kind for %a is already defined at %a.@]" Style.inline_code name (Location.Doc.loc ~capitalize_first:false) defined_at - | Lookup_error(loc, t, err) -> report_lookup_error_doc loc t ppf err | Incomplete_instantiation { unset_param } -> - fprintf ppf "@[Not enough instance arguments: the parameter@ %a@ is \ - required.@]" + Location.errorf ~loc:Location.none + "@[Not enough instance arguments: \ + the parameter@ %a@ is required.@]" Global_module.Parameter_name.print unset_param | Toplevel_splice loc -> - fprintf ppf + Location.errorf ~loc "@[Splices ($) are not allowed in the initial stage,@ \ as encountered at %a.@,\ Did you forget to insert a quotation?@]" (Location.Doc.loc ~capitalize_first:false) loc | Unsupported_inside_quotation (loc, context) -> - fprintf ppf + Location.errorf ~loc "@[%a@ is not supported inside quoted expressions,@ \ as seen at %a.@]" print_unsupported_quotation context (Location.Doc.loc ~capitalize_first:false) loc let () = +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + Location.register_error_of_exn + (function + | Error err -> + let loc = + match err with + | Missing_module (loc, _, _) + | Illegal_value_name (loc, _) + | Implicit_jkind_already_defined { loc; _ } + | Toplevel_splice loc + | Unsupported_inside_quotation (loc, _) + | Lookup_error(loc, _, _) -> loc + | Incomplete_instantiation _ -> Location.none + in + let error_of_printer = + if loc = Location.none + then Location.error_of_printer_file + else Location.error_of_printer ~loc ?sub:None + in + Some + (error_of_printer + report_error_doc err) + | _ -> + None + ) + +let () = + let get_current_compilation_unit () = + Option.map Unit_info.modname (get_unit_name ()) + in + Compilation_unit.Private.fwd_get_current := get_current_compilation_unit + +let report_lookup_error loc t = + Format_doc.compat (report_lookup_error_doc loc t) +let report_error = Format_doc.compat report_error_doc +======= + Location.register_error_of_exn + (function + | Error err -> + Some (report_error_doc err) + | _ -> + None + ) + +let () = + let get_current_compilation_unit () = + Option.map Unit_info.modname (get_current_unit ()) + in + Compilation_unit.Private.fwd_get_current := get_current_compilation_unit +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 Location.register_error_of_exn (function | Error err -> diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli index 499d50857..63df30baa 100644 --- a/src/ocaml/typing/env.mli +++ b/src/ocaml/typing/env.mli @@ -16,6 +16,7 @@ (* Environment handling *) open Types +open Data_types open Misc module Jkind = Btype.Jkind0 @@ -429,8 +430,20 @@ val add_value_lazy: val add_value: ?check:(string -> Warnings.t) -> mode:(Mode.allowed * 'r) Mode.Value.t -> Ident.t -> value_description -> t -> t +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 val add_type: check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t val add_type_long_path: check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + ?check:(string -> Warnings.t) -> mode:(Mode.allowed * 'r) Mode.Value.t -> + Ident.t -> Types.value_description -> t -> t +val add_type: + check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t +======= + ?check:(string -> Warnings.t) -> mode:(Mode.allowed * 'r) Mode.Value.t -> + Ident.t -> Types.value_description -> t -> t +val add_type: + check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 val add_extension: check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t -> extension_constructor -> t -> t @@ -574,9 +587,10 @@ val reset_cache: preserve_persistent_env:bool -> 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: Unit_info.t option -> unit -val get_unit_name: unit -> Unit_info.t option +(* 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: @@ -679,14 +693,6 @@ type 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 @@ -720,8 +726,6 @@ val same_constr: (t -> type_expr -> type_expr -> bool) ref val constrain_type_jkind: (t -> type_expr -> jkind_r -> (unit, Jkind.Violation.t) result) 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 (* Forward declaration to break mutual recursion with Printtyp. *) val print_type_expr: Types.type_expr Format_doc.printer ref diff --git a/src/ocaml/typing/errortrace_report.ml b/src/ocaml/typing/errortrace_report.ml new file mode 100644 index 000000000..42e8873dd --- /dev/null +++ b/src/ocaml/typing/errortrace_report.ml @@ -0,0 +1,657 @@ +(**************************************************************************) +(* *) +(* 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_arg env ty = + let ty, vars = Btype.tpoly_get_poly ty in + if vars <> [] then false + else begin + match Types.get_desc (Ctype.expand_head env ty) with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + end + +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_arg 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_arg 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 + | Types.Fixed_existential -> 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 | Fixed_existential)) -> + (* 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 ~missing_label_msg {Errortrace.got;expected} = + let quoted_label ppf l = + Style.inline_code ppf (Printtyp.string_of_label l) + in + match got, expected with + | Types.Nolabel, Types.(Labelled _ | Optional _ | Position _) -> + doc_printf "@,@[A label@ %a@ was expected@]" + quoted_label expected + | Types.(Labelled _ | Optional _ | Position _), Types.Nolabel -> + doc_printf missing_label_msg + quoted_label got + | Types.Labelled g, Types.Optional e when g = e -> + doc_printf + "@,@[The label@ %a@ was expected to be optional@]" + quoted_label got + | Types.Optional g, Types.Labelled e when g = e -> + doc_printf + "@,@[The label@ %a@ was expected to not be optional@]" + quoted_label got + | Types.(Labelled _ | Optional _ | Position _), + Types.(Labelled _ | Optional _ | Position _) -> + doc_printf "@,@[Labels %a@ and@ %a do not match@]" + quoted_label got + quoted_label expected + | Types.Nolabel, Types.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 -> + let missing_label_msg = + format_of_string + "@,@[The first argument is labeled@ %a,@ \ + but an unlabeled argument was expected@]" + in + Some(explain_label_mismatch ~missing_label_msg diff) + | Errortrace.Tuple_label_mismatch diff -> + let types_label = function + | None -> Types.Nolabel + | Some x -> Types.Labelled x + in + let diff = Errortrace.map_diff types_label diff in + let missing_label_msg = + format_of_string + "@,@[The first tuple element is labeled@ %a,@ \ + but an unlabeled element was expected@]" + in + Some(explain_label_mismatch ~missing_label_msg diff) + | 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 + | Errortrace.Bad_jkind (t,e) -> + Some (doc_printf "@ @[%a@]" + (Jkind.Violation.report_with_offender + ~offender:(fun ppf -> + prepare_for_printing [t]; + prepared_type_expr ppf t) + env) e) + | Errortrace.Bad_jkind_sort (t,e) -> + Some (doc_printf "@ @[%a@]" + (Jkind.Violation.report_with_offender_sort + ~offender:(fun ppf -> + prepare_for_printing [t]; + prepared_type_expr ppf t) + env) e) + | Errortrace.Unequal_var_jkinds (t1,k1,t2,k2) -> + let fmt_history t k ppf = + Jkind.(format_history env ~intro:( + dprintf "The layout of %a is %a" prepared_type_expr t + (format env) k) ppf k) + in + Some (doc_printf "@ because the layouts of their variables are different.\ + @ @[%t@;%t@]" + (fmt_history t1 k1) (fmt_history t2 k2)) + | Errortrace.Unequal_tof_kind_jkinds (k1, k2) -> + let fmt_history which k ppf = + Jkind.(format_history env ~intro:( + dprintf "The kind of %s is %a" which (format env) k) ppf k) + in + Some (doc_printf "@ because their kinds are different.\ + @ @[%t@;%t@]" + (fmt_history "the first" k1) (fmt_history "the second" k2)) + +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 ~var_jkinds mode txt_got txt_but = function + | None -> Format_doc.Doc.empty + | Some d -> + let d = + Errortrace.map_diff (trees_of_type_expansion' ~var_jkinds 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 + let jkind_error = match Misc.last tr with + | Some (Bad_jkind _ | Bad_jkind_sort _ | Unequal_var_jkinds _ + | Unequal_tof_kind_jkinds _) -> + true + | _ -> + false + 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 ~var_jkinds:jkind_error 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 && not jkind_error + (* the jkinds mechanism has its own way of reporting missing cmis + CR jkinds: streamline these *) + 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/gprinttyp.ml b/src/ocaml/typing/gprinttyp.ml new file mode 100644 index 000000000..91a7d5cd9 --- /dev/null +++ b/src/ocaml/typing/gprinttyp.ml @@ -0,0 +1,999 @@ +(**************************************************************************) +(* *) +(* 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 } + type level_and_scope = { level:int; scope: int } + type 'a desc = { + id: 'a; + color: Decoration.color option; + desc: Types.type_desc; + lvl:level_and_scope; + } + val subnode: name:string -> t -> t + val either_ext: Types.row_field_cell -> t + val split: params -> Types.type_expr -> t 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 level_and_scope = { level:int; scope: int } + type 'a desc = { + id: 'a; + color: Decoration.color option; + desc: Types.type_desc; + lvl:level_and_scope; + } + + 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 + let scope = Types.Transient_expr.get_scope x in + let level = x.level in + { id = pretty_id params x.id; + color; + desc = x.desc; + lvl = {level;scope} + } + + 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.txt s.txt + | Longident.Lapply(f,x) -> + fprintf ppf "%a(%a)" longident f.txt longident x.txt + + 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" + | Some Types.Fixed_existential -> fprintf ppf "existential" + + 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 + | Types.Nolabel -> () + | Types.Labelled s -> fprintf ppf "%s" s + | Types.Optional s -> fprintf ppf "?%s" s + | Types.Position 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 + + (* Use unicode superscript digit to circumvent graphviz limited support for + superscript. *) + let superscript_digit ppf n = + let s = match n with + | 1 -> "¹" + | 2 -> "²" + | 3 -> "³" + | 0 -> "⁰" + | 4 -> "⁴" + | 5 -> "⁵" + | 6 -> "⁶" + | 7 -> "⁷" + | 8 -> "⁸" + | 9 -> "⁹" + | _ -> assert false + in + Format.pp_print_string ppf s + + let rec superscript ppf n = + if n < 10 then + superscript_digit ppf n + else begin + superscript ppf (n/10); + superscript_digit ppf (n mod 10) + end + + let superscript_level ppf lvl = + (* avoid a dependency on Btype *) + if lvl = Ident.highest_scope then Format.pp_print_string ppf "᪲" + else superscript ppf lvl + + let add_node explicit_d color id ?lvl tynode dg = + let d = match lvl with + | None -> labelf "%a" Pp.prettier_index id + | Some {Index.level; scope=0} -> + labelf "%a %a" + Pp.prettier_index id superscript_level level + | Some {Index.level; scope} -> + labelf "%a %a⁺%a" + Pp.prettier_index id + superscript_level level + superscript scope + 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 {Index.id; _ } as desc = Index.split params ty0 in + let tynode = Node id in + if Elt_map.mem tynode g then id, None + else id, Some { desc with id = tynode } + + 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 Index.{id=tynode; color; desc; lvl} -> + id, node params color ~lvl 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 labeled_edge params id0 (i,gh) (l,ty) = + let l = + match l with + | None -> labelr "%d" i + | Some l -> labelr "%d%s" i l + in + i + 1, edge params id0 l ty gh + and labeled_edges params id0 l gh = + snd @@ List.fold_left + (labeled_edge params id0) + (0,gh) l + and node params color ~lvl id tynode desc dg = + let add_tynode l = add_node l color ~lvl 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 "*" |> labeled_edges params id tl + | Types.Tunboxed_tuple tl -> + mk "#*" |> labeled_edges params id 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 {Index.color; desc; lvl; _ } -> + group_fields ~params ~prev_id:id ~lvl + dg.elts dg.graph empty_subgraph + ~id:next_id ~color ~desc + end + | Types.Tfield _ -> + group_fields ~params ~prev_id:id ~lvl + dg.elts dg.graph empty_subgraph + ~color ~id ~desc + | Types.Tnil -> mk "[Nil]" + | Types.Tquote t -> mk "[Quote]" |> std_edge t + | Types.Tsplice t -> mk "[Splice]" |> std_edge t + | Types.Tquote_eval t -> mk "[QuoteEval]" |> std_edge t + | 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.Trepr (t, _sort_vars) -> + mk "[Repr]" |> std_edge t + | 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 {pack_path; pack_cstrs} -> + let types = List.map snd pack_cstrs in + let pp_cstrs ppf (l, _) = + Pp.longident ppf (Option.get @@ Longident.unflatten l) + in + mk "[mod %a with %a]" + pp_path pack_path + Pp.(list ~sep:semi pp_cstrs) pack_cstrs + |> numbered types + | Types.Tof_kind _ -> + mk "[Kind]" + 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 ~lvl ~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 {Index.color; desc; lvl; _} -> + group_fields ~params ~prev_id:id ~lvl + 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 ~lvl 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/src/ocaml/typing/gprinttyp.mli b/src/ocaml/typing/gprinttyp.mli new file mode 100644 index 000000000..e6bbd61c3 --- /dev/null +++ b/src/ocaml/typing/gprinttyp.mli @@ -0,0 +1,326 @@ +(**************************************************************************) +(* *) +(* 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 +{[ + .---------------. + | lvl | + | 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/src/ocaml/typing/ident.ml b/src/ocaml/typing/ident.ml index 1d4e321af..5fdf7992b 100644 --- a/src/ocaml/typing/ident.ml +++ b/src/ocaml/typing/ident.ml @@ -131,6 +131,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 @@ -168,9 +171,38 @@ let to_global = function | Global_with_args g -> Some g | _ -> None +let canonical_stamps = s_table Hashtbl.create 0 +let next_canonical_stamp = s_table Hashtbl.create 0 + +let canonicalize name stamp = + try Hashtbl.find !canonical_stamps (name, stamp) + with Not_found -> + let canonical_stamp = + try Hashtbl.find !next_canonical_stamp name + with Not_found -> 0 + in + Hashtbl.replace !next_canonical_stamp name + (canonical_stamp + 1); + Hashtbl.add !canonical_stamps (name, stamp) + canonical_stamp; + canonical_stamp + +let pp_stamped ppf (name, stamp) = + let open Format_doc in + if not !Clflags.unique_ids then + fprintf ppf "%s" name + else begin + let stamp = + if not !Clflags.canonical_ids then stamp + else canonicalize name stamp + in + fprintf ppf "%s/%i" name stamp + end + let print ~with_scope ppf = let open Format_doc in function +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 | Global name -> fprintf ppf "%s!" name | Predef { name; stamp = n } -> fprintf ppf "%s/%i!" name n @@ -178,6 +210,30 @@ let print ~with_scope ppf = fprintf ppf "%s/%i" name n | Scoped { name; stamp = n; scope } -> fprintf ppf "%s/%i%s" name n +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | 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 "") +======= + | Global name -> + fprintf ppf "%s!" name + | Predef { name; stamp } -> + fprintf ppf "%a!" + pp_stamped (name, stamp) + | Local { name; stamp } -> + fprintf ppf "%a" + pp_stamped (name, stamp) + | Scoped { name; stamp; scope } -> + fprintf ppf "%a%s" + pp_stamped (name, stamp) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (if with_scope then asprintf "[%i]" scope else "") | Global_with_args g -> fprintf ppf "%a!" Global_module.Name.print g diff --git a/src/ocaml/typing/includemod.ml b/src/ocaml/typing/includemod.ml index c8ef7111a..80b8f5a66 100644 --- a/src/ocaml/typing/includemod.ml +++ b/src/ocaml/typing/includemod.ml @@ -111,11 +111,13 @@ module Error = struct | Param of (functor_parameter, unit) functor_param_symptom | Incompatible - and functor_params_diff = - (functor_parameter list * module_type, functor_params_symptom) diff + and functor_params_info = + { params: functor_parameter list; res: module_type } + and functor_params_diff = (functor_params_info, functor_params_symptom) diff and signature_symptom = { env: Env.t; + subst: Subst.t; missings: signature_item list; incompatibles: (Ident.t * sigitem_symptom) list; } @@ -149,6 +151,12 @@ module Error = struct | In_Jkind_declaration of Ident.t * core_sigitem_symptom | In_Expansion of core_module_type_symptom + let cons_arg arg params_info = + { params = arg :: params_info.params; res = params_info.res } + + let functor_params info1 info2 symptom = + Error (Functor (Params (diff info1 info2 symptom))) + end module Directionality = struct @@ -245,79 +253,87 @@ let modes_unit = let modes_toplevel = Specific ((Env.mode_unit, None), Env.mode_unit) -(* 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 ~direction subst id ~mmodes vd1 vd2 = - if Directionality.mark_as_used direction 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) ~mmodes vd1 vd2) - with Includecore.Dont_match err -> - Error Error.(Core (Value_descriptions (mdiff vd1 vd2 mmodes err))) - -(* Inclusion between type declarations *) +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 ~direction subst id ~mmodes vd1 vd2 = + if Directionality.mark_as_used direction 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) ~mmodes + vd1 vd2) + with Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (mdiff vd1 vd2 mmodes err))) + + (* Inclusion between type declarations *) + + let type_declarations ~loc env ~direction subst id ~mmodes:_ decl1 decl2 = + let mark = Directionality.mark_as_used direction 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 ~direction subst id ~mmodes:_ ext1 ext2 = + let mark = Directionality.mark_as_used direction 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 jkind declarations *) + + let jkind_declarations ~loc env ~direction subst id ~mmodes:_ decl1 decl2 = + let mark = Directionality.mark_as_used direction in + if mark then + Env.mark_jkind_used decl1.jkind_uid; + let decl2 = Subst.jkind_declaration subst decl2 in + match + Includecore.jkind_declarations ~loc env (Ident.name id) decl1 decl2 + with + | None -> Ok Tcoerce_none + | Some err -> + Error Error.(Core(Jkind_declarations (diff decl1 decl2 err))) + + (* Inclusion between class declarations *) + + let class_type_declarations ~loc env ~direction:_ subst _id ~mmodes:_ 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 ~direction:_ subst id ~mmodes decl1 decl2 = + let modes = Includecore.child_modes (Ident.name id) mmodes in + match Includecore.check_modes env ~item:Class modes with + | Error e -> + Error Error.(Core(Class_declarations( + mdiff decl1 decl2 mmodes (Class_mode e)))) + | Ok () -> + 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( + mdiff decl1 decl2 mmodes (Class_type reason)))) +end -let type_declarations ~loc env ~direction subst id decl1 decl2 = - let mark = Directionality.mark_as_used direction 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 ~direction subst id ext1 ext2 = - let mark = Directionality.mark_as_used direction 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 jkind declarations *) -let jkind_declarations ~loc env ~direction subst id decl1 decl2 = - let mark = Directionality.mark_as_used direction in - if mark then - Env.mark_jkind_used decl1.jkind_uid; - let decl2 = Subst.jkind_declaration subst decl2 in - match Includecore.jkind_declarations ~loc env (Ident.name id) decl1 decl2 with - | None -> Ok Tcoerce_none - | Some err -> - Error Error.(Core(Jkind_declarations (diff decl1 decl2 err))) - -(* Inclusion between class declarations *) - -let class_type_declarations ~loc 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 env subst id ~mmodes decl1 decl2 = - let modes = Includecore.child_modes (Ident.name id) mmodes in - match Includecore.check_modes env ~item:Class modes with - | Error e -> - Error Error.(Core(Class_declarations( - mdiff decl1 decl2 mmodes (Class_mode e)))) - | Ok () -> - 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( - mdiff decl1 decl2 mmodes (Class_type reason)))) (* Extract name, kind and ident from a signature item *) @@ -426,11 +442,13 @@ 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 - (Format_doc.compat Printtyp.raw_type_expr) pc_type + Rawprinttyp.type_expr pc_type | Tcoerce_alias (_, p, c) -> pr "@[<2>alias %a@ (%a)@]" - Printtyp.Compat.path p + Printtyp.path p print_coercion c + | Tcoerce_invalid -> + pr "invalid_coercion" and print_coercion2 ppf (n, c) = Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c and print_coercion3 ppf (i, n, c) = @@ -542,8 +560,16 @@ let retrieve_functor_params env mty = (* the function is only used for functor parameter diff, so the return mode is intentionally ignored. *) retrieve_functor_params (p :: before) env res +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 | Mty_ident _ | Mty_alias _ | Mty_signature _ | Mty_strengthen _ | Mty_for_hole as res -> List.rev before, res +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | Mty_ident _ | Mty_alias _ | Mty_signature _ | Mty_strengthen _ as res -> + List.rev before, res +======= + | Mty_ident _ | Mty_alias _ | Mty_signature _ | Mty_strengthen _ as res -> + { Error.params = List.rev before; res } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 in retrieve_functor_params [] env mty @@ -592,6 +618,25 @@ 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 -> direction:Directionality.t -> Subst.t -> Ident.t -> + mmodes:modes -> '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; + jkind_declarations: Types.jkind_declaration core_incl; +} + (* Quickly compare module types without expanding them, succeeding only if mty1 is a subtype of mty2 with no coercion *) let rec shallow_modtypes env subst mty1 mty2 = @@ -629,8 +674,8 @@ and shallow_module_paths env subst p1 mty2 p2 = | Mty_alias _ | Mty_ident _ | Mty_signature _ | Mty_functor _ | Mty_for_hole | exception Not_found -> false -let rec modtypes ~direction ~loc env subst ~modes mty1 mty2 shape = - match try_modtypes ~direction ~loc env subst ~modes mty1 mty2 shape with +let rec modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 shape = + match try_modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 shape with | Ok _ as ok -> ok | Error reason -> let mty1 = Subst.Lazy.force_modtype mty1 in @@ -639,7 +684,7 @@ let rec modtypes ~direction ~loc env subst ~modes mty1 mty2 shape = in Error Error.(mdiff mty1 mty2 modes reason) -and try_modtypes ~direction ~loc env subst ~modes +and try_modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 orig_shape = let open Subst.Lazy in (* Do a quick nominal comparison for simple types and if that fails, try to @@ -659,14 +704,14 @@ and try_modtypes ~direction ~loc env subst ~modes in begin match mty1, mty2 with | Some mty1, Some mty2 -> - try_modtypes ~direction ~loc env subst ~modes mty1 mty2 orig_shape + try_modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 + orig_shape | _, _ -> Error (Error.Mode e) end | Ok () -> Ok (Tcoerce_none, orig_shape) end - | (Mty_alias p1, _) when not (is_alias mty2) -> begin match Env.normalize_module_path (Some Location.none) env p1 @@ -676,8 +721,8 @@ and try_modtypes ~direction ~loc env subst ~modes | p1 -> begin match Env.find_module_lazy p1 env with | md -> begin - match strengthened_modtypes ~direction ~loc ~aliasable:true env - subst ~modes md.md_type p1 mty2 orig_shape + match strengthened_modtypes ~core ~direction ~loc ~aliasable:true + env subst ~modes md.md_type p1 mty2 orig_shape with | Ok _ as x -> x | Error reason -> Error (Error.After_alias_expansion reason) @@ -694,7 +739,7 @@ and try_modtypes ~direction ~loc env subst ~modes |> map_error (fun e -> Error.Mode e) in begin match - signatures ~direction ~loc env subst ~modes sig1 sig2 orig_shape + signatures ~core ~direction ~loc env subst ~modes sig1 sig2 orig_shape with | Ok _ as ok -> ok | Error e -> Error (Error.Signature e) @@ -708,7 +753,7 @@ and try_modtypes ~direction ~loc env subst ~modes in let cc_arg, env, subst = let direction = Directionality.negate direction in - functor_param ~direction ~loc env + functor_param ~core ~direction ~loc env subst param1 param2 in let var, res_shape = @@ -716,10 +761,10 @@ and try_modtypes ~direction ~loc env subst ~modes | 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 @@ -728,7 +773,7 @@ and try_modtypes ~direction ~loc env subst ~modes let cc_res : (_, _ Error.mdiff) result = let mres1 = Mode.alloc_as_value mres1 in let mres2 = Mode.alloc_as_value mres2 in - modtypes ~direction ~loc env subst res1 res2 res_shape + modtypes ~core ~direction ~loc env subst res1 res2 res_shape ~modes:(Specific ((mres1, None), mres2)) in begin match cc_arg, cc_res with @@ -747,27 +792,19 @@ and try_modtypes ~direction ~loc env subst ~modes 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.diff - (force_functor_parameter param1::got_params, got_res) - (force_functor_parameter param2::expected_params, expected_res) - res.symptom + let got = Error.cons_arg (force_functor_parameter param1) res.got in + let expected = + Error.cons_arg (force_functor_parameter param2) res.expected in - Error Error.(Functor (Params d)) + Error.functor_params got expected res.symptom | Error symptom, _ -> - let params1, res1 = - retrieve_functor_params env (Subst.Lazy.force_modtype res1) - in - let params2, res2 = - retrieve_functor_params env (Subst.Lazy.force_modtype res2) + let params env param res = + Error.cons_arg (force_functor_parameter param) + (retrieve_functor_params env (Subst.Lazy.force_modtype res)) in - let d = Error.diff - (force_functor_parameter param1::params1, res1) - (force_functor_parameter param2::params2, res2) + Error.functor_params + (params env param1 res1) (params env param2 res2) (Error.Param symptom) - in - Error Error.(Functor (Params d)) | Ok _, Error res -> Error Error.(Functor (Result res)) end @@ -787,7 +824,7 @@ and try_modtypes ~direction ~loc env subst ~modes in match red with | Some (mty1,mty2) -> - try_modtypes ~direction ~loc env subst ~modes mty1 mty2 orig_shape + try_modtypes ~core ~direction ~loc env subst ~modes mty1 mty2 orig_shape | None -> (* Report error *) match mty1, mty2 with @@ -802,14 +839,10 @@ and try_modtypes ~direction ~loc env subst ~modes Error Error.(Mt_core Incompatible_aliases) | Mty_functor _, _ | _, Mty_functor _ -> - let params1 = - retrieve_functor_params env (Subst.Lazy.force_modtype mty1) - in - let params2 = - retrieve_functor_params env (Subst.Lazy.force_modtype mty2) - in - let d = Error.diff params1 params2 Error.Incompatible in - Error Error.(Functor (Params d)) + Error.functor_params + (retrieve_functor_params env (Subst.Lazy.force_modtype mty1)) + (retrieve_functor_params env (Subst.Lazy.force_modtype mty2)) + Error.Incompatible | _, (Mty_ident _ | Mty_strengthen _) -> Error Error.(Mt_core Not_an_identifier) | _, Mty_alias _ -> @@ -821,7 +854,7 @@ and try_modtypes ~direction ~loc env subst ~modes (* Functor parameters *) -and functor_param ~direction ~loc env subst param1 param2 = +and functor_param ~core ~direction ~loc env subst param1 param2 = let open Subst.Lazy in match param1, param2 with | Unit, Unit -> @@ -832,7 +865,7 @@ and functor_param ~direction ~loc env subst param1 param2 = let marg2 = Mode.alloc_as_value marg2 in let cc_arg = match - modtypes ~direction ~loc env Subst.identity arg2' arg1 + modtypes ~core ~direction ~loc env Subst.identity arg2' arg1 Shape.dummy_mod ~modes:(Specific ((marg2, None), marg1)) with | Ok (cc, _) -> Ok cc @@ -862,22 +895,22 @@ and equate_one_functor_param subst env arg2' name1 name2 = | None, None -> env, subst -and strengthened_modtypes ~direction ~loc ~aliasable env - subst ~modes mty1 path1 mty2 shape = +and strengthened_modtypes ~core ~direction ~loc ~aliasable env + subst mty1 path1 mty2 shape = let mty1 = Mtype.strengthen_lazy ~aliasable mty1 path1 in - modtypes ~direction ~loc env subst ~modes mty1 mty2 shape + modtypes ~core ~direction ~loc env subst mty1 mty2 shape -and strengthened_module_decl ~loc ~aliasable ~direction env +and strengthened_module_decl ~loc ~aliasable ~core ~direction env subst ~mmodes md1 path1 md2 shape = let md1 = Subst.Lazy.of_module_decl md1 in let md1 = Mtype.strengthen_lazy_decl ~aliasable md1 path1 in let mty2 = Subst.Lazy.of_modtype md2.md_type in let modes = mmodes in - modtypes ~direction ~loc env subst ~modes md1.md_type mty2 shape + modtypes ~core ~direction ~loc env subst ~modes md1.md_type mty2 shape (* Inclusion between signatures *) -and signatures ~direction ~loc env subst ~modes sig1 sig2 mod_shape = +and signatures ~core ~direction ~loc env subst ~modes sig1 sig2 mod_shape = let open Subst.Lazy in (* Environment used to check inclusion of components *) let sig1 = force_signature_once sig1 in @@ -905,7 +938,7 @@ and signatures ~direction ~loc env subst ~modes sig1 sig2 mod_shape = (* Do the pairing and checking, and return the final coercion *) let paired, unpaired, subst = pair_components subst comps1 sig2 in let d = - signature_components ~direction ~loc new_env subst mod_shape + signature_components ~core ~direction ~loc new_env subst mod_shape Shape.Map.empty ~mmodes:modes (List.rev paired) in @@ -936,14 +969,16 @@ and signatures ~direction ~loc env subst ~modes sig1 sig2 mod_shape = | missings, incompatibles, _runtime_coercions, _leftovers -> Error { Error.env=new_env; + subst; missings = List.map force_signature_item missings; incompatibles; } (* Inclusion between signature components *) and signature_components : - 'a. direction:_ -> loc:_ -> _ -> _ -> _ -> _ -> mmodes:_ -> (_ * _ * 'a) list -> 'a Sign_diff.t = - fun ~direction ~loc env subst orig_shape shape_map ~mmodes paired -> + 'a. core:_ -> direction:_ -> loc:_ -> _ -> _ -> _ -> _ -> + mmodes:_ -> (_ * _ * 'a) list -> 'a Sign_diff.t = + fun ~core ~direction ~loc env subst orig_shape shape_map ~mmodes paired -> let open Subst.Lazy in match paired with | [] -> Sign_diff.{ empty with shape_map } @@ -953,7 +988,7 @@ and signature_components : match sigi1, sigi2 with | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) -> let item = - value_descriptions ~loc ~direction env subst id1 ~mmodes + core.value_descriptions ~loc ~direction env subst id1 ~mmodes (Subst.Lazy.force_value_description valdecl1) (Subst.Lazy.force_value_description valdecl2) in @@ -967,7 +1002,8 @@ and signature_components : id1, item, paired_uids, shape_map, present_at_runtime | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) -> let item = - type_declarations ~loc ~direction env subst id1 tydec1 tydec2 + core.type_declarations ~loc ~direction env subst id1 ~mmodes + tydec1 tydec2 in let item = mark_error_as_unrecoverable item in (* Right now we don't filter hidden constructors / labels from the @@ -976,7 +1012,8 @@ and signature_components : id1, item, (tydec1.type_uid, tydec2.type_uid), shape_map, false | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> let item = - extension_constructors ~loc ~direction env subst id1 ext1 ext2 + core.extension_constructors ~loc ~direction env subst id1 + ~mmodes ext1 ext2 in let item = mark_error_as_unrecoverable item in let shape_map = @@ -989,8 +1026,8 @@ and signature_components : Shape.(proj orig_shape (Item.module_ id1)) in let item = - module_declarations ~direction ~loc env subst id1 mty1 mty2 - ~mmodes orig_shape + module_declarations ~core ~direction ~loc env subst id1 + mty1 mty2 ~mmodes orig_shape in let item, shape_map = match item with @@ -1019,7 +1056,7 @@ and signature_components : end | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> let item = - modtype_infos ~direction ~loc env subst id1 info1 info2 + modtype_infos ~core ~direction ~loc env subst id1 info1 info2 in let shape_map = Shape.Map.add_module_type_proj shape_map id1 orig_shape @@ -1028,7 +1065,8 @@ and signature_components : id1, item, (info1.mtd_uid, info2.mtd_uid), shape_map, false | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> let item = - class_declarations env subst id1 ~mmodes decl1 decl2 + core.class_declarations ~loc ~direction env subst id1 ~mmodes + decl1 decl2 in let shape_map = Shape.Map.add_class_proj shape_map id1 orig_shape @@ -1037,7 +1075,8 @@ and signature_components : id1, item, (decl1.cty_uid, decl2.cty_uid), shape_map, true | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> let item = - class_type_declarations ~loc env subst info1 info2 + core.class_type_declarations ~loc ~direction env subst id1 ~mmodes + info1 info2 in let item = mark_error_as_unrecoverable item in let shape_map = @@ -1046,7 +1085,8 @@ and signature_components : id1, item, (info1.clty_uid, info2.clty_uid), shape_map, false | Sig_jkind (id1, jd1, _), Sig_jkind (_id2, jd2, _) -> let item = - jkind_declarations ~loc env ~direction subst id1 jd1 jd2 + core.jkind_declarations ~loc env ~direction subst id1 ~mmodes jd1 + jd2 in let item = mark_error_as_unrecoverable item in let shape_map = Shape.Map.add_jkind_proj shape_map id1 orig_shape in @@ -1090,7 +1130,7 @@ and signature_components : in let rest = if continue then - signature_components ~direction ~loc env subst + signature_components ~core ~direction ~loc env subst orig_shape shape_map ~mmodes rem else let rem = List.map @@ -1104,7 +1144,8 @@ and signature_components : in Sign_diff.merge first rest -and module_declarations ~direction ~loc env subst id1 ~mmodes md1 md2 orig_shape = +and module_declarations ~core ~direction ~loc env subst id1 ~mmodes md1 md2 + orig_shape = let open Subst.Lazy in Builtin_attributes.check_alerts_inclusion ~def:md1.md_loc @@ -1121,13 +1162,13 @@ and module_declarations ~direction ~loc env subst id1 ~mmodes md1 md2 orig_shape Includecore.child_modes_with_modalities id ~modalities mmodes |> map_error (fun e -> Error.(Core (Modalities e))) in - strengthened_modtypes ~direction ~loc ~aliasable:true env subst ~modes + strengthened_modtypes ~core ~direction ~loc ~aliasable:true env subst ~modes md1.md_type p1 md2.md_type orig_shape |> map_error (fun x -> Error.Module_type x) (* Inclusion between module type specifications *) -and modtype_infos ~direction ~loc env subst id info1 info2 = +and modtype_infos ~core ~direction ~loc env subst id info1 info2 = let open Subst.Lazy in Builtin_attributes.check_alerts_inclusion ~def:info1.mtd_loc @@ -1141,10 +1182,10 @@ and modtype_infos ~direction ~loc env subst id info1 info2 = (None, None) -> Ok Tcoerce_none | (Some _, None) -> Ok Tcoerce_none | (Some mty1, Some mty2) -> - check_modtype_equiv ~direction ~loc env mty1 mty2 + check_modtype_equiv ~core ~direction ~loc env mty1 mty2 | (None, Some mty2) -> let mty1 = Mty_ident(Path.Pident id) in - check_modtype_equiv ~direction ~loc env mty1 mty2 in + check_modtype_equiv ~core ~direction ~loc env mty1 mty2 in match r with | Ok _ as ok -> ok | Error e -> @@ -1152,11 +1193,11 @@ and modtype_infos ~direction ~loc env subst id info1 info2 = let info2 = Subst.Lazy.force_modtype_decl info2 in Error Error.(Module_type_declaration (diff info1 info2 e)) -and check_modtype_equiv ~direction ~loc env mty1 mty2 = +and check_modtype_equiv ~core ~direction ~loc env mty1 mty2 = let nested_eq = direction.Directionality.in_eq in let direction = Directionality.enter_eq direction in let c1 = - modtypes ~direction ~loc env Subst.identity mty1 mty2 Shape.dummy_mod + modtypes ~core ~direction ~loc env Subst.identity mty1 mty2 Shape.dummy_mod ~modes:All in let c2 = @@ -1168,7 +1209,7 @@ and check_modtype_equiv ~direction ~loc env mty1 mty2 = else let direction = Directionality.negate direction in Some ( - modtypes ~direction ~loc env Subst.identity ~modes:All + modtypes ~core ~direction ~loc env Subst.identity ~modes:All mty2 mty1 Shape.dummy_mod ) in @@ -1183,11 +1224,11 @@ and check_modtype_equiv ~direction ~loc env mty1 mty2 = | Error less_than, Some Error greater_than -> Error Error.(Incomparable {less_than; greater_than}) -let include_functor_signatures ~direction ~loc env subst sig1 sig2 +let include_functor_signatures ~core ~direction ~loc env subst sig1 sig2 ~modes mod_shape = let _, _, comps1 = build_component_table (fun _pos name -> name) sig1 in let paired, unpaired, subst = pair_components subst comps1 sig2 in - let d = signature_components ~direction ~loc env subst mod_shape + let d = signature_components ~core ~direction ~loc env subst mod_shape Shape.Map.empty ~mmodes:modes (List.rev paired) in @@ -1196,8 +1237,16 @@ let include_functor_signatures ~direction ~loc env subst sig1 sig2 | [], [], [] -> Ok d.runtime_coercions | missings, incompatibles, _leftovers -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let missings = List.map Subst.Lazy.force_signature_item missings in Error Error.{ env; missings; incompatibles } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let missings = List.map Subst.Lazy.force_signature_item missings in + Error Error.{ env; missings; incompatibles } +======= + let missings = List.map Subst.Lazy.force_signature_item missings in + Error Error.{ env; subst; missings; incompatibles } +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let can_alias env path = let rec no_apply = function @@ -1207,6 +1256,54 @@ 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; + jkind_declarations; +} + +let core_consistency = + let type_declarations ~loc:_ env ~direction:_ _ _ ~mmodes:_ 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 ~direction:_ _ _ ~mmodes:_ vd1 vd2 = + match Includecore.value_descriptions_consistency env vd1 vd2 with + | x -> Ok x + | exception Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (mdiff vd1 vd2 All err))) + in + let accept ~loc:_ _env ~direction:_ _subst _id ~mmodes:_ _d1 _d2 = + Ok Tcoerce_none + in + { + type_declarations; + value_descriptions; + class_declarations=accept; + class_type_declarations=accept; + extension_constructors=accept; + jkind_declarations=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 + * Typedtree.mode_with_locks) list ; + } let signatures ~direction ~loc env subst sig1 sig2 mod_shape = let sig1 = Subst.Lazy.of_signature sig1 in @@ -1225,28 +1322,11 @@ let strengthened_modtypes ~direction ~loc ~aliasable env strengthened_modtypes ~direction ~loc ~aliasable env subst mty1 path1 mty2 shape -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 - * Typedtree.mode_with_locks) list ; - } - let check_functor_application_raw ~loc env mty1 path1 mty2 = let aliasable = can_alias env path1 in let direction = Directionality.unknown ~mark:true in - strengthened_modtypes ~direction ~loc ~aliasable env - Subst.identity ~modes:All mty1 path1 mty2 - Shape.dummy_mod + strengthened_modtypes ~core:core_inclusion ~direction ~loc ~aliasable env + Subst.identity ~modes:All mty1 path1 mty2 Shape.dummy_mod |> Result.map fst let check_functor_application ~loc env mty1 path1 mty2 = @@ -1285,10 +1365,11 @@ let () = let compunit0 ~comparison env ~mark impl_name impl_sig intf_name intf_sig unit_shape = + let loc = Location.in_file impl_name in let direction = Directionality.strictly_positive ~mark ~both:false in match - signatures ~direction ~loc:(Location.in_file impl_name) env - Subst.identity ~modes:modes_unit impl_sig intf_sig unit_shape + signatures ~core:core_inclusion ~direction ~loc env Subst.identity + ~modes:modes_unit impl_sig intf_sig unit_shape with Result.Error reasons -> let diff = Error.diff impl_name intf_name reasons in let cdiff = @@ -1359,8 +1440,8 @@ module Functor_inclusion_diff = struct | None -> None | Some res -> match retrieve_functor_params env res with - | [], _ -> None - | params, res -> + | { params = []; _ } -> None + | { params; res} -> let more = Array.of_list params in Some (keep_expansible_param res, more) @@ -1401,7 +1482,8 @@ module Functor_inclusion_diff = struct in expand_params { st with env; subst } - let diff env (l1,res1) (l2,_) = + type inclusion_env = { i_env:Env.t; i_subst:Subst.t } + let diff {i_env=env; i_subst=subst} (l1,res1) (l2,_) = let module Compute = Diff.Left_variadic(struct let test st mty1 mty2 = let loc = Location.none in @@ -1409,7 +1491,7 @@ module Functor_inclusion_diff = struct let mty1 = Subst.Lazy.of_functor_parameter mty1 in let mty2 = Subst.Lazy.of_functor_parameter mty2 in let direction = Directionality.unknown ~mark:false in - functor_param ~direction ~loc st.env + functor_param ~core:core_inclusion ~direction ~loc st.env st.subst mty1 mty2 in res @@ -1420,7 +1502,7 @@ module Functor_inclusion_diff = struct 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} + { env; subst; res = keep_expansible_param res1} in Compute.diff state param1 param2 @@ -1495,7 +1577,7 @@ module Functor_app_diff = struct I.expand_params { st with env; res} let diff env ~f ~args = - let params, res = retrieve_functor_params env f in + let {Error.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,arg_mode) param = @@ -1509,7 +1591,7 @@ module Functor_app_diff = struct let param_m = Mode.alloc_as_value param_m in let direction = Directionality.unknown ~mark:false in match - modtypes ~direction ~loc state.env + modtypes ~core:core_inclusion ~direction ~loc state.env state.subst arg_mty param ~modes:(Specific (arg_mode, param_m)) Shape.dummy_mod with @@ -1534,23 +1616,35 @@ end let modtypes_constraint ~shape ~loc env ~mark ~modes mty1 mty2 = (* modtypes with shape is used when typing module expressions in [Typemod] *) let direction = Directionality.strictly_positive ~mark ~both:true in - match modtypes ~direction ~loc env - Subst.identity ~modes mty1 mty2 shape + match + modtypes ~core:core_inclusion ~direction ~loc env + Subst.identity ~modes 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 = + let direction = Directionality.unknown ~mark:false in + match + modtypes ~core:core_consistency ~direction ~loc env Subst.identity + ~modes:All mty1 mty2 Shape.dummy_mod + with + | Ok _ -> () + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + let modtypes ~loc env ~mark ~modes mty1 mty2 = let direction = Directionality.unknown ~mark in - match modtypes ~direction ~loc env - Subst.identity ~modes mty1 mty2 Shape.dummy_mod + match + modtypes ~core:core_inclusion ~direction ~loc env Subst.identity + ~modes mty1 mty2 Shape.dummy_mod with | Ok (cc, _) -> cc | Error reason -> raise (Error (env, Error.(In_Module_type reason))) let gen_signatures env ~direction ~modes sig1 sig2 = - match signatures ~direction ~loc:Location.none env - Subst.identity ~modes sig1 sig2 Shape.dummy_mod + match + signatures ~core:core_inclusion ~direction ~loc:Location.none env + Subst.identity ~modes sig1 sig2 Shape.dummy_mod with | Ok (cc, _) -> cc | Error reason -> raise (Error(env,Error.(In_Signature reason))) @@ -1569,15 +1663,19 @@ let include_functor_signatures env ~mark sig1 sig2 ~modes = let sig1 = List.map Subst.Lazy.of_signature_item sig1 in let sig2 = List.map Subst.Lazy.of_signature_item sig2 in let direction = Directionality.unknown ~mark in - match include_functor_signatures ~direction ~loc:Location.none env + match include_functor_signatures ~core:core_inclusion ~direction + ~loc:Location.none env Subst.identity sig1 sig2 ~modes Shape.dummy_mod with | Ok cc -> cc - | Error reason -> raise (Error(env,Error.(In_Include_functor_signature reason))) + | Error reason -> + raise (Error(env,Error.(In_Include_functor_signature reason))) let type_declarations ~loc env ~mark id decl1 decl2 = let direction = Directionality.unknown ~mark in - match type_declarations ~loc env ~direction Subst.identity id decl1 decl2 with + match Core_inclusion.type_declarations ~loc env ~direction + Subst.identity id ~mmodes:All decl1 decl2 + with | Ok _ -> () | Error (Error.Core reason) -> raise (Error(env,Error.(In_Type_declaration(id,reason)))) @@ -1586,7 +1684,8 @@ let type_declarations ~loc env ~mark id decl1 decl2 = let jkind_declarations ~loc env ~mark id decl1 decl2 = let direction = Directionality.unknown ~mark in match - jkind_declarations ~loc env ~direction Subst.identity id decl1 decl2 + Core_inclusion.jkind_declarations ~loc env ~direction + Subst.identity id ~mmodes:All decl1 decl2 with | Ok _ -> () | Error (Error.Core reason) -> @@ -1595,8 +1694,8 @@ let jkind_declarations ~loc env ~mark id decl1 decl2 = let strengthened_module_decl ~loc ~aliasable env ~mark ~mmodes md1 path1 md2 = let direction = Directionality.unknown ~mark in - match strengthened_module_decl ~loc ~aliasable ~direction env Subst.identity - ~mmodes md1 path1 md2 Shape.dummy_mod with + match strengthened_module_decl ~core:core_inclusion ~loc ~aliasable ~direction + env Subst.identity ~mmodes md1 path1 md2 Shape.dummy_mod with | Ok (x, _shape) -> x | Error d -> raise (Error(env,Error.(In_Module_type d))) @@ -1611,7 +1710,9 @@ let check_modtype_equiv ~loc env id mty1 mty2 = let mty1' = Subst.Lazy.of_modtype mty1 in let mty2' = Subst.Lazy.of_modtype mty2 in let direction = Directionality.unknown ~mark:true in - match check_modtype_equiv ~direction ~loc env mty1' mty2' with + match + check_modtype_equiv ~core:core_inclusion ~direction ~loc env mty1' mty2' + with | Ok _ -> () | Error e -> raise (Error(env, diff --git a/src/ocaml/typing/mtype.ml b/src/ocaml/typing/mtype.ml index db99f6a7e..cc10269d9 100644 --- a/src/ocaml/typing/mtype.ml +++ b/src/ocaml/typing/mtype.ml @@ -458,9 +458,17 @@ let scrape env mty = | _ -> mty let () = +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 Printtyp.expand_module_type := expand ; Env.scrape_alias := scrape_alias_lazy ; Env.scrape_lazy := scrape_lazy +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + Printtyp.expand_module_type := expand ; + Env.scrape_alias := scrape_alias_lazy +======= + Out_type.expand_module_type := expand ; + Env.scrape_alias := scrape_alias_lazy +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let find_type_of_module ~strengthen ~aliasable env path = if strengthen then @@ -548,14 +556,7 @@ and nondep_sig_item env va ids = function 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_modtype(id, nondep_modtype_decl env ids d, vis) | 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) -> diff --git a/src/ocaml/typing/out_type.ml b/src/ocaml/typing/out_type.ml new file mode 100644 index 000000000..fe68b8a66 --- /dev/null +++ b/src/ocaml/typing/out_type.ml @@ -0,0 +1,2880 @@ +(**************************************************************************) +(* *) +(* 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 +open Mode + +module String = Misc.Stdlib.String +module Int = Misc.Stdlib.Int +module Sig_component_kind = Shape.Sig_component_kind +module Style = Misc.Style + +(* Note [When to print jkind annotations] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Jkind annotations are only occasionally necessary to write + (compilation can often infer jkinds), so when should we print + them? This Note addresses all the cases. + + Case (C1). The jkind on a type declaration, like + [type 'a t : <> = ...]. + + We print the jkind when it cannot be inferred from the rest of what is + printed. Specifically, we print the user-written jkind in any of these + cases: + + (C1.1) The type declaration is abstract, has no manifest (i.e., + it's written without any [=]-signs), and the annotation is not equivalent to value. + + In this case, there is no way to know the jkind without the annotation. + + (C1.2) The type has unsafe mode crossings. In this case, the jkind is overridden by the + user rather than being inferred from the definition. + + Case (C2). The jkind on a type parameter to a type, like + [type ('a : <>) t = ...]. + + This jkind is printed if both of the following are true: + + (C2.1) The jkind is something other than the default [value]. + (* CR layouts reisenberg: update when the default changes *) + + (C2.2) The variable has no constraints on it. (If there is a constraint, + the constraint determines the jkind, so printing the jkind is + redundant.) + + We *could*, in theory, print this only when it cannot be inferred. + But this amounts to repeating inference. The heuristic also runs into + trouble when considering the possibility of a recursive type. So, in + order to keep the pretty-printer simple, we just always print the + (non-default) annotation. + + Another design possibility is to pass in verbosity level as some kind + of flag. + + Case (C3). The jkind on a universal type variable, like + [val f : ('a : <>). 'a -> 'a]. + + We should print this jkind annotation whenever it is neither the + default [value] nor an unfilled sort variable. (But see (X1) below.) + (* CR layouts reisenberg: update when the default changes *) + This is a challenge, though, because the type in a [val] does not + explicitly quantify its free variables. So we must collect the free + variables, look to see whether any have interesting jkinds, and + print the whole set of variables if any of them do. This is all + implemented in [extract_qtvs], used also in a number of other places + we do quantification (e.g. gadt-syntax constructors). + + Exception (X1). When we are still in the process of inferring a type, + there may be an unfilled sort variable. Here is an example: + + {[ + module M : sig + val f : int -> bool -> char + end = struct + let f true _ = () + end + ]} + + The problem is that [f]'s first parameter is conflicted between being + [int] and [bool]. But the second parameter in the [struct] will have + type ['a : <>]. We generally do not want to print this, + however, and so we don't -- except when [-verbose-types] is set. + + We imagine that merlin, when run verbosely, will set [-verbose-types]. + This will allow an informative type to be printed for e.g. [let f x = x], + which can work with any sort. +*) + +(* Print a long identifier *) + +module Fmt = Format_doc +open Format_doc + +(* Print an identifier avoiding name collisions *) + +module Out_name = struct + let create x = { printed_name = x } + let print x = x.printed_name + let set out_name x = out_name.printed_name <- x +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 + +let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n + + type namespace = Sig_component_kind.t = + | Value + | Type + | Constructor + | Label + | Unboxed_label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + | Jkind + + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value | Constructor | Label -> 5 + | Unboxed_label -> 6 + | Jkind -> 7 + (* we do not handle those component *) + + let size = 1 + id Jkind + + + 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_lazy + | Some Module_type -> to_lookup Env.find_modtype_by_name_lazy + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | Some Jkind -> to_lookup Env.find_jkind_by_name + | None + | Some(Value|Extension_constructor|Constructor|Label|Unboxed_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_lazy path).md_loc + | Some Module_type -> + (in_printing_env @@ Env.find_modtype_lazy 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 Jkind -> (in_printing_env @@ Env.find_jkind path).jkind_loc + | Some (Extension_constructor|Value|Constructor|Label|Unboxed_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 collect_explanation namespace n id = + let name = human_unique n id in + let root_name = Ident.name id in + if not (M.mem name !explanations) then + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = { kind = namespace; location; name; root_name } in + explanations := M.add name explanation !explanations + + let pp_explanation ppf r= + Fmt.fprintf ppf "@[%a:@,Definition of %s %a@]" + (Location.Doc.loc ~capitalize_first:true) 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 + +(** Name mapping *) +type mapping = + | Need_unique_name of int Ident.Map.t + (** The same name has already been attributed to multiple types. + The [map] argument contains the specific binding time attributed to each + types. + *) + | Uniquely_associated_to of Ident.t * out_name + (** For now, the name [Ident.name id] has been attributed to [id], + [out_name] is used to expand this name if a conflict arises + at a later point + *) + | Associated_to_pervasives of out_name + (** [Associated_to_pervasives out_name] is used when the item + [Stdlib.$name] has been associated to the name [$name]. + Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *) + +let hid_start = 0 + +let add_hid_id id map = + let new_id = 1 + Ident.Map.fold (fun _ -> Int.max) map hid_start in + new_id, Ident.Map.add id new_id map + +let find_hid id map = + try Ident.Map.find id map, map with + Not_found -> add_hid_id id map + +let pervasives name = "Stdlib." ^ name + +let map = Array.make Namespace.size M.empty +let get namespace = map.(Namespace.id namespace) +let set namespace x = map.(Namespace.id namespace) <- x + +(* Names used in recursive definitions are not considered when determining + if a name is already attributed in the current environment. + This is a complementary version of hidden_rec_items used by short-path. *) +let protected = ref S.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 = S.add (Ident.name id.ident) m in + protect_refs [ R(protected, List.fold_left update !protected ids)] f + +let pervasives_name namespace name = + match namespace, !enabled with + | None, _ | _, true -> Out_name.create name + | Some namespace, false -> + match M.find name (get namespace) with + | Associated_to_pervasives r -> r + | Need_unique_name _ -> Out_name.create (pervasives name) + | Uniquely_associated_to (id',r) -> + let hid, map = add_hid_id id' Ident.Map.empty in + Out_name.set r (human_unique hid id'); + Ident_conflicts.collect_explanation namespace hid id'; + set namespace @@ M.add name (Need_unique_name map) (get namespace); + Out_name.create (pervasives name) + | exception Not_found -> + let r = Out_name.create name in + set namespace @@ M.add name (Associated_to_pervasives r) (get namespace); + r + +(** Lookup for preexisting named item within the current {!printing_env} *) +let env_ident namespace name = + if S.mem name !protected then None else + match Namespace.lookup namespace name with + | Pident id -> Some id + | _ -> None + | exception Not_found -> None + +(** Associate a name to the identifier [id] within [namespace] *) +let ident_name_simple 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 = Ident.name id in + match M.find name (get namespace) with + | Uniquely_associated_to (id',r) when Ident.same id id' -> + r + | Need_unique_name map -> + let hid, m = find_hid id map in + Ident_conflicts.collect_explanation namespace hid id; + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | Uniquely_associated_to (id',r) -> + let hid', m = find_hid id' Ident.Map.empty in + let hid, m = find_hid id m in + Out_name.set r (human_unique hid' id'); + List.iter (fun (id,hid) -> Ident_conflicts.collect_explanation namespace hid id) + [id, hid; id', hid' ]; + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | Associated_to_pervasives r -> + Out_name.set r ("Stdlib." ^ Out_name.print r); + let hid, m = find_hid id Ident.Map.empty in + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | exception Not_found -> + let r = Out_name.create name in + set namespace + @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace); + r + +(** Same as {!ident_name_simple} but lookup to existing named identifiers + in the current {!printing_env} *) +let ident_name namespace id = + begin match env_ident namespace (Ident.name id) with + | Some id' -> ignore (ident_name_simple namespace id') + | None -> () + end; + ident_name_simple namespace id + +let reset () = + Array.iteri ( fun i _ -> map.(i) <- M.empty ) map + +let with_ctx f = + let old = Array.copy map in + try_finally f + ~always:(fun () -> Array.blit old 0 map 0 (Array.length map)) + +end +let ident_name = Ident_names.ident_name +let reset_naming_context = Ident_names.reset + +(* let ident ppf id = pp_print_string ppf + * (Out_name.print (Ident_names.ident_name_simple None id)) *) + +(* let namespaced_ident namespace id = + * Out_name.print (Ident_names.ident_name (Some namespace) id) *) + +let instance_name global = + (* Construct the stopgap syntax and then shove it in a string with the + attribute after it. *) + (* CR lmaurer: This is hacky and it loses the state of the [out_name]s that + comprise the [out_ident]. Should presumably have a new constructor for + [out_ident] instead? *) + let rec string_of_global global = + (* We can avoid calling [ident_name_simple] here because instance names are + always global (which is bad - but the syntax is currently bad anyway) *) + let ({ head; args } : Global_module.Name.t) = global in + String.concat "" (head :: List.map string_of_arg args) + and string_of_arg arg = + let ({ param; value } : Global_module.Name.argument) = arg in + Printf.sprintf "(%s)(%s)" + (Global_module.Parameter_name.to_string param) (string_of_global value) + in + let printed_name = + string_of_global global ^ " [@jane.non_erasable.instances]" + in + { printed_name } + + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_pervasive = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match in_printing_env (Env.find_type_by_name (Lident 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 + +let expand_longident_head name = + match find_double_underscore name with + | None -> None + | Some i -> + Some + (Ldot + (Location.mknoloc (Lident (String.sub name 0 i)), + (Location.mknoloc (Unit_info.modulize + (String.sub name (i + 2) (String.length name - i - 2)))))) + +(* 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_impl env p = + match p with + | Pdot (p, s) -> + Pdot (rewrite_double_underscore_paths_impl env p, s) + | Papply (a, b) -> + Papply (rewrite_double_underscore_paths_impl env a, + rewrite_double_underscore_paths_impl env b) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths_impl env p, extra) + | Pident id -> + let name = Ident.name id in + match expand_longident_head name with + | None -> p + | Some better_lid -> + match Env.find_module_by_name_lazy 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_impl env p + +let rec rewrite_double_underscore_longidents env (l : Longident.t) = + match l with + | Ldot (l, s) -> + Ldot (Location.map (rewrite_double_underscore_longidents env) l, s) + | Lapply (a, b) -> + Lapply + ( Location.map (rewrite_double_underscore_longidents env) a, + Location.map (rewrite_double_underscore_longidents env) b ) + | Lident name -> + begin + match find_double_underscore name with + | None -> l + | Some i -> + let l' = + Ldot + ( Location.mknoloc (Lident (String.sub name 0 i)), + Location.mknoloc + (Unit_info.modulize + (String.sub name (i + 2) + (String.length name - i - 2))) ) + in + begin + match + (Env.find_module_by_name_lazy l env, + Env.find_module_by_name_lazy l' env) + with + | exception Not_found -> l + | (p, _), (p', _) -> + if module_path_is_an_alias_of env p' ~alias_of:p then l' + else l + end + end + +let rec tree_of_path namespace = function + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_pervasive path -> + Oide_ident (Ident_names.pervasives_name namespace s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + Oide_apply (tree_of_path (Some Module) p1, tree_of_path (Some Module) p2) + | 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 + | Punboxed_ty -> + Oide_hash (tree_of_path namespace p) + end + +let tree_of_path namespace = function + | Pident id when Ident.is_instance id -> + (* Only when the instance name is the entire path (which is the only place + a human could write it) is it worth printing the human-writable stopgap + syntax for instance names *) + Oide_ident (instance_name (Ident.to_global_exn id)) + | p -> tree_of_path namespace p + +let tree_of_path namespace p = + tree_of_path 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 + +(* In the [Paths] constructor, more preferred paths are stored later in the + list. *) + +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 Compilation_unit.Name.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 same_printing_env env = + let used_pers = Env.used_persistent () in + Env.same_types !printing_old env + && Compilation_unit.Name.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 -> + (* Jane Street: Often the best choice for printing [p1] is + [p1] itself. And often [p1] is a path whose "penalty" + would be reduced if the double-underscore rewrite + applied. + *) + let rewritten_p1 = rewrite_double_underscore_paths env p1 in + printing_map := Path.Map.add p1 (ref (Paths [ p; rewritten_p1 ])) !printing_map) + env in + printing_cont := [cont]; + end + +(* CR-soon zqian: Currently we immediately backtrack each mutation, which might +cause incoherent types/modes in a single printing. Instead, we should move +backtrack logic into [wrap_printing_env], which is called for each "printing +request". Unfortunately, that seems to interfere with type naming context. The +later is cleaned up in Ocaml 5.3, so we should retry once we merge 5.3. *) +let wrap_mutation f = + let snap = Btype.snapshot () in + try_finally f ~always:(fun () -> Btype.backtrack snap) + +let wrap_printing_env ~reset_names env f = + let old_env = !printing_env in + set_printing_env env; + if reset_names then reset_naming_context (); + try_finally f ~always:(fun () -> set_printing_env old_env) + +let wrap_printing_env ~error env f = + if error then Env.without_cmis (wrap_printing_env ~reset_names:true env) f + else wrap_printing_env ~reset_names:true env f + +and wrap_printing_env_unguarded env f = + wrap_printing_env ~reset_names:false 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 (Location.mknoloc (lid_of_path p1), Location.mknoloc s) + | Path.Papply (p1, p2) -> + Longident.Lapply + (Location.mknoloc (lid_of_path p1), Location.mknoloc (lid_of_path p2)) + | Path.Pextra_ty (p, Pext_ty) -> lid_of_path p + | Path.Pextra_ty (p, Punboxed_ty) -> + match p with + | Pident id -> Longident.Lident (Ident.name id ^ "#") + | Pdot (p, s) -> + Longident.Ldot (Location.mknoloc (lid_of_path p), + Location.mknoloc(s ^ "#")) + | Papply _ | Pextra_ty _ -> assert false + +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 -> Longident.same (lid_of_path p) id) rem && + Path.same p (fst (Env.find_type_by_name id env)) + +let penalty_size = 20 + +let name_penalty s = + if s <> "" && s.[0] = '_' then + penalty_size + else + match find_double_underscore s with + | None -> 2 + | Some _ -> penalty_size + +let ambiguity_penalty path env = + if is_unambiguous path env then 0 else penalty_size + +let path_size path env = + let rec size = function + Pident id -> + name_penalty (Ident.name id), -Ident.scope id + | Pdot (p, id) | Pextra_ty (p, Pcstr_ty id) -> + let (l, b) = size p in (name_penalty id + l, b) + | Papply (p1, p2) -> + let (l, b) = size p1 in + (l + fst (size p2), b) + | Pextra_ty (p, Pext_ty) -> + size p + | Pextra_ty (p, Punboxed_ty) -> + let (l, b) = size p in (1 + l, b) + in + let l, s = size path in + l + ambiguity_penalty path env, s + +let rec get_best_path r env = + 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 env >= path_size p' env -> () + | _ -> r := Best p) + (List.rev l); + get_best_path r env + +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 () = + try + get_best_path (Path.Map.find p' !printing_map) !printing_env + with Not_found -> rewrite_double_underscore_paths !printing_env p' + in + while !printing_cont <> [] && + fst (path_size (get_path ()) !printing_env) > !printing_depth + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth; + done; + let p'' = get_path () in + (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) + (p'', s) + +(* 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 { name = Some name } | Tunivar { name = 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 { name = Some name } | Tunivar { name = 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 _ | Trepr _ -> 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 + +(* Whether to expand [eval] in types for reductions before printing. + Disabled when printing errors, as they usually contain an expansion trace. *) +let print_reduced_evals = ref true + +let out_jkind_of_const_jkind env jkind = + Ojkind_const (Jkind.Const.to_out_jkind_const env jkind) + +(* CR layouts v2.8: This is just like [Jkind.format], and likely needs to + be overhauled with [with]-types. Internal ticket 5096. *) +let rec out_jkind_of_desc env (desc : 'd Jkind.Desc.t) = + match desc.base with + | Layout (Sort (Var n, sa)) -> + Ojkind_var ("'_representable_layout_" ^ + Int.to_string (Jkind.Sort.Var.get_print_number n), + Jkind.Scannable_axes.to_string_list sa) + (* Analyze a product before calling [get_const]: the machinery in + [Jkind.Const.to_out_jkind_const] works better for atomic layouts, not + products. *) + | Layout (Product lays) -> + Ojkind_product + (List.map + (fun layout -> + out_jkind_of_desc env { desc with base = Layout layout }) + lays) + | _ -> match Jkind.Desc.get_const desc with + | Some c -> out_jkind_of_const_jkind env c + | None -> assert false (* handled above *) + +(* returns None for [value], according to (C2.1) from + Note [When to print jkind annotations] *) +(* CR layouts v2.8: This should use the annotation in the jkind, if there + is one. But first that annotation needs to be in Typedtree, not in + Parsetree. Internal ticket 4435. *) +let out_jkind_option_of_jkind ~ignore_null env jkind = + let desc = Jkind.get jkind in + let elide = + Jkind.is_value_for_printing ~ignore_null env jkind (* C2.1 *) + || (match desc.base with + | Layout (Sort (Var _, _)) -> not !Clflags.verbose_types (* X1 *) + | _ -> false) + in + if elide then None else Some (out_jkind_of_desc env desc) + +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 outcome_label : Types.arg_label -> Outcometree.arg_label = function + | Nolabel -> Nolabel + | Labelled l -> Labelled l + | Optional l -> Optional l + | Position l -> Position l + +(** Un-interpret modalities back to outcome tree. Takes the mutability and + attributes on the field and removes mutable-implied modalities + accordingly. *) +let tree_of_modalities mut t = + t + |> Typemode.least_modalities ~include_implied:false ~mut + |> Typemode.sort_dedup_modalities + |> List.map (fun (Atom (ax, m) : Modality.atom) -> + Fmt.asprintf "%a" (Modality.Per_axis.print ax) m) + +let tree_of_modes (modes : Mode.Alloc.Const.t) = + (* Step 1: Compute the modes to print *) + let diff = + + (* [forkable] has implied defaults depending on [areality]: *) + let forkable = + match modes.areality, modes.forkable with + | Local, Unforkable | Global, Forkable -> None + | _, _ -> Some modes.forkable + in + + (* [yielding] has implied defaults depending on [areality]: *) + let yielding = + match modes.areality, modes.yielding with + | Local, Yielding | Global, Unyielding -> None + | _, _ -> Some modes.yielding + in + + (* [contention] has implied defaults based on [visibility]: *) + let contention = + match modes.visibility, modes.contention with + | Immutable, Contended + | Read, Shared + | Write, Corrupted + | Read_write, Uncontended -> None + | _, _ -> Some modes.contention + in + + (* [portability] has implied defaults based on [statefulness]: *) + let portability = + match modes.statefulness, modes.portability with + | Stateless, Portable + | Reading, Shareable + | Writing, Corruptible + | Stateful, Nonportable -> None + | _, _ -> Some modes.portability + in + + let diff = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy in + { diff with forkable; yielding; contention; portability } + in + (* Step 2: Print the modes *) + let print_to_string_opt print a = Option.map (Fmt.asprintf "%a" print) a in + let modes = + [ print_to_string_opt Mode.Locality.Const.print diff.areality + ; print_to_string_opt Mode.Uniqueness.Const.print diff.uniqueness + ; print_to_string_opt Mode.Linearity.Const.print diff.linearity + ; print_to_string_opt Mode.Portability.Const.print diff.portability + ; print_to_string_opt Mode.Contention.Const.print diff.contention + ; print_to_string_opt Mode.Forkable.Const.print diff.forkable + ; print_to_string_opt Mode.Yielding.Const.print diff.yielding + ; print_to_string_opt Mode.Statefulness.Const.print diff.statefulness + ; print_to_string_opt Mode.Visibility.Const.print diff.visibility ] + in + List.filter_map (fun x -> x) modes + +(** The modal context on a type when printing it. This is to reproduce the mode + currying logic in [typetexp.ml], so that parsing and printing roundtrip. *) +type modal = + | Arrow_return of + { acc : Mode.Alloc.Const.t; + mode : Mode.Alloc.lr; } + (** This is the RHS (say [r]) of an arrow type, where [mode] is the real + mode of [r]. and: + - If [r] is also an arrow type, then [acc] is how users would interpret + [r]'s mode, if [r] doesn't have any parens aound it. + - If [r] is not an arrow type, in which case [acc] is meaningless. + + The callee is responsible for printing the type with the modes, with parens + if needed. + + Note that if [r] is an aliased type (e.g., [(int -> 'r) as 'r]), it will be + treated as NOT an arrow type, to align with the currying logic in + [typetexp.ml]. + + If [r] is [Tpoly (Tarrow_, [])], it will be treated as NOT an arrow type. + This gives tedious (but still correct) printing. *) + + | Other of Mode.Alloc.Const.t + (** In other cases, the caller has already printed the modes (as the + constructor argument) on the type. *) + +type typobject_repr = { fields : (string * type_expr) list; open_row : bool } + +type typvariant_repr = { + fields : (string * bool * type_expr list) list; + name : (Path.t * type_expr list) option; + closed : bool; + present : (string * row_field) list; + all_present : bool; + tags : string list option +} + +let rec tree_of_modal_typexp mode modal ty = + let not_arrow tree = + match modal with + | Arrow_return {mode; _} -> + let mode = Alloc.zap_to_legacy mode in + Otyp_ret (Orm_any (tree_of_modes mode), tree) + | Other _ -> tree + in + let ty = + Ctype.reduce_head ~expand_eval:!print_reduced_evals !printing_env ty + in + 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 + not_arrow (Otyp_var (non_gen, name)) else + + let pr_typ alloc_mode = + 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, marg, mret), ty1, ty2, _) -> + let lab = + if !print_labels || is_omittable l then outcome_label l + else Nolabel + in + (* [marg] will contain undetermined axes. It would be imprecise if we + don't print anything for those axes, since user would interpret that + as legacy. The best we can do is to zap to legacy and if they do land + at legacy, we will be able to omit printing them. *) + let arg_mode = Alloc.zap_to_legacy marg in + let t1 = + if is_optional l then + match + get_desc (Ctype.expand_head !printing_env (tpoly_get_mono ty1)) + with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode arg_mode ty + | _ -> Otyp_stuff "" + else + tree_of_typexp mode arg_mode ty1 + in + let acc_mode = curry_mode alloc_mode arg_mode in + let modal = Arrow_return {acc = acc_mode; mode = mret} in + let t2 = tree_of_modal_typexp mode modal ty2 in + Otyp_arrow (lab, tree_of_modes arg_mode, t1, t2) + | Ttuple labeled_tyl -> + Otyp_tuple (tree_of_labeled_typlist mode labeled_tyl) + | Tunboxed_tuple labeled_tyl -> + Otyp_unboxed_tuple (tree_of_labeled_typlist mode labeled_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 Alloc.Const.legacy (List.hd tyl') + else begin + Internal_names.add p'; + Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') + end + | Tvariant row -> + let { fields; name; closed; present; all_present; tags } = + tree_of_typvariant_repr row + in + begin match name with + | Some(p, tyl) when nameable_row row -> + let (p', s) = best_type_path p in + let id = tree_of_path (Some Type) 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 + (fun (l, c, tyl) -> (l, c, tree_of_typlist mode tyl)) fields + in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tquote ty -> + wrap_printing_env_unguarded + (Env.enter_quotation !printing_env) + (fun () -> Otyp_quote (tree_of_typexp mode alloc_mode ty)) + | Tsplice ty -> + wrap_printing_env_unguarded + (Env.enter_splice ~loc:Location.none !printing_env) + (fun () -> Otyp_splice (tree_of_typexp mode alloc_mode ty)) + | Tquote_eval ty -> + let ty = newgenty (Tquote ty) in + let p', s = best_type_path Predef.path_eval in + let tyl = apply_subst s [ty] in + Internal_names.add p'; + let tyl = + wrap_printing_env_unguarded + (Env.enter_quotation !printing_env) + (fun () -> tree_of_typlist mode tyl) + in + Otyp_constr (tree_of_path (Some Type) p', tyl) + | 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, []) | Trepr (ty, []) -> + tree_of_typexp mode alloc_mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + 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 = tree_of_qtvs tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode alloc_mode ty) in + (* Forget names when we leave scope *) + Variable_names.remove_names tyl; + Aliases.delayed := old_delayed; tr + | Trepr (ty, sort_vars) -> + (* Trepr wraps a Tpoly that contains the type variables + corresponding to the sort variables. Extract them and print. *) + (match get_desc ty with + | Tpoly (inner_ty, (_ :: _ as tyl)) -> + (* Check that the sort_vars match the jkinds of tyl *) + let sorts_match = + match + List.for_all2 + (fun sort_var ty -> + match get_desc ty with + | Tunivar { jkind } -> + (match Jkind.get_layout !printing_env jkind with + | Some layout -> + (match Jkind.Layout.Const.get_sort layout with + | Some (Jkind.Sort.Const.Univar uv) -> + uv == sort_var + | _ -> false) + | None -> false) + | _ -> false) + sort_vars tyl + with + | result -> result + | exception Invalid_argument _ -> false + in + if sorts_match then begin + let tyl = List.map Transient_expr.repr tyl in + let old_delayed = !Aliases.delayed in + List.iter Aliases.add_delayed tyl; + let sort_names = tree_of_qsvs tyl in + let tr = + Otyp_repr (sort_names, tree_of_typexp mode alloc_mode inner_ty) + in + Variable_names.remove_names tyl; + Aliases.delayed := old_delayed; + tr + end else + (* Mismatch: print Trepr and Tpoly separately *) + tree_of_typexp mode alloc_mode ty + | _ -> + (* No type variables, just print the body *) + tree_of_typexp mode alloc_mode ty) + | Tunivar _ -> + Otyp_var (false, Variable_names.(name_of_type new_name) tty) + | Tpackage pack -> + let pack = tree_of_package mode pack in + Otyp_module pack + | Tof_kind jkind -> + Otyp_of_kind (out_jkind_of_desc !printing_env (Jkind.get jkind)) + 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 + let tree = + Otyp_alias {non_gen; aliased = pr_typ Mode.Alloc.Const.legacy; alias } + in + not_arrow tree end + else + match modal with + | Arrow_return {acc; mode} -> + let rm, alloc_mode = tree_of_ret_typ_mutating acc mode ty in + let ty = pr_typ alloc_mode in + Otyp_ret (rm, ty) + | Other m -> pr_typ m + +and tree_of_typexp mode alloc_mode ty = + tree_of_modal_typexp mode (Other alloc_mode) ty + +(* qtvs = quantified type variables *) +(* this silently drops any arguments that are not generic Tvar or Tunivar *) +and tree_of_qtvs qtvs = + let tree_of_qtv v : (string * out_jkind option) option = + (* CR layouts: We ignore nullability here to avoid needlessly printing + ['a : value_or_null] when it's not relevant (most cases). + Unfortunately, this makes error messages really confusing, because + we don't consider jkind annotations. *) + let tree jkind = + Some (Variable_names.name_of_type Variable_names.new_name v, + out_jkind_option_of_jkind ~ignore_null:true !printing_env jkind) + in + match v.desc with + | Tvar { jkind } when v.level = generic_level -> tree jkind + | Tunivar { jkind } -> tree jkind + | _ -> None + in + List.filter_map tree_of_qtv qtvs + +(* qsvs = quantified sort variables (for Trepr) *) +(* Extract names from type variables corresponding to sort variables *) +and tree_of_qsvs qtvs = + List.filter_map + (fun v -> + match v.desc with + | Tvar _ when v.level = generic_level -> + Some (Variable_names.name_of_type Variable_names.new_name v) + | Tunivar _ -> Some (Variable_names.name_of_type Variable_names.new_name v) + | _ -> None) + qtvs + +and tree_of_row_field (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tyl) + else (l, false, tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typvariant_repr 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 + let fields = List.map tree_of_row_field fields in + let tags = + if all_present then None else Some (List.map fst present) in + { fields; name; closed; present; all_present; tags } + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode Alloc.Const.legacy) tyl + +and tree_of_labeled_typlist mode tyl = + List.map (fun (label, ty) -> label, tree_of_typexp mode Alloc.Const.legacy ty) tyl + +and tree_of_typ_gf {ca_type=ty; ca_modalities=gf; _} = + (tree_of_typexp Type Alloc.Const.legacy ty, + tree_of_modalities Immutable gf) + +(** NB: This function might mutate states; the caller is responsible for + reverting them. *) +and tree_of_ret_typ_mutating acc_mode m ty= + match get_desc ty with + | Tarrow _ -> begin + (* We first try to equate [m] with the [acc_mode]; if that succeeds, we + can omit parens and modes. *) + match Alloc.equate (Alloc.of_const acc_mode) m with + | Ok () -> + (Orm_no_parens, acc_mode) + | Error _ -> + (* In this branch we need to print parens. [m] might have undetermined + axes and we adopt a similar logic to the [marg] above. *) + let m = Alloc.zap_to_legacy m in + (Orm_parens (tree_of_modes m), m) + end + | _ -> + let m = Alloc.zap_to_legacy m in + (Orm_any (tree_of_modes m), m) + +and tree_of_typobject_repr 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 + let fields, open_row = tree_of_typfields rest sorted_fields in + { fields; open_row } + +and tree_of_typobject mode fi nm = + match nm with + | None -> + let { fields; open_row } = tree_of_typobject_repr fi in + let fields = + List.map + (fun (s, t) -> (s, tree_of_typexp mode Alloc.Const.legacy t)) + fields + 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_path (Some Type) p', args) + | _ -> fatal_error "Out_type.tree_of_typobject" + +and tree_of_typfields rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | field :: l -> + let (fields, rest) = tree_of_typfields rest l in + (field :: fields, rest) + +and tree_of_package mode {pack_path; pack_cstrs} = + { opack_path = tree_of_path (Some Module_type) pack_path; + opack_cstrs = + List.map + (fun (li, ty) -> + (String.concat "." li, tree_of_typexp mode Alloc.Const.legacy ty)) + pack_cstrs } + +let tree_of_typexp mode ty = + (* [tree_of_typexp] mutates state, which we need to backtrack. *) + wrap_mutation (fun () -> tree_of_typexp mode Alloc.Const.legacy ty) + +let tree_of_typexp mode ty = + (* CR metaprogramming jbachurski: Remove this [Env.enter_future] hack once + errors track their stage, as we should usually print at stage 0. + See ticket 6726. *) + if Ctype.contains_toplevel_splice (Env.stage !printing_env :> int) ty + then + wrap_printing_env_unguarded + (Env.enter_future !printing_env) + (fun () -> tree_of_typexp mode ty) + else + tree_of_typexp mode ty + +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 + +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 [None, 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 args = + List.iter prepare_type (tys_of_constr_args args) + +(* returns an empty list if no variables in the list have a jkind annotation *) +let zap_qtvs_if_boring qtvs = + if List.exists (fun (_v, l) -> Option.is_some l) qtvs + then qtvs + else [] + +(* get the free variables with their jkinds; do this *after* converting the + type itself, so that the type names are available. + This implements Case (C3) from Note [When to print jkind annotations]. *) +let extract_qtvs tyl = + let fvs = Ctype.free_non_row_variables_of_list tyl in + (* The [Ctype.free*variables] family of functions returns the free + variables in reverse order they were encountered in the list of types. + *) + let fvs = List.rev fvs in + let tfvs = List.map Transient_expr.repr fvs in + let vars_jkinds = tree_of_qtvs tfvs in + zap_qtvs_if_boring vars_jkinds + +let param_jkind ty = + match get_desc ty with + | Tvar { jkind; _ } | Tunivar { jkind; _ } -> + out_jkind_option_of_jkind ~ignore_null:false !printing_env jkind + | _ -> None (* this is (C2.2) from Note [When to print jkind annotations] *) + +let tree_of_label l = + let mut = + match l.ld_mutable with + | Mutable { mode; atomic } -> + let atomic = + match atomic with + | Atomic -> Atomic + | Nonatomic -> Nonatomic + in + let mut = + let open Value.Comonadic in + match equate mode legacy with + | Ok () -> Om_mutable (None, atomic) + | Error _ -> Om_mutable (Some "", atomic) + in + mut + | Immutable -> Om_immutable + in + let ld_modalities = tree_of_modalities l.ld_mutable l.ld_modalities in + { + olab_name = Ident.name l.ld_id; + olab_mut = mut; + olab_type = tree_of_typexp Type l.ld_type; + olab_modalities = ld_modalities; + } + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> List.map tree_of_typ_gf l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l), [] ] + +let extension_constructor_args_and_ret_type_subtree args ret_type = + match ret_type with + | None -> (tree_of_constructor_arguments args, None) + | Some res -> + let out_ret = tree_of_typexp Type res in + let out_args = tree_of_constructor_arguments args in + let qtvs = extract_qtvs (res :: tys_of_constr_args args) in + (out_args, Some (qtvs, out_ret)) + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let args, ret = + extension_constructor_args_and_ret_type_subtree cd.cd_args cd.cd_res + 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 -> + match get_desc ty with + | Tvar { name = Some "_"; jkind } + when List.exists (eq_type ty) vars -> + set_type_desc ty (Tvar {name = None; jkind}) + | _ -> ()) + 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,_umc) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep,_umc) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_record_unboxed_product(l, _rep,_umc) -> + 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 ot_jkind = + function + | Otyp_var (ot_non_gen, ot_name) -> + {ot_non_gen; ot_name; ot_variance; ot_jkind} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} + 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_record_unboxed_product _ -> + decl.type_private = Private + | Type_variant (tll, _rep,_umc) -> + 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 !Clflags.print_variance || abstr || not is_var then + let inj = + !Clflags.print_variance && Variance.mem Inj v || + 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 + (match co, cn with + | false, false -> Bivariant + | true, false -> Covariant + | false, true -> Contravariant + | true, true -> NoVariance), + (if inj then Injective else NoInjectivity) + else (NoVariance, NoInjectivity)) + decl.type_params decl.type_variance + in + let mk_param ty variance = + let jkind = param_jkind ty in + type_param variance jkind (tree_of_typexp Type ty) + in + (Ident.name id, + List.map2 mk_param 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, or_null_attribute, unsafe_mode_crossing = + match decl.type_kind with + | Type_abstract _ -> + begin match ty_manifest with + | None -> (Otyp_abstract, Public, false, None, false) + | Some ty -> + tree_of_typexp Type ty, decl.type_private, false, None, false + end + | Type_variant (cstrs, rep, umc) -> + let unboxed = + match rep with + | Variant_unboxed -> true + | Variant_boxed _ | Variant_extensible | Variant_with_null -> false + in + let or_null_attribute = + if Builtin_attributes.has_or_null decl.type_attributes then + Some "or_null" + else if Builtin_attributes.has_or_null_reexport decl.type_attributes + then Some "or_null_reexport" + else None + in + tree_of_manifest (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), + decl.type_private, + unboxed, + or_null_attribute, + (Option.is_some umc) + | Type_record(lbls, rep, umc) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private, + (match rep with Record_unboxed -> true | _ -> false), + None, + (Option.is_some umc) + | Type_record_unboxed_product(lbls, Record_unboxed_product, umc) -> + tree_of_manifest + (Otyp_record_unboxed_product (List.map tree_of_label lbls)), + decl.type_private, + false, + None, + (Option.is_some umc) + | Type_open -> + tree_of_manifest Otyp_open, + decl.type_private, + false, + None, + false + in + (* The algorithm for setting [lay] here is described as Case (C1) in + Note [When to print jkind annotations] *) + let is_value = + Jkind.is_value_for_printing ~ignore_null:false !printing_env decl.type_jkind + in + let otype_jkind = + match ty, is_value, unsafe_mode_crossing with + | (Otyp_abstract, false, _) | (_, _, true) -> + (* The two cases of (C1) from the Note correspond to Otyp_abstract. + Anything but the default must be user-written, so we print the + user-written annotation. *) + (* unsafe_mode_crossing corresponds to C1.2 *) + Some (out_jkind_of_desc !printing_env (Jkind.get decl.type_jkind)) + | _ -> None (* other cases have no jkind annotation *) + in + let otype_attributes = + if unsafe_mode_crossing + then [{ oattr_name = "unsafe_allow_any_mode_crossing" }] + else [] + in + { otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_jkind; + otype_unboxed = unboxed; + otype_or_null_attribute = or_null_attribute; + otype_cstrs = constraints; + otype_attributes } + +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 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 + wrap_mutation (fun () -> + let moda = + if Mode.Modality.is_undefined decl.val_modalities then + Mode.Modality.Const.id + else + Ctype.zap_modalities_to_floor_if_modes_enabled_at Alpha + decl.val_modalities + in + let qsvs, qtvs = + (* Important: process the fvs *after* the type; tree_of_type_scheme + resets the naming context. Both must be inside print_with_genvars + so that sort poly var names are registered when jkinds are printed. *) + Jkind_types.Sort.print_with_genvars (Lpoly.get_exn decl.val_lpoly) + (fun names -> names, extract_qtvs [decl.val_type]) + in + let apparent_arity = + let rec count n typ = + match get_desc typ with + | Tarrow (_,_,typ,_) -> count (n+1) typ + | _ -> n + in + count 0 decl.val_type + in + let attrs = + match Zero_alloc.get decl.val_zero_alloc with + | Default_zero_alloc | Ignore_assert_all -> [] + | Check { strict; opt; arity; custom_error_msg; loc = _; } -> + [{ oattr_name = + String.concat "" + ["zero_alloc"; + if strict then " strict" else ""; + if opt then " opt" else ""; + if arity = apparent_arity then "" else + Printf.sprintf " arity %d" arity; + match custom_error_msg with + | None -> "" + | Some msg -> Printf.sprintf " custom_error_message %S" msg + ] }] + | Assume { strict; never_returns_normally; arity; _ } -> + [{ oattr_name = + String.concat "" + ["zero_alloc assume"; + if strict then " strict" else ""; + if never_returns_normally then " never_returns_normally" else ""; + if arity = apparent_arity then "" else + Printf.sprintf " arity %d" arity; + ] + }] + in + let vd = + { oval_name = id; + oval_type = Otyp_newlayout(qsvs, Otyp_poly(qtvs, ty)); + oval_modalities = tree_of_modalities Immutable moda; + oval_prims = []; + oval_attributes = attrs + } + 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 + let tyl = List.map Transient_expr.repr tyl in + let qtvs = tree_of_qtvs tyl in + let qtvs = zap_qtvs_if_boring qtvs in + Variable_names.remove_names tyl; + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, Otyp_poly(qtvs, 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) + || deep_occur_list 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 = Asttypes.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_omittable l then outcome_label l + else Nolabel + in + let tr = + if is_optional l then + match get_desc (Ctype.expand_head !printing_env 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 + (* CR layouts: fix next line when adding support for jkind + annotations on class type parameters *) + let ot_jkind = param_jkind param in + match tree_of_typexp Type_scheme param with + Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance; ot_jkind} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} + +let class_variance = + let open Variance in let open Asttypes in + List.map (fun v -> + let inj = !Clflags.print_variance && Variance.mem Inj v in + (match mem May_pos v, mem May_neg v with + | false, false -> Bivariant + | true, false -> Covariant + | false, true -> Contravariant + | true, true -> NoVariance), + (if inj then Injective else 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) + +let tree_of_jkind_declaration id decl = + let ojkind = + { ojkind_name = Ident.name id + ; ojkind_jkind = + Option.map + (fun jkind -> + jkind |> Jkind.Desc.of_const |> out_jkind_of_desc !printing_env) + decl.jkind_manifest + } + in + Osig_jkind ojkind + +(* 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_jkind = Jkind.Builtin.any ~why:Dummy_jkind; + type_ikind = Types.ikinds_todo "print dummy"; + 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_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + type_unboxed_version = None; + } + +(** 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_jkind (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.is_global_or_predef 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 expand_module_type = + ref ((fun _env _mty -> assert false) : + Env.t -> module_type -> module_type) + +(** How to abbreviate signatures *) +module Abbrev = struct + (* The code is substantially simpler if [width] is mutable. Strictly speaking, [depth] + doesn't have to be mutable here but mixed mutability would be quite confusing. *) + type t = + { (* To what depth to unfold the module tree *) + mutable depth : int + (* How many signature items to print in total across all signatures *) + ; mutable width : int + } + + (** Standard abbreviation heuristic *) + let abbrev () = + { depth = 4 + ; width = 16 + } + + (** Don't print any signature items *) + let ellipsis () = + { depth = 0 + ; width = 0 + } + + (** Should we print anything in this signature *) + let exhausted = function + | Some {depth; width} -> depth <= 0 || width <= 0 + | None -> false + + (** Run [f] at one deeper unfolding level *) + let deeper t f = + match t with + | Some t -> + let saved = t.depth in + t.depth <- t.depth - 1; + let x = f () in + t.depth <- saved; + x + | None -> f () + + (** Reduce the remaining width by the number of items in [sg] and return the number of + items to print in [sg] and a flag that inidicates whether [sg] is being trimmed. *) + let items t sg = + match t with + | Some t -> + let n = List.length sg in + let k = min t.width n in + t.width <- t.width - n; + Some k, (k < n) + | None -> + None, false +end + +let rec tree_of_modtype ?abbrev = function + | Mty_ident p -> + Omty_ident (tree_of_path (Some Module_type) p) + | Mty_signature sg -> + Omty_signature (tree_of_signature ?abbrev sg) + | Mty_functor(param, ty_res, m_res) -> + wrap_mutation (fun () -> + let param, env = + tree_of_functor_parameter ?abbrev param + in + let res = wrap_env env (tree_of_modtype ?abbrev) ty_res in + let mres = m_res |> Mode.Alloc.zap_to_legacy |> tree_of_modes in + Omty_functor (param, res, mres)) + | Mty_alias p -> + Omty_alias (tree_of_path (Some Module) p) + | Mty_strengthen _ as mty -> + begin match !expand_module_type !printing_env mty with + | Mty_strengthen (mty,p,a) -> + let unaliasable = + not (Aliasability.is_aliasable a) + && not (Env.is_functor_arg p !printing_env) + in + Omty_strengthen + (tree_of_modtype ?abbrev mty, tree_of_path (Some Module) p, unaliasable) + | mty -> tree_of_modtype ?abbrev mty + end + +and tree_of_functor_parameter ?abbrev = function + | Unit -> + None, fun k -> k + | Named (param, ty_arg, m_arg) -> + let name, env = + match param with + | None -> None, fun env -> env + | Some id -> + Some (Ident.name id), + fun k -> Env.add_module ~arg:true id Mp_present ty_arg k + in + let marg = m_arg |> Mode.Alloc.zap_to_legacy |> tree_of_modes in + Some (name, tree_of_modtype ?abbrev ty_arg, marg), env + +and tree_of_signature ?abbrev = function + | [] -> [] + | _ when Abbrev.exhausted abbrev -> [Osig_ellipsis] + | sg -> + Abbrev.deeper abbrev (fun () -> + wrap_env (fun env -> env)(fun sg -> + (* Only expand signatures to 'abbrev.depth' depth and print at most 'abbrev.width' + items overall. We just keep decreasing 'abbrev.width' during the traversal but + make sure that we expand the current signature up to 'abbrev.width' before + expanding it's components. Below, 'max_items' is the number of items we should + print in the current signature and 'abbrev.width' is then be the remaining + number of items. This is simpler to implement than proper breadth-first. *) + let max_items, trimmed = Abbrev.items abbrev sg in + let tree_groups = tree_of_signature_rec ?abbrev ?max_items !printing_env sg in + let items = List.concat_map (fun (_env,l) -> List.map snd l) tree_groups in + if trimmed then items @ [Osig_ellipsis] else items + ) sg + ) + +and tree_of_signature_rec ?abbrev ?max_items env' sg = + let structured = List.of_seq (Signature_group.seq sg) in + (* Don't descent into more than 'max_items' (if set) elements to save time. *) + let collect_trees_of_rec_group max_items group = + match max_items with + | Some n when n <= 0 -> (max_items, (!printing_env, [])) + | Some _ | None -> + let env = !printing_env in + let env', group_trees = + Ident_names.with_ctx + (fun () -> trees_of_recursive_sigitem_group ?abbrev env group) + in + set_printing_env env'; + let max_items, group_trees = match max_items with + | None -> None, group_trees + | Some n -> + let rec take n acc xs = + match n, xs with + | 0, _ | _, [] -> n, List.rev acc + | n, x :: xs -> take (n-1) (x :: acc) xs + in + let n, group_trees = take n [] group_trees in + Some n, group_trees + in + max_items, (env, group_trees) + in + set_printing_env env'; + snd (List.fold_left_map collect_trees_of_rec_group max_items structured) + +and trees_of_recursive_sigitem_group ?abbrev env + (syntactic_group: Signature_group.rec_group) = + let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem ?abbrev 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 ?abbrev = 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 abbrev = + if List.exists (function + | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true + | _ -> false) + md.md_attributes + then Some (Abbrev.ellipsis ()) + else abbrev + in + tree_of_module ?abbrev id md rs + | Sig_modtype(id, decl, _) -> + tree_of_modtype_declaration ?abbrev 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 + | Sig_jkind(id, decl, _) -> + tree_of_jkind_declaration id decl + +and tree_of_modtype_declaration ?abbrev id decl = + let mty = + match decl.mtd_type with + | None -> Omty_abstract + | Some mty -> tree_of_modtype ?abbrev mty + in + Osig_modtype (Ident.name id, mty) + +and tree_of_module ?abbrev id md rs = wrap_mutation (fun () -> + let moda = + if Mode.Modality.is_undefined md.md_modalities then + Mode.Modality.Const.id + else + Ctype.zap_modalities_to_floor_if_at_least Alpha md.md_modalities + in + Osig_module (Ident.name id, tree_of_modtype ?abbrev md.md_type, + tree_of_modalities Immutable moda, + 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' + ~var_jkinds mode Errortrace.{ty = t; expanded = t'} = + let tree_of_typexp' ty = + let out = tree_of_typexp mode ty in + if var_jkinds then + match get_desc ty with + | Tvar { jkind; _ } | Tunivar { jkind; _ } -> + let okind = out_jkind_of_desc !printing_env (Jkind.get jkind) in + Otyp_jkind_annot (out, okind) + | _ -> + out + else + out + in + Aliases.reset (); + Aliases.mark_loops t; + if same_path t t' + then begin Aliases.add_delayed (proxy t); Same (tree_of_typexp' 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 *) + print_reduced_evals := false; (* preserve unreduced eval in types *) + let first = tree_of_typexp' t in + print_reduced_evals := true; + let second = tree_of_typexp' t' in + if first = second then Same first + else Diff(first,second) + end + +let trees_of_type_expansion = + trees_of_type_expansion' ~var_jkinds:false + +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) + (Jkind.Builtin.value ~why:Row_variable)))) + | _ -> 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 abbreviate ~abbrev f = + f ?abbrev:(if abbrev then Some (Abbrev.abbrev ()) else None) + +(* let tree_of_path = tree_of_path None *) +let tree_of_module ident ?(ellipsis = false) = + tree_of_module ident ?abbrev:(if ellipsis then Some (Abbrev.ellipsis ()) else None) +let tree_of_signature sg = tree_of_signature sg +let tree_of_modtype ?(abbrev = false) ty = + abbreviate ~abbrev tree_of_modtype ty +let namespaced_tree_of_path n = tree_of_path (Some n) +let tree_of_path p = tree_of_path None p +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_modtype_declaration ?(abbrev = false) id md = + abbreviate ~abbrev tree_of_modtype_declaration id md + +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 () = + try + get_best_path (Path.Map.find p' !printing_map) !printing_env + with Not_found -> rewrite_double_underscore_paths !printing_env p' + in + while !printing_cont <> [] && + fst (path_size (get_path ()) !printing_env) > !printing_depth + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth; + done; + let p'' = get_path () in + (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) + (p'', s) + +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_path p'' diff --git a/src/ocaml/typing/out_type.mli b/src/ocaml/typing/out_type.mli new file mode 100644 index 000000000..1c9a2a70d --- /dev/null +++ b/src/ocaml/typing/out_type.mli @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* 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: 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 tree_of_type_scheme: type_expr -> out_type + +val tree_of_modalities: + Types.mutability -> Mode.Modality.Const.t -> Outcometree.out_mode list + + +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 trees_of_type_expansion': + var_jkinds:bool -> 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 * out_modality list) 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 * out_modality list) list * (out_vars_jkinds * out_type) option +val add_extension_constructor_to_preparation : + extension_constructor -> unit +val prepared_extension_constructor: + Ident.t -> extension_constructor printer + + +val rewrite_double_underscore_longidents: Env.t -> Longident.t -> Longident.t + +(** {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: + ?abbrev:bool -> 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 + +val tree_of_jkind_declaration: + Ident.t -> jkind_declaration -> out_sig_item + +(** {1 Module types }*) + +val tree_of_module: + Ident.t -> ?ellipsis:bool -> module_declaration -> rec_status -> + out_sig_item +val tree_of_modtype: ?abbrev:bool -> 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 + +val expand_module_type: (Env.t -> module_type -> module_type) ref +(* Forward declaration to be filled in Mtype. We want to be able to print types + in Mtype for debugging purposes and hence don't want to depend on Mtype + here. *) + +(** {1 For [Translquote] *) +type typobject_repr = { fields : (string * type_expr) list; open_row : bool } +type typvariant_repr = { + fields : (string * bool * type_expr list) list; + name : (Path.t * type_expr list) option; + closed : bool; + present : (string * row_field) list; + all_present : bool; + tags : string list option +} +val tree_of_typobject_repr : type_expr -> typobject_repr +val tree_of_typvariant_repr : row_desc -> typvariant_repr + +(** {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 + + val reset: unit -> unit +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/predef.mli b/src/ocaml/typing/predef.mli index f61f57bc4..920d90f04 100644 --- a/src/ocaml/typing/predef.mli +++ b/src/ocaml/typing/predef.mli @@ -17,8 +17,76 @@ open Types +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 val ident_bytes: Ident.t +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +======= +type abstract_type_constr = [ + | `Int + | `Char + | `String + | `Bytes + | `Float + | `Continuation + | `Array + | `Nativeint + | `Int32 + | `Int64 + | `Lazy_t + | `Extension_constructor + | `Floatarray + | `Iarray + | `Atomic_loc + | `Lexing_position + | `Code + | `Float32 + | `Int8 + | `Int16 +] +type abstract_non_value_type_constr = [ + | `Idx_imm + | `Idx_mut + | `Int8x16 + | `Int16x8 + | `Int32x4 + | `Int64x2 + | `Float16x8 + | `Float32x4 + | `Float64x2 + | `Int8x32 + | `Int16x16 + | `Int32x8 + | `Int64x4 + | `Float16x16 + | `Float32x8 + | `Float64x4 + | `Int8x64 + | `Int16x32 + | `Int32x16 + | `Int64x8 + | `Float16x32 + | `Float32x16 + | `Float64x8 +] +type data_type_constr = [ + | `Bool + | `Unit + | `Exn + | `Eff + | `List + | `Option + | `Or_null +] +type type_constr = [ + | abstract_type_constr + | abstract_non_value_type_constr + | data_type_constr +] + +val find_type_constr : Path.t -> type_constr option + +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 val type_int: type_expr val type_char: type_expr val type_string: type_expr @@ -28,6 +96,8 @@ val type_float32: 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_iarray: type_expr -> type_expr val type_list: type_expr -> type_expr @@ -112,6 +182,7 @@ val path_float32: 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_iarray: Path.t val path_list: Path.t @@ -124,6 +195,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_lexing_position: Path.t val path_code: Path.t val path_eval: Path.t diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index 0cee3b8c3..1db7cf978 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -2,14 +2,3907 @@ (* *) (* 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. *) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +(* *) +(**************************************************************************) + +(* Printing functions *) + +open Misc +open Ctype +open Longident +open Path +open Asttypes +open Types +open Mode +open Btype +open Outcometree + +module String = Misc.Stdlib.String +module Int = Misc.Stdlib.Int +module Sig_component_kind = Shape.Sig_component_kind +module Style = Misc.Style + +(* Note [When to print jkind annotations] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Jkind annotations are only occasionally necessary to write + (compilation can often infer jkinds), so when should we print + them? This Note addresses all the cases. + + Case (C1). The jkind on a type declaration, like + [type 'a t : <> = ...]. + + We print the jkind when it cannot be inferred from the rest of what is + printed. Specifically, we print the user-written jkind in any of these + cases: + + (C1.1) The type declaration is abstract, has no manifest (i.e., + it's written without any [=]-signs), and the annotation is not equivalent to value. + + In this case, there is no way to know the jkind without the annotation. + + (C1.2) The type has unsafe mode crossings. In this case, the jkind is overridden by the + user rather than being inferred from the definition. + + Case (C2). The jkind on a type parameter to a type, like + [type ('a : <>) t = ...]. + + This jkind is printed if both of the following are true: + + (C2.1) The jkind is something other than the default [value]. + (* CR layouts reisenberg: update when the default changes *) + + (C2.2) The variable has no constraints on it. (If there is a constraint, + the constraint determines the jkind, so printing the jkind is + redundant.) + + We *could*, in theory, print this only when it cannot be inferred. + But this amounts to repeating inference. The heuristic also runs into + trouble when considering the possibility of a recursive type. So, in + order to keep the pretty-printer simple, we just always print the + (non-default) annotation. + + Another design possibility is to pass in verbosity level as some kind + of flag. + + Case (C3). The jkind on a universal type variable, like + [val f : ('a : <>). 'a -> 'a]. + + We should print this jkind annotation whenever it is neither the + default [value] nor an unfilled sort variable. (But see (X1) below.) + (* CR layouts reisenberg: update when the default changes *) + This is a challenge, though, because the type in a [val] does not + explicitly quantify its free variables. So we must collect the free + variables, look to see whether any have interesting jkinds, and + print the whole set of variables if any of them do. This is all + implemented in [extract_qtvs], used also in a number of other places + we do quantification (e.g. gadt-syntax constructors). + + Exception (X1). When we are still in the process of inferring a type, + there may be an unfilled sort variable. Here is an example: + + {[ + module M : sig + val f : int -> bool -> char + end = struct + let f true _ = () + end + ]} + + The problem is that [f]'s first parameter is conflicted between being + [int] and [bool]. But the second parameter in the [struct] will have + type ['a : <>]. We generally do not want to print this, + however, and so we don't -- except when [-verbose-types] is set. + + We imagine that merlin, when run verbosely, will set [-verbose-types]. + This will allow an informative type to be printed for e.g. [let f x = x], + which can work with any sort. +*) + +(* Print a long identifier *) + +module Fmt = Format_doc +open Format_doc + +let longident = Pprintast.Doc.longident + +let () = Env.print_longident := longident; Mode.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 + let set out_name x = out_name.printed_name <- x +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 + +let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n + + type namespace = Sig_component_kind.t = + | Value + | Type + | Constructor + | Label + | Unboxed_label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + | Jkind + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value | Constructor | Label -> 5 + | Unboxed_label -> 6 + | Jkind -> 7 + (* we do not handle those component *) + + let size = 1 + id Jkind + + + 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_lazy + | Some Module_type -> to_lookup Env.find_modtype_by_name_lazy + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | Some Jkind -> to_lookup Env.find_jkind_by_name + | None + | Some(Value|Extension_constructor|Constructor|Label|Unboxed_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_lazy path).md_loc + | Some Module_type -> + (in_printing_env @@ Env.find_modtype_lazy 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 Jkind -> (in_printing_env @@ Env.find_jkind path).jkind_loc + | Some (Extension_constructor|Value|Constructor|Label|Unboxed_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 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 collect_explanation namespace n id = + let name = human_unique n id in + let root_name = Ident.name id in + if not (M.mem name !explanations) then + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = { kind = namespace; location; name; root_name } in + explanations := M.add name explanation !explanations + + let pp_explanation ppf r= + Fmt.fprintf ppf "@[%a:@,Definition of %s %a@]" + (Location.Doc.loc ~capitalize_first:true) 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 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 -> Fmt.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 exists () = M.cardinal !explanations >0 +end + +module Naming_context = struct + +module M = String.Map +module S = String.Set + +let enabled = ref true +let enable b = enabled := b + +(** Name mapping *) +type mapping = + | Need_unique_name of int Ident.Map.t + (** The same name has already been attributed to multiple types. + The [map] argument contains the specific binding time attributed to each + types. + *) + | Uniquely_associated_to of Ident.t * out_name + (** For now, the name [Ident.name id] has been attributed to [id], + [out_name] is used to expand this name if a conflict arises + at a later point + *) + | Associated_to_pervasives of out_name + (** [Associated_to_pervasives out_name] is used when the item + [Stdlib.$name] has been associated to the name [$name]. + Upon a conflict, this name will be expanded to ["Stdlib." ^ name ] *) + +let hid_start = 0 + +let add_hid_id id map = + let new_id = 1 + Ident.Map.fold (fun _ -> Int.max) map hid_start in + new_id, Ident.Map.add id new_id map + +let find_hid id map = + try Ident.Map.find id map, map with + Not_found -> add_hid_id id map + +let pervasives name = "Stdlib." ^ name + +let map = Array.make Namespace.size M.empty +let get namespace = map.(Namespace.id namespace) +let set namespace x = map.(Namespace.id namespace) <- x + +(* Names used in recursive definitions are not considered when determining + if a name is already attributed in the current environment. + This is a complementary version of hidden_rec_items used by short-path. *) +let protected = ref S.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 = S.add (Ident.name id.ident) m in + protect_refs [ R(protected, List.fold_left update !protected ids)] f + +let pervasives_name namespace name = + match namespace, !enabled with + | None, _ | _, true -> Out_name.create name + | Some namespace, false -> + match M.find name (get namespace) with + | Associated_to_pervasives r -> r + | Need_unique_name _ -> Out_name.create (pervasives name) + | Uniquely_associated_to (id',r) -> + let hid, map = add_hid_id id' Ident.Map.empty in + Out_name.set r (human_unique hid id'); + Conflicts.collect_explanation namespace hid id'; + set namespace @@ M.add name (Need_unique_name map) (get namespace); + Out_name.create (pervasives name) + | exception Not_found -> + let r = Out_name.create name in + set namespace @@ M.add name (Associated_to_pervasives r) (get namespace); + r + +(** Lookup for preexisting named item within the current {!printing_env} *) +let env_ident namespace name = + if S.mem name !protected then None else + match Namespace.lookup namespace name with + | Pident id -> Some id + | _ -> None + | exception Not_found -> None + +(** Associate a name to the identifier [id] within [namespace] *) +let ident_name_simple 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 = Ident.name id in + match M.find name (get namespace) with + | Uniquely_associated_to (id',r) when Ident.same id id' -> + r + | Need_unique_name map -> + let hid, m = find_hid id map in + Conflicts.collect_explanation namespace hid id; + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | Uniquely_associated_to (id',r) -> + let hid', m = find_hid id' Ident.Map.empty in + let hid, m = find_hid id m in + Out_name.set r (human_unique hid' id'); + List.iter (fun (id,hid) -> Conflicts.collect_explanation namespace hid id) + [id, hid; id', hid' ]; + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | Associated_to_pervasives r -> + Out_name.set r ("Stdlib." ^ Out_name.print r); + let hid, m = find_hid id Ident.Map.empty in + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | exception Not_found -> + let r = Out_name.create name in + set namespace + @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace); + r + +(** Same as {!ident_name_simple} but lookup to existing named identifiers + in the current {!printing_env} *) +let ident_name namespace id = + begin match env_ident namespace (Ident.name id) with + | Some id' -> ignore (ident_name_simple namespace id') + | None -> () + end; + ident_name_simple namespace id + +let reset () = + Array.iteri ( fun i _ -> map.(i) <- M.empty ) map + +let with_ctx f = + let old = Array.copy map in + try_finally f + ~always:(fun () -> Array.blit old 0 map 0 (Array.length map)) + +end +let ident_name = Naming_context.ident_name +let reset_naming_context = Naming_context.reset + +let ident ppf id = pp_print_string ppf + (Out_name.print (Naming_context.ident_name_simple None id)) + +let namespaced_ident namespace id = + Out_name.print (Naming_context.ident_name (Some namespace) id) + +let instance_name global = + (* Construct the stopgap syntax and then shove it in a string with the + attribute after it. *) + (* CR lmaurer: This is hacky and it loses the state of the [out_name]s that + comprise the [out_ident]. Should presumably have a new constructor for + [out_ident] instead? *) + let rec string_of_global global = + (* We can avoid calling [ident_name_simple] here because instance names are + always global (which is bad - but the syntax is currently bad anyway) *) + let ({ head; args } : Global_module.Name.t) = global in + String.concat "" (head :: List.map string_of_arg args) + and string_of_arg arg = + let ({ param; value } : Global_module.Name.argument) = arg in + Printf.sprintf "(%s)(%s)" + (Global_module.Parameter_name.to_string param) (string_of_global value) + in + let printed_name = + string_of_global global ^ " [@jane.non_erasable.instances]" + in + { printed_name } + + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_pervasive = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match in_printing_env (Env.find_type_by_name (Lident 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 + +let expand_longident_head name = + match find_double_underscore name with + | None -> None + | Some i -> + Some + (Ldot + (Lident (String.sub name 0 i), + Unit_info.modulize + (String.sub name (i + 2) (String.length name - i - 2)))) + +(* 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 expand_longident_head name with + | None -> p + | Some better_lid -> + match Env.find_module_by_name_lazy 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 rewrite_double_underscore_longidents env (l : Longident.t) = + match l with + | Ldot (l, s) -> + Ldot (rewrite_double_underscore_longidents env l, s) + | Lapply (a, b) -> + Lapply (rewrite_double_underscore_longidents env a, + rewrite_double_underscore_longidents env b) + | Lident name -> + match expand_longident_head name with + | None -> l + | Some l' -> + match + (Env.find_module_by_name_lazy l env, + Env.find_module_by_name_lazy l' env) + with + | exception Not_found -> l + | (p, _), (p', _) -> + if module_path_is_an_alias_of env p' ~alias_of:p then + l' + else + l + +let rec tree_of_path namespace = function + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_pervasive path -> + Oide_ident (Naming_context.pervasives_name namespace s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + Oide_apply (tree_of_path (Some Module) p1, tree_of_path (Some Module) p2) + | 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 + | Punboxed_ty -> + Oide_hash (tree_of_path namespace p) + end + +let tree_of_path namespace = function + | Pident id when Ident.is_instance id -> + (* Only when the instance name is the entire path (which is the only place + a human could write it) is it worth printing the human-writable stopgap + syntax for instance names *) + Oide_ident (instance_name (Ident.to_global_exn id)) + | p -> tree_of_path namespace p + +let tree_of_path namespace p = + tree_of_path 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" (Fmt.compat path) p + +let strings_of_paths namespace p = + reset_naming_context (); + let trees = List.map (tree_of_path namespace) p in + List.map (Fmt.asprintf "%a" !Oprint.out_ident) trees + +let () = Env.print_path := path +let () = Jkind.set_printtyp_path path + +(* Print a recursive annotation *) + +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 : Types.arg_label -> string = function + Nolabel -> "" + | Labelled s | Position 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;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 labeled_type ppf (label, ty) = + begin match label with + | Some s -> fprintf ppf "label=\"%s\" " s + | None -> () + end; + raw_type ppf ty + +and raw_type_list tl = raw_list raw_type tl +and labeled_type_list tl = raw_list labeled_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_row_desc ppf 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) +and raw_type_desc ppf = function + Tvar { name; jkind } -> + fprintf ppf "Tvar (@,%a,@,%a)" + print_name name (Jkind.format !printing_env) jkind + | Tarrow((l,arg,ret),t1,t2,c) -> + fprintf ppf "@[Tarrow((\"%s\",%a,%a),@,%a,@,%a,@,%s)@]" + (string_of_label l) + (Alloc.print ~verbose:true ()) arg + (Alloc.print ~verbose:true ()) ret + raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" labeled_type_list tl + | Tunboxed_tuple tl -> + fprintf ppf "@[<1>Tunboxed_tuple@,%a@]" labeled_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) + | Tquote t -> + fprintf ppf "@[Tquote@ %a@]" raw_type t + | Tsplice t -> + fprintf ppf "@[Tsplice@ %a@]" raw_type t + | Tquote_eval t -> + fprintf ppf "@[Tquote_eval@ %a@]" raw_type t + | 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; jkind } -> + fprintf ppf "Tunivar (@,%a,@,%a)" + print_name name (Jkind.format !printing_env) jkind + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Trepr (t, sort_vars) -> + let print_sort_univar ppf uv = + fprintf ppf "%s" (Option.value uv.Jkind_types.Sort.name ~default:"_") + in + fprintf ppf "@[Trepr(@,%a,@,[@[%a@]])@]" + raw_type t + (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@ ") + print_sort_univar) sort_vars + | Tvariant row -> + raw_row_desc ppf row + | Tpackage (p, fl) -> + fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p + raw_lid_type_list fl + | Tof_kind jkind -> + fprintf ppf "Tof_kind@ %a" (Jkind.format !printing_env) jkind +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 +| Some Types.Fixed_existential -> fprintf ppf "Some Fixed_existential" + +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 := compat 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 + +(* In the [Paths] constructor, more preferred paths are stored later in the + list. *) + +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 Compilation_unit.Name.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 same_printing_env env = + let used_pers = Env.used_persistent () in + Env.same_types !printing_old env + && Compilation_unit.Name.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 -> + (* Jane Street: Often the best choice for printing [p1] is + [p1] itself. And often [p1] is a path whose "penalty" + would be reduced if the double-underscore rewrite + applied. + *) + let rewritten_p1 = rewrite_double_underscore_paths env p1 in + printing_map := Path.Map.add p1 (ref (Paths [ p; rewritten_p1 ])) !printing_map) + env in + printing_cont := [cont]; + end + +(* CR-soon zqian: Currently we immediately backtrack each mutation, which might +cause incoherent types/modes in a single printing. Instead, we should move +backtrack logic into [wrap_printing_env], which is called for each "printing +request". Unfortunately, that seems to interfere with type naming context. The +later is cleaned up in Ocaml 5.3, so we should retry once we merge 5.3. *) +let wrap_mutation f = + let snap = Btype.snapshot () in + try_finally f ~always:(fun () -> Btype.backtrack snap) + +let wrap_printing_env ~reset_names env f = + let old_env = !printing_env in + set_printing_env env; + if reset_names then reset_naming_context (); + try_finally f ~always:(fun () -> set_printing_env old_env) + +let wrap_printing_env ~error env f = + if error then Env.without_cmis (wrap_printing_env ~reset_names:true env) f + else wrap_printing_env ~reset_names:true env f +and wrap_printing_env_unguarded env f = + wrap_printing_env ~reset_names:false 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 + | Path.Pextra_ty (p, Punboxed_ty) -> + match p with + | Pident id -> Longident.Lident (Ident.name id ^ "#") + | Pdot (p, s) -> Longident.Ldot (lid_of_path p, s ^ "#") + | Papply _ | Pextra_ty _ -> assert false + +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 penalty_size = 20 + +let name_penalty s = + if s <> "" && s.[0] = '_' then + penalty_size + else + match find_double_underscore s with + | None -> 2 + | Some _ -> penalty_size + +let ambiguity_penalty path env = + if is_unambiguous path env then 0 else penalty_size + +let path_size path env = + let rec size = function + Pident id -> + name_penalty (Ident.name id), -Ident.scope id + | Pdot (p, id) | Pextra_ty (p, Pcstr_ty id) -> + let (l, b) = size p in (name_penalty id + l, b) + | Papply (p1, p2) -> + let (l, b) = size p1 in + (l + fst (size p2), b) + | Pextra_ty (p, Pext_ty) -> + size p + | Pextra_ty (p, Punboxed_ty) -> + let (l, b) = size p in (1 + l, b) + in + let l, s = size path in + l + ambiguity_penalty path env, s + +let rec get_best_path r env = + 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 env >= path_size p' env -> () + | _ -> r := Best p) + (List.rev l); + get_best_path r env + +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 () = + try + get_best_path (Path.Map.find p' !printing_map) !printing_env + with Not_found -> rewrite_double_underscore_paths !printing_env p' + in + while !printing_cont <> [] && + fst (path_size (get_path ()) !printing_env) > !printing_depth + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth; + done; + let p'' = get_path () in + (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) + (p'', s) + +(* 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 Names : sig + val reset_names : unit -> unit + + val add_named_vars : type_expr -> 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 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 { name = Some name } | Tunivar { name = 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 { name = Some name } | Tunivar { name = 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 _ | Trepr _ -> 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 () = + reset_naming_context (); 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 + +(* Whether to expand [eval] in types for reductions before printing. + Disabled when printing errors, as they usually contain an expansion trace. *) +let print_reduced_evals = ref true + +let out_jkind_of_const_jkind env jkind = + Ojkind_const (Jkind.Const.to_out_jkind_const env jkind) + +(* CR layouts v2.8: This is just like [Jkind.format], and likely needs to + be overhauled with [with]-types. Internal ticket 5096. *) +let rec out_jkind_of_desc env (desc : 'd Jkind.Desc.t) = + match desc.base with + | Layout (Sort (Var n, sa)) -> + Ojkind_var ("'_representable_layout_" ^ + Int.to_string (Jkind.Sort.Var.get_print_number n), + Jkind.Scannable_axes.to_string_list sa) + (* Analyze a product before calling [get_const]: the machinery in + [Jkind.Const.to_out_jkind_const] works better for atomic layouts, not + products. *) + | Layout (Product lays) -> + Ojkind_product + (List.map + (fun layout -> + out_jkind_of_desc env { desc with base = Layout layout }) + lays) + | _ -> match Jkind.Desc.get_const desc with + | Some c -> out_jkind_of_const_jkind env c + | None -> assert false (* handled above *) + +(* returns None for [value], according to (C2.1) from + Note [When to print jkind annotations] *) +(* CR layouts v2.8: This should use the annotation in the jkind, if there + is one. But first that annotation needs to be in Typedtree, not in + Parsetree. Internal ticket 4435. *) +let out_jkind_option_of_jkind ~ignore_null env jkind = + let desc = Jkind.get jkind in + let elide = + Jkind.is_value_for_printing ~ignore_null env jkind (* C2.1 *) + || (match desc.base with + | Layout (Sort (Var _, _)) -> not !Clflags.verbose_types (* X1 *) + | _ -> false) + in + if elide then None else Some (out_jkind_of_desc env desc) + +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 outcome_label : Types.arg_label -> Outcometree.arg_label = function + | Nolabel -> Nolabel + | Labelled l -> Labelled l + | Optional l -> Optional l + | Position l -> Position l + +(** Un-interpret modalities back to outcome tree. Takes the mutability and + attributes on the field and removes mutable-implied modalities + accordingly. *) +let tree_of_modalities mut t = + t + |> Typemode.least_modalities ~include_implied:false ~mut + |> Typemode.sort_dedup_modalities + |> List.map (fun (Atom (ax, m) : Modality.atom) -> + Fmt.asprintf "%a" (Modality.Per_axis.print ax) m) + +let tree_of_modes (modes : Mode.Alloc.Const.t) = + (* Step 1: Compute the modes to print *) + let diff = + + (* [forkable] has implied defaults depending on [areality]: *) + let forkable = + match modes.areality, modes.forkable with + | Local, Unforkable | Global, Forkable -> None + | _, _ -> Some modes.forkable + in + + (* [yielding] has implied defaults depending on [areality]: *) + let yielding = + match modes.areality, modes.yielding with + | Local, Yielding | Global, Unyielding -> None + | _, _ -> Some modes.yielding + in + + (* [contention] has implied defaults based on [visibility]: *) + let contention = + match modes.visibility, modes.contention with + | Immutable, Contended + | Read, Shared + | Write, Corrupted + | Read_write, Uncontended -> None + | _, _ -> Some modes.contention + in + + (* [portability] has implied defaults based on [statefulness]: *) + let portability = + match modes.statefulness, modes.portability with + | Stateless, Portable + | Reading, Shareable + | Writing, Corruptible + | Stateful, Nonportable -> None + | _, _ -> Some modes.portability + in + + let diff = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy in + { diff with forkable; yielding; contention; portability } + in + (* Step 2: Print the modes *) + let print_to_string_opt print a = Option.map (Fmt.asprintf "%a" print) a in + let modes = + [ print_to_string_opt Mode.Locality.Const.print diff.areality + ; print_to_string_opt Mode.Uniqueness.Const.print diff.uniqueness + ; print_to_string_opt Mode.Linearity.Const.print diff.linearity + ; print_to_string_opt Mode.Portability.Const.print diff.portability + ; print_to_string_opt Mode.Contention.Const.print diff.contention + ; print_to_string_opt Mode.Forkable.Const.print diff.forkable + ; print_to_string_opt Mode.Yielding.Const.print diff.yielding + ; print_to_string_opt Mode.Statefulness.Const.print diff.statefulness + ; print_to_string_opt Mode.Visibility.Const.print diff.visibility ] + in + List.filter_map (fun x -> x) modes + +(** The modal context on a type when printing it. This is to reproduce the mode + currying logic in [typetexp.ml], so that parsing and printing roundtrip. *) +type modal = + | Arrow_return of + { acc : Mode.Alloc.Const.t; + mode : Mode.Alloc.lr; } + (** This is the RHS (say [r]) of an arrow type, where [mode] is the real + mode of [r]. and: + - If [r] is also an arrow type, then [acc] is how users would interpret + [r]'s mode, if [r] doesn't have any parens aound it. + - If [r] is not an arrow type, in which case [acc] is meaningless. + + The callee is responsible for printing the type with the modes, with parens + if needed. + + Note that if [r] is an aliased type (e.g., [(int -> 'r) as 'r]), it will be + treated as NOT an arrow type, to align with the currying logic in + [typetexp.ml]. + + If [r] is [Tpoly (Tarrow_, [])], it will be treated as NOT an arrow type. + This gives tedious (but still correct) printing. *) + + | Other of Mode.Alloc.Const.t + (** In other cases, the caller has already printed the modes (as the + constructor argument) on the type. *) + +type typobject_repr = { fields : (string * type_expr) list; open_row : bool } + +type typvariant_repr = { + fields : (string * bool * type_expr list) list; + name : (Path.t * type_expr list) option; + closed : bool; + present : (string * row_field) list; + all_present : bool; + tags : string list option +} + +let rec tree_of_modal_typexp mode modal ty = + let not_arrow tree = + match modal with + | Arrow_return {mode; _} -> + let mode = Alloc.zap_to_legacy mode in + Otyp_ret (Orm_any (tree_of_modes mode), tree) + | Other _ -> tree + in + let ty = + Ctype.reduce_head ~expand_eval:!print_reduced_evals !printing_env ty + in + 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 + not_arrow (Otyp_var (non_gen, name)) else + + let pr_typ alloc_mode = + 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, marg, mret), ty1, ty2, _) -> + let lab = + if !print_labels || is_omittable l then outcome_label l + else Nolabel + in + (* [marg] will contain undetermined axes. It would be imprecise if we + don't print anything for those axes, since user would interpret that + as legacy. The best we can do is to zap to legacy and if they do land + at legacy, we will be able to omit printing them. *) + let arg_mode = Alloc.zap_to_legacy marg in + let t1 = + if is_optional l then + match + get_desc (Ctype.expand_head !printing_env (tpoly_get_mono ty1)) + with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode arg_mode ty + | _ -> Otyp_stuff "" + else + tree_of_typexp mode arg_mode ty1 + in + let acc_mode = curry_mode alloc_mode arg_mode in + let modal = Arrow_return {acc = acc_mode; mode = mret} in + let t2 = tree_of_modal_typexp mode modal ty2 in + Otyp_arrow (lab, tree_of_modes arg_mode, t1, t2) + | Ttuple labeled_tyl -> + Otyp_tuple (tree_of_labeled_typlist mode labeled_tyl) + | Tunboxed_tuple labeled_tyl -> + Otyp_unboxed_tuple (tree_of_labeled_typlist mode labeled_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 Alloc.Const.legacy (List.hd tyl') + else begin + Internal_names.add p'; + Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') + end + | Tvariant row -> + let { fields; name; closed; present; all_present; tags } = + tree_of_typvariant_repr row + in + begin match name with + | Some(p, tyl) when nameable_row row -> + let (p', s) = best_type_path p in + let id = tree_of_path (Some Type) 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 + (fun (l, c, tyl) -> (l, c, tree_of_typlist mode tyl)) fields + in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tquote ty -> + wrap_printing_env_unguarded + (Env.enter_quotation !printing_env) + (fun () -> Otyp_quote (tree_of_typexp mode alloc_mode ty)) + | Tsplice ty -> + wrap_printing_env_unguarded + (Env.enter_splice ~loc:Location.none !printing_env) + (fun () -> Otyp_splice (tree_of_typexp mode alloc_mode ty)) + | Tquote_eval ty -> + (* We use [Predef]'s [eval] as the syntax, so we need to quote [ty]. *) + let ty = newgenty (Tquote ty) in + let p', s = best_type_path Predef.path_eval in + let tyl = apply_subst s [ty] in + Internal_names.add p'; + let tyl = + wrap_printing_env_unguarded + (Env.enter_quotation !printing_env) + (fun () -> tree_of_typlist mode tyl) + in + Otyp_constr (tree_of_path (Some Type) p', tyl) + | 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, []) | Trepr (ty, []) -> + tree_of_typexp mode alloc_mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + 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 = tree_of_qtvs tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode alloc_mode ty) in + (* Forget names when we leave scope *) + Names.remove_names tyl; + delayed := old_delayed; tr + | Trepr (ty, sort_vars) -> + (* Trepr wraps a Tpoly that contains the type variables + corresponding to the sort variables. Extract them and print. *) + (match get_desc ty with + | Tpoly (inner_ty, (_ :: _ as tyl)) -> + (* Check that the sort_vars match the jkinds of tyl *) + let sorts_match = + match + List.for_all2 + (fun sort_var ty -> + match get_desc ty with + | Tunivar { jkind } -> + (match Jkind.get_layout !printing_env jkind with + | Some layout -> + (match Jkind.Layout.Const.get_sort layout with + | Some (Jkind.Sort.Const.Univar uv) -> + uv == sort_var + | _ -> false) + | None -> false) + | _ -> false) + sort_vars tyl + with + | result -> result + | exception Invalid_argument _ -> false + in + if sorts_match then begin + let tyl = List.map Transient_expr.repr tyl in + let old_delayed = !delayed in + List.iter add_delayed tyl; + let sort_names = tree_of_qsvs tyl in + let tr = + Otyp_repr (sort_names, tree_of_typexp mode alloc_mode inner_ty) + in + Names.remove_names tyl; + delayed := old_delayed; + tr + end else + (* Mismatch: print Trepr and Tpoly separately *) + tree_of_typexp mode alloc_mode ty + | _ -> + (* No type variables, just print the body *) + tree_of_typexp mode alloc_mode ty) + | 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 Alloc.Const.legacy ty + )) fl in + Otyp_module (tree_of_path (Some Module_type) p, fl) + | Tof_kind jkind -> + Otyp_of_kind (out_jkind_of_desc !printing_env (Jkind.get jkind)) + 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 + let tree = + Otyp_alias {non_gen; aliased = pr_typ Mode.Alloc.Const.legacy; alias } + in + not_arrow tree end + else + match modal with + | Arrow_return {acc; mode} -> + let rm, alloc_mode = tree_of_ret_typ_mutating acc mode ty in + let ty = pr_typ alloc_mode in + Otyp_ret (rm, ty) + | Other m -> pr_typ m + +and tree_of_typexp mode alloc_mode ty = + tree_of_modal_typexp mode (Other alloc_mode) ty + +(* qtvs = quantified type variables *) +(* this silently drops any arguments that are not generic Tvar or Tunivar *) +and tree_of_qtvs qtvs = + let tree_of_qtv v : (string * out_jkind option) option = + (* CR layouts: We ignore nullability here to avoid needlessly printing + ['a : value_or_null] when it's not relevant (most cases). + Unfortunately, this makes error messages really confusing, because + we don't consider jkind annotations. *) + let tree jkind = + Some (Names.name_of_type Names.new_name v, + out_jkind_option_of_jkind ~ignore_null:true !printing_env jkind) + in + match v.desc with + | Tvar { jkind } when v.level = generic_level -> tree jkind + | Tunivar { jkind } -> tree jkind + | _ -> None + in + List.filter_map tree_of_qtv qtvs + +(* qsvs = quantified sort variables (for Trepr) *) +(* Extract names from type variables corresponding to sort variables *) +and tree_of_qsvs qtvs = + List.filter_map + (fun v -> + match v.desc with + | Tvar _ when v.level = generic_level -> + Some (Names.name_of_type Names.new_name v) + | Tunivar _ -> Some (Names.name_of_type Names.new_name v) + | _ -> None) + qtvs + +and tree_of_row_field (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tyl) + else (l, false, tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typvariant_repr 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 + let fields = List.map tree_of_row_field fields in + let tags = + if all_present then None else Some (List.map fst present) in + { fields; name; closed; present; all_present; tags } + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode Alloc.Const.legacy) tyl + +and tree_of_labeled_typlist mode tyl = + List.map (fun (label, ty) -> label, tree_of_typexp mode Alloc.Const.legacy ty) tyl + +and tree_of_typ_gf {ca_type=ty; ca_modalities=gf; _} = + (tree_of_typexp Type Alloc.Const.legacy ty, + tree_of_modalities Immutable gf) + +(** NB: This function might mutate states; the caller is responsible for + reverting them. *) +and tree_of_ret_typ_mutating acc_mode m ty= + match get_desc ty with + | Tarrow _ -> begin + (* We first try to equate [m] with the [acc_mode]; if that succeeds, we + can omit parens and modes. *) + match Alloc.equate (Alloc.of_const acc_mode) m with + | Ok () -> + (Orm_no_parens, acc_mode) + | Error _ -> + (* In this branch we need to print parens. [m] might have undetermined + axes and we adopt a similar logic to the [marg] above. *) + let m = Alloc.zap_to_legacy m in + (Orm_parens (tree_of_modes m), m) + end + | _ -> + let m = Alloc.zap_to_legacy m in + (Orm_any (tree_of_modes m), m) + +and tree_of_typobject_repr 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 + let fields, open_row = tree_of_typfields rest sorted_fields in + { fields; open_row } + +and tree_of_typobject mode fi nm = + begin match nm with + | None -> + let { fields; open_row } = tree_of_typobject_repr fi in + let fields = + List.map + (fun (s, t) -> (s, tree_of_typexp mode Alloc.Const.legacy t)) + fields + 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_path (Some Type) p', args) + | _ -> + fatal_error "Printtyp.tree_of_typobject" + end + +and tree_of_typfields rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | field :: l -> + let (fields, rest) = tree_of_typfields rest l in + (field :: fields, rest) + +let tree_of_typexp mode ty = + (* [tree_of_typexp] mutates state, which we need to backtrack. *) + wrap_mutation (fun () -> tree_of_typexp mode Alloc.Const.legacy ty) + +let tree_of_typexp mode ty = + (* CR metaprogramming jbachurski: Remove this [Env.enter_future] hack once + errors track their stage, as we should usually print at stage 0. + See ticket 6726. *) + if Ctype.contains_toplevel_splice (Env.stage !printing_env :> int) ty + then + wrap_printing_env_unguarded + (Env.enter_future !printing_env) + (fun () -> tree_of_typexp mode ty) + else + tree_of_typexp mode ty + +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + +(* Only used for printing a single modality in error message *) +let modality ?(id = fun _ppf -> ()) ax ppf modality = + if Mode.Modality.Per_axis.is_id ax modality then id ppf + else + Fmt.asprintf "%a" (Mode.Modality.Per_axis.print ax) modality + |> !Oprint.out_modality ppf + +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_path (Some Type) p'' in + !Oprint.out_ident ppf t + +let tree_of_type_scheme ty = + prepare_for_printing [ty]; + tree_of_typexp Type_scheme ty + +let () = + Env.print_type_expr := type_expr; + Env.report_jkind_violation_with_offender := + Jkind.Violation.report_with_offender; + Jkind.set_outcometrees_of_types (fun tys -> + prepare_for_printing tys; + List.map (tree_of_typexp Type) tys); + Jkind.set_outcometree_of_modalities tree_of_modalities; + Jkind.set_print_type_expr type_expr; + Jkind.set_raw_type_expr (compat raw_type_expr) + +(* 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 [None, 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 args = + List.iter prepare_type (tys_of_constr_args args) + +(* returns an empty list if no variables in the list have a jkind annotation *) +let zap_qtvs_if_boring qtvs = + if List.exists (fun (_v, l) -> Option.is_some l) qtvs + then qtvs + else [] + +(* get the free variables with their jkinds; do this *after* converting the + type itself, so that the type names are available. + This implements Case (C3) from Note [When to print jkind annotations]. *) +let extract_qtvs tyl = + let fvs = Ctype.free_non_row_variables_of_list tyl in + (* The [Ctype.free*variables] family of functions returns the free + variables in reverse order they were encountered in the list of types. + *) + let fvs = List.rev fvs in + let tfvs = List.map Transient_expr.repr fvs in + let vars_jkinds = tree_of_qtvs tfvs in + zap_qtvs_if_boring vars_jkinds + +let param_jkind ty = + match get_desc ty with + | Tvar { jkind; _ } | Tunivar { jkind; _ } -> + out_jkind_option_of_jkind ~ignore_null:false !printing_env jkind + | _ -> None (* this is (C2.2) from Note [When to print jkind annotations] *) + +let tree_of_label l = + let mut = + match l.ld_mutable with + | Mutable { mode; atomic } -> + let atomic = + match atomic with + | Atomic -> Atomic + | Nonatomic -> Nonatomic + in + let mut = + let open Value.Comonadic in + match equate mode legacy with + | Ok () -> Om_mutable (None, atomic) + | Error _ -> Om_mutable (Some "", atomic) + in + mut + | Immutable -> Om_immutable + in + let ld_modalities = tree_of_modalities l.ld_mutable l.ld_modalities in + (Ident.name l.ld_id, mut, tree_of_typexp Type l.ld_type, ld_modalities) + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> List.map tree_of_typ_gf l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l), [] ] + +let tree_of_constructor_args_and_ret_type args ret_type = + match ret_type with + | None -> (tree_of_constructor_arguments args, None) + | Some res -> + let out_ret = tree_of_typexp Type res in + let out_args = tree_of_constructor_arguments args in + let qtvs = extract_qtvs (res :: tys_of_constr_args args) in + (out_args, Some (qtvs, out_ret)) + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let args, ret = tree_of_constructor_args_and_ret_type cd.cd_args cd.cd_res 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 -> + match get_desc ty with + | Tvar { name = Some "_"; jkind } + when List.exists (eq_type ty) vars -> + set_type_desc ty (Tvar {name = None; jkind}) + | _ -> ()) + 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,_umc) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep,_umc) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_record_unboxed_product(l, _rep,_umc) -> + 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 ot_jkind = + function + | Otyp_var (ot_non_gen, ot_name) -> + {ot_non_gen; ot_name; ot_variance; ot_jkind} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} + 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_record_unboxed_product _ -> + decl.type_private = Private + | Type_variant (tll, _rep,_umc) -> + 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 + let mk_param ty variance = + let jkind = param_jkind ty in + type_param variance jkind (tree_of_typexp Type ty) + in + (Ident.name id, + List.map2 mk_param 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, or_null_attribute, unsafe_mode_crossing = + match decl.type_kind with + | Type_abstract _ -> + begin match ty_manifest with + | None -> (Otyp_abstract, Public, false, None, false) + | Some ty -> + tree_of_typexp Type ty, decl.type_private, false, None, false + end + | Type_variant (cstrs, rep, umc) -> + let unboxed = + match rep with + | Variant_unboxed -> true + | Variant_boxed _ | Variant_extensible | Variant_with_null -> false + in + let or_null_attribute = + if Builtin_attributes.has_or_null decl.type_attributes then + Some "or_null" + else if Builtin_attributes.has_or_null_reexport decl.type_attributes + then Some "or_null_reexport" + else None + in + tree_of_manifest (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), + decl.type_private, + unboxed, + or_null_attribute, + (Option.is_some umc) + | Type_record(lbls, rep, umc) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private, + (match rep with Record_unboxed -> true | _ -> false), + None, + (Option.is_some umc) + | Type_record_unboxed_product(lbls, Record_unboxed_product, umc) -> + tree_of_manifest + (Otyp_record_unboxed_product (List.map tree_of_label lbls)), + decl.type_private, + false, + None, + (Option.is_some umc) + | Type_open -> + tree_of_manifest Otyp_open, + decl.type_private, + false, + None, + false + in + (* The algorithm for setting [lay] here is described as Case (C1) in + Note [When to print jkind annotations] *) + let is_value = + Jkind.is_value_for_printing ~ignore_null:false !printing_env decl.type_jkind + in + let otype_jkind = + match ty, is_value, unsafe_mode_crossing with + | (Otyp_abstract, false, _) | (_, _, true) -> + (* The two cases of (C1) from the Note correspond to Otyp_abstract. + Anything but the default must be user-written, so we print the + user-written annotation. *) + (* unsafe_mode_crossing corresponds to C1.2 *) + Some (out_jkind_of_desc !printing_env (Jkind.get decl.type_jkind)) + | _ -> None (* other cases have no jkind annotation *) + in + let attrs = + if unsafe_mode_crossing + then [{ oattr_name = "unsafe_allow_any_mode_crossing" }] + else [] + in + { otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_jkind; + otype_unboxed = unboxed; + otype_or_null_attribute = or_null_attribute; + otype_cstrs = constraints; + otype_attributes = attrs } + +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_constr_args ppf tys + +(* Print an extension declaration *) + +(* 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 = + tree_of_constructor_args_and_ret_type + 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 = + tree_of_constructor_args_and_ret_type + ext.ext_args + ext.ext_ret_type + in + Fmt.fprintf ppf "@[%a@]" + !Oprint.out_constr { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* 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 ty = tree_of_type_scheme decl.val_type in + (* Important: process the fvs *after* the type; tree_of_type_scheme + resets the naming context *) + wrap_mutation (fun () -> + let moda = + if Mode.Modality.is_undefined decl.val_modalities then + Mode.Modality.Const.id + else + Ctype.zap_modalities_to_floor_if_modes_enabled_at Alpha + decl.val_modalities + in + let qsvs, qtvs = + (* Important: process the fvs *after* the type; tree_of_type_scheme + resets the naming context. Both must be inside print_with_genvars + so that sort poly var names are registered when jkinds are printed. *) + Jkind_types.Sort.print_with_genvars (Lpoly.get_exn decl.val_lpoly) + (fun names -> names, extract_qtvs [decl.val_type]) + in + let apparent_arity = + let rec count n typ = + match get_desc typ with + | Tarrow (_,_,typ,_) -> count (n+1) typ + | _ -> n + in + count 0 decl.val_type + in + let attrs = + match Zero_alloc.get decl.val_zero_alloc with + | Default_zero_alloc | Ignore_assert_all -> [] + | Check { strict; opt; arity; custom_error_msg; loc = _; } -> + [{ oattr_name = + String.concat "" + ["zero_alloc"; + if strict then " strict" else ""; + if opt then " opt" else ""; + if arity = apparent_arity then "" else + Printf.sprintf " arity %d" arity; + match custom_error_msg with + | None -> "" + | Some msg -> Printf.sprintf " custom_error_message %S" msg + ] }] + | Assume { strict; never_returns_normally; arity; _ } -> + [{ oattr_name = + String.concat "" + ["zero_alloc assume"; + if strict then " strict" else ""; + if never_returns_normally then " never_returns_normally" else ""; + if arity = apparent_arity then "" else + Printf.sprintf " arity %d" arity; + ] + }] + in + let vd = + { oval_name = id; + oval_type = Otyp_newlayout(qsvs, Otyp_poly(qtvs, ty)); + oval_modalities = tree_of_modalities Immutable moda; + oval_prims = []; + oval_attributes = attrs + } + 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 + let tyl = List.map Transient_expr.repr tyl in + let qtvs = tree_of_qtvs tyl in + let qtvs = zap_qtvs_if_boring qtvs in + Names.remove_names tyl; + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, Otyp_poly(qtvs, 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) + || deep_occur_list 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 = Asttypes.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_omittable l then outcome_label l + else Nolabel + in + let tr = + if is_optional l then + match get_desc (Ctype.expand_head !printing_env 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 + (* CR layouts: fix next line when adding support for jkind + annotations on class type parameters *) + let ot_jkind = param_jkind param in + match tree_of_typexp Type_scheme param with + Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance; ot_jkind} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} + +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_jkind = Jkind.Builtin.any ~why:Dummy_jkind; + type_ikind = Types.ikinds_todo "print dummy"; + 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_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + type_unboxed_version = None; + } + +(** 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_jkind (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.is_global_or_predef 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 expand_module_type = + ref ((fun _env _mty -> assert false) : + Env.t -> module_type -> module_type) + +(** How to abbreviate signatures *) +module Abbrev = struct + (* The code is substantially simpler if [width] is mutable. Strictly speaking, [depth] + doesn't have to be mutable here but mixed mutability would be quite confusing. *) + type t = + { (* To what depth to unfold the module tree *) + mutable depth : int + (* How many signature items to print in total across all signatures *) + ; mutable width : int + } + + (** Standard abbreviation heuristic *) + let abbrev () = + { depth = 4 + ; width = 16 + } + + (** Don't print any signature items *) + let ellipsis () = + { depth = 0 + ; width = 0 + } + + (** Should we print anything in this signature *) + let exhausted = function + | Some {depth; width} -> depth <= 0 || width <= 0 + | None -> false + + (** Run [f] at one deeper unfolding level *) + let deeper t f = + match t with + | Some t -> + let saved = t.depth in + t.depth <- t.depth - 1; + let x = f () in + t.depth <- saved; + x + | None -> f () + + (** Reduce the remaining width by the number of items in [sg] and return the number of + items to print in [sg] and a flag that inidicates whether [sg] is being trimmed. *) + let items t sg = + match t with + | Some t -> + let n = List.length sg in + let k = min t.width n in + t.width <- t.width - n; + Some k, (k < n) + | None -> + None, false +end + +let tree_of_jkind_declaration id decl = + let ojkind = + { ojkind_name = Ident.name id + ; ojkind_jkind = + Option.map + (fun jkind -> + jkind |> Jkind.Desc.of_const |> out_jkind_of_desc !printing_env) + decl.jkind_manifest + } + in + Osig_jkind ojkind + +let rec tree_of_modtype ?abbrev = function + | Mty_ident p -> + Omty_ident (tree_of_path (Some Module_type) p) + | Mty_signature sg -> + Omty_signature (tree_of_signature ?abbrev sg) + | Mty_functor(param, ty_res, m_res) -> + wrap_mutation (fun () -> + let param, env = + tree_of_functor_parameter ?abbrev param + in + let res = wrap_env env (tree_of_modtype ?abbrev) ty_res in + let mres = m_res |> Mode.Alloc.zap_to_legacy |> tree_of_modes in + Omty_functor (param, res, mres)) + | Mty_alias p -> + Omty_alias (tree_of_path (Some Module) p) + | Mty_strengthen _ as mty -> + begin match !expand_module_type !printing_env mty with + | Mty_strengthen (mty,p,a) -> + let unaliasable = + not (Aliasability.is_aliasable a) + && not (Env.is_functor_arg p !printing_env) + in + Omty_strengthen + (tree_of_modtype ?abbrev mty, tree_of_path (Some Module) p, unaliasable) + | mty -> tree_of_modtype ?abbrev mty + end + +and tree_of_functor_parameter ?abbrev = function + | Unit -> + None, fun k -> k + | Named (param, ty_arg, m_arg) -> + let name, env = + match param with + | None -> None, fun env -> env + | Some id -> + Some (Ident.name id), + fun k -> Env.add_module ~arg:true id Mp_present ty_arg k + in + let marg = m_arg |> Mode.Alloc.zap_to_legacy |> tree_of_modes in + Some (name, tree_of_modtype ?abbrev ty_arg, marg), env + +and tree_of_signature ?abbrev = function + | [] -> [] + | _ when Abbrev.exhausted abbrev -> [Osig_ellipsis] + | sg -> + Abbrev.deeper abbrev (fun () -> + wrap_env (fun env -> env)(fun sg -> + (* Only expand signatures to 'abbrev.depth' depth and print at most 'abbrev.width' + items overall. We just keep decreasing 'abbrev.width' during the traversal but + make sure that we expand the current signature up to 'abbrev.width' before + expanding it's components. Below, 'max_items' is the number of items we should + print in the current signature and 'abbrev.width' is then be the remaining + number of items. This is simpler to implement than proper breadth-first. *) + let max_items, trimmed = Abbrev.items abbrev sg in + let tree_groups = tree_of_signature_rec ?abbrev ?max_items !printing_env sg in + let items = List.concat_map (fun (_env,l) -> List.map snd l) tree_groups in + if trimmed then items @ [Osig_ellipsis] else items + ) sg + ) + +and tree_of_signature_rec ?abbrev ?max_items env' sg = + let structured = List.of_seq (Signature_group.seq sg) in + (* Don't descent into more than 'max_items' (if set) elements to save time. *) + let collect_trees_of_rec_group max_items group = + match max_items with + | Some n when n <= 0 -> (max_items, (!printing_env, [])) + | Some _ | None -> + let env = !printing_env in + let env', group_trees = + Naming_context.with_ctx + (fun () -> trees_of_recursive_sigitem_group ?abbrev env group) + in + set_printing_env env'; + let max_items, group_trees = match max_items with + | None -> None, group_trees + | Some n -> + let rec take n acc xs = + match n, xs with + | 0, _ | _, [] -> n, List.rev acc + | n, x :: xs -> take (n-1) (x :: acc) xs + in + let n, group_trees = take n [] group_trees in + Some n, group_trees + in + max_items, (env, group_trees) + in + set_printing_env env'; + snd (List.fold_left_map collect_trees_of_rec_group max_items structured) + +and trees_of_recursive_sigitem_group ?abbrev env + (syntactic_group: Signature_group.rec_group) = + let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem ?abbrev 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 ?abbrev = 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 abbrev = + if List.exists (function + | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true + | _ -> false) + md.md_attributes + then Some (Abbrev.ellipsis ()) + else abbrev + in + tree_of_module ?abbrev id md rs + | Sig_modtype(id, decl, _) -> + tree_of_modtype_declaration ?abbrev 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 + | Sig_jkind(id, decl, _) -> + tree_of_jkind_declaration id decl + +and tree_of_modtype_declaration ?abbrev id decl = + let mty = + match decl.mtd_type with + | None -> Omty_abstract + | Some mty -> tree_of_modtype ?abbrev mty + in + Osig_modtype (Ident.name id, mty) + +and tree_of_module ?abbrev id md rs = wrap_mutation (fun () -> + let moda = + if Mode.Modality.is_undefined md.md_modalities then + Mode.Modality.Const.id + else + Ctype.zap_modalities_to_floor_if_at_least Alpha md.md_modalities + in + Osig_module (Ident.name id, tree_of_modtype ?abbrev md.md_type, + tree_of_modalities Immutable moda, + tree_of_rec rs) + ) + +let rec functor_parameters ~sep custom_printer = function + | [] -> ignore + | [id,param] -> + Fmt.dprintf "%t%t" + (custom_printer param) + (functor_param ~sep ~custom_printer id []) + | (id,param) :: q -> + Fmt.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(); + reset_naming_context (); + 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 + +(* Print a signature body (used by -i when compiling a .ml) *) + +let print_signature ppf tree = + fprintf ppf "@[%a@]" !Oprint.out_signature tree + +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 (); + reset_naming_context (); + let t = tree_of_signature sg in + if Warnings.(is_active @@ Erroneous_printed_signature "") + && Conflicts.exists () + then begin + let conflicts = Format_doc.asprintf "%t" Conflicts.print_explanations in + Location.prerr_warning (Location.in_file sourcefile) + (Warnings.Erroneous_printed_signature conflicts); + Warnings.check_fatal () + end; + compat print_signature ppf 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' + ~var_jkinds mode Errortrace.{ty = t; expanded = t'} = + let tree_of_typexp' ty = + let out = tree_of_typexp mode ty in + if var_jkinds then + match get_desc ty with + | Tvar { jkind; _ } | Tunivar { jkind; _ } -> + let okind = out_jkind_of_desc !printing_env (Jkind.get jkind) in + Otyp_jkind_annot (out, okind) + | _ -> + out + else + out + in + reset_loop_marks (); + mark_loops t; + if same_path t t' + then begin add_delayed (proxy t); Same (tree_of_typexp' 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 *) + print_reduced_evals := false; (* preserve unreduced eval in types *) + let first = tree_of_typexp' t in + print_reduced_evals := true; + let second = tree_of_typexp' t' in + if first = second then Same first + else Diff(first,second) + end + +let trees_of_type_expansion = + trees_of_type_expansion' ~var_jkinds:false + +let pp_type ppf t = + Style.as_inline_code !Oprint.out_type ppf t + +let quoted_ident ppf t = + Style.as_inline_code !Oprint.out_ident ppf t + +let type_expansion ppf = function + | Same t -> pp_type ppf t + | Diff(t,t') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + pp_type t + pp_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 -> quoted_ident ppf p + | Diff(p,p') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + quoted_ident p + quoted_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 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 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 + +(* 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) + (Jkind.Builtin.value ~why:Row_variable)))) + | _ -> 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 = + Fmt.dprintf "%a" !Oprint.out_ident (tree_of_path (Some 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_arg env ty = + let ty, vars = tpoly_get_poly ty in + if vars <> [] then false + else begin + match get_desc (Ctype.expand_head env ty) with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + end + +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 = + match get_desc t3, get_desc t4 with + | Tarrow (_, ty1, ty2, _), _ + when is_unit_arg 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_arg 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 explain_fixed_row pos expl = match expl with + | Fixed_private -> + doc_printf "The %a variant type is private" Errortrace.print_pos pos + | Univar x -> + reserve_names 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 + | 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 + | Rigid -> Format_doc.Doc.empty + | Fixed_existential -> 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 | Fixed_existential)) -> + (* 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 -> + reserve_names 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 (Style.as_inline_code path) p + ) + | Errortrace.Module_type p -> Some( + doc_printf + "%a@,@[The module type@;<1 2>%a@ would escape its scope@]" + pp_doc pre (Style.as_inline_code path) p + ) + | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> + reserve_names 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) = + reserve_names diff.got; + reserve_names 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 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; + 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.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 _ -> + mark_loops x; + mark_loops y; + 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 + | Errortrace.Bad_jkind (t,e) -> + Some (doc_printf "@ @[%a@]" + (Jkind.Violation.report_with_offender + ~offender:(fun ppf -> type_expr ppf t) + env) e) + | Errortrace.Bad_jkind_sort (t,e) -> + Some (doc_printf "@ @[%a@]" + (Jkind.Violation.report_with_offender_sort + ~offender:(fun ppf -> type_expr ppf t) + env) e) + | Errortrace.Unequal_var_jkinds (t1,k1,t2,k2) -> + let fmt_history t k ppf = + Jkind.(format_history env ~intro:( + dprintf "The layout of %a is %a" prepared_type_expr t + (format env) k) ppf k) + in + Some (doc_printf "@ because the layouts of their variables are different.\ + @ @[%t@;%t@]" + (fmt_history t1 k1) (fmt_history t2 k2)) + | Errortrace.Unequal_tof_kind_jkinds (k1, k2) -> + let fmt_history which k ppf = + Jkind.(format_history env ~intro:( + dprintf "The kind of %s is %a" which (format env) k) ppf k) + in + Some (doc_printf "@ because their kinds are different.\ + @ @[%t@;%t@]" + (fmt_history "the first" k1) (fmt_history "the second" k2)) + +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 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 ~var_jkinds mode txt_got txt_but = function + | None -> Format_doc.Doc.empty + | Some d -> + let d = + Errortrace.map_diff (trees_of_type_expansion' ~var_jkinds mode) d + in + doc_printf "%a@;<1 2>%a@ %a@;<1 2>%a" + pp_doc txt_got type_expansion d.Errortrace.got + pp_doc 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 jkind_error = match Misc.last tr with + | Some (Bad_jkind _ | Bad_jkind_sort _ | Unequal_var_jkinds _ + | Unequal_tof_kind_jkinds _) -> + true + | Some (Diff _ | Escape _ | Variant _ | Obj _ | Incompatible_fields _ + | Rec_occur _) + | None -> + false + in + match tr with + | [] -> assert false + | (elt :: tr) as full_trace -> + try + print_labels := not !Clflags.classic; + 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 ~var_jkinds:jkind_error 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 && not jkind_error + (* the jkinds mechanism has its own way of reporting missing cmis *) + 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; + print_reduced_evals := true; + raise exn + +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 report_unification_error ?type_expected_explanation + ppf env ({trace} : Errortrace.unification_error) = + report_error ?type_expected_explanation 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, 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; + print_labels := true + | _ -> () + with exn -> + print_labels := true; + raise exn + + 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 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 (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 + 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 + "@[%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) + +(* Adapt functions to exposed interface *) +let abbreviate ~abbrev f = + f ?abbrev:(if abbrev then Some (Abbrev.abbrev ()) else None) + +let tree_of_path = tree_of_path None +let tree_of_module ident ?(ellipsis = false) = + tree_of_module ident ?abbrev:(if ellipsis then Some (Abbrev.ellipsis ()) else None) +let tree_of_signature sg = tree_of_signature sg +let tree_of_modtype ?(abbrev = false) ty = + abbreviate ~abbrev tree_of_modtype ty +let tree_of_modtype_declaration ?(abbrev = false) id md = + abbreviate ~abbrev tree_of_modtype_declaration id md +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) + +(** Compatibility module for Format printers *) +module Compat = struct + let longident = Fmt.compat longident + let path = Fmt.compat path + let type_expr = Fmt.compat type_expr + let shared_type_scheme = Fmt.compat shared_type_scheme + let signature = Fmt.compat signature + let class_type = Fmt.compat class_type + let modtype = Fmt.compat modtype + let string_of_label (lbl : Asttypes.arg_label) = + let lbl : Types.arg_label = match lbl with + | Nolabel -> Nolabel + | Labelled s -> Labelled s + | Optional s -> Optional s + in + string_of_label lbl +end +======= +(* *) +(**************************************************************************) + +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 modality ?(id = fun _ppf () -> ()) ax ppf modality = + if Mode.Modality.Per_axis.is_id ax modality then + id ppf () + else + Fmt.asprintf "%a" (Mode.Modality.Per_axis.print ax) modality + |> !Oprint.out_modality ppf + + 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 p) + + let () = Env.print_path := path + let () = Env.print_type_expr := type_expr + + 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 = + !Oprint.out_constr_args ppf (tree_of_constructor_arguments a) + + 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) + + 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 modality ?id ax = + Fmt.compat (modality ?id:(Option.map Fmt.deprecated id) ax) + +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 + +let string_of_label : Types.arg_label -> string = function + | Nolabel -> "" + | Labelled s | Position s -> s + | Optional s -> "?" ^ s + +let () = Jkind.set_printtyp_path Doc.path +let () = Mode.print_longident := Doc.longident +let () = + Env.report_jkind_violation_with_offender := + Jkind.Violation.report_with_offender; + Jkind.set_outcometrees_of_types (fun tys -> + prepare_for_printing tys; + List.map (tree_of_typexp Type) tys); + Jkind.set_outcometree_of_modalities tree_of_modalities; + Jkind.set_print_type_expr Doc.type_expr +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* *) (**************************************************************************) diff --git a/src/ocaml/typing/printtyp.mli b/src/ocaml/typing/printtyp.mli index b6bb876d1..5a7956277 100644 --- a/src/ocaml/typing/printtyp.mli +++ b/src/ocaml/typing/printtyp.mli @@ -2,14 +2,397 @@ (* *) (* 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 *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +(* *) +(**************************************************************************) + +(* Printing functions *) + +open Format_doc +open Types +open Outcometree + +val longident: Longident.t printer +val ident: Ident.t printer +val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string +val tree_of_path: Path.t -> out_ident +val path: Path.t printer +val string_of_path: Path.t -> string + +val type_path: Path.t printer +(** 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 + +type namespace := Shape.Sig_component_kind.t option + +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_row_desc : formatter -> row_desc -> unit +val raw_type_expr: formatter -> type_expr -> unit +val raw_field : formatter -> row_field -> unit +val string_of_label: Types.arg_label -> string + +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. *) + + val reset: unit -> unit + (** Reset the naming context *) +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: explanation list printer + + val print_explanations: Format_doc.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: type_expr printer + +(** Prints a modality. If it is the identity modality, prints [id], which + defaults to nothing. *) +val modality : + ?id:(formatter -> unit) -> 'a Mode.Modality.Axis.t -> formatter -> 'a -> 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: type_expr printer +(** 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: constructor_arguments printer +val tree_of_type_scheme: type_expr -> out_type +val type_scheme: type_expr printer +val prepared_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 tree_of_value_description: Ident.t -> value_description -> out_sig_item +val value_description: Ident.t -> value_description printer +val label : label_declaration printer +val add_constructor_to_preparation : constructor_declaration -> unit +val prepared_constructor : constructor_declaration printer +val constructor : constructor_declaration printer +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 type_declaration: Ident.t -> type_declaration printer +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 -> extension_constructor 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 tree_of_jkind_declaration: + Ident.t -> jkind_declaration -> out_sig_item + +val tree_of_module: + Ident.t -> ?ellipsis:bool -> module_declaration -> rec_status + -> out_sig_item +val modtype: module_type printer +val signature: signature printer +val tree_of_modtype: ?abbrev:bool -> module_type -> out_module_type +val tree_of_modtype_declaration: + ?abbrev:bool -> Ident.t -> modtype_declaration -> out_sig_item + +val expand_module_type: (Env.t -> module_type -> module_type) ref +(* Forward declaration to be filled in Mtype. We want to be able to print types + in Mtype for debugging purposes and hence don't want to depend on Mtype + here. +*) + +(** 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:unit printer -> ('b -> Format_doc.formatter -> unit) -> + (Ident.t option * 'b) list -> Format_doc.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 -> modtype_declaration printer +val class_type: class_type printer +val tree_of_class_declaration: + Ident.t -> class_declaration -> rec_status -> out_sig_item +val class_declaration: Ident.t -> class_declaration printer +val tree_of_cltype_declaration: + Ident.t -> class_type_declaration -> rec_status -> out_sig_item +val cltype_declaration: Ident.t -> class_type_declaration printer +val type_expansion : + type_or_scheme -> Errortrace.expanded_type printer +val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type + +module Compat: sig + (** {!Format} compatible printers *) + type 'a printer := Format.formatter -> 'a -> unit + val longident : Longident.t printer + val path: Path.t printer + val type_expr: type_expr printer + val shared_type_scheme: type_expr printer + val signature: signature printer + val modtype: module_type printer + val class_type: class_type printer + val string_of_label: Asttypes.arg_label -> string +end + +val report_ambiguous_type_error: + formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> + Format_doc.t -> Format_doc.t -> Format_doc.t -> unit + +val report_unification_error : + ?type_expected_explanation:Format_doc.t -> + formatter -> + Env.t -> Errortrace.unification_error -> + Format_doc.t -> Format_doc.t -> + unit + +val report_equality_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.equality_error -> + Format_doc.t -> Format_doc.t -> + unit + +val report_moregen_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.moregen_error -> + Format_doc.t -> Format_doc.t -> + unit + +val report_comparison_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.comparison_error -> + Format_doc.t -> Format_doc.t -> + 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 + +(* for [Translquote] *) +type typobject_repr = { fields : (string * type_expr) list; open_row : bool } +type typvariant_repr = { + fields : (string * bool * type_expr list) list; + name : (Path.t * type_expr list) option; + closed : bool; + present : (string * row_field) list; + all_present : bool; + tags : string list option +} +val tree_of_typobject_repr : type_expr -> typobject_repr +val tree_of_typvariant_repr : row_desc -> typvariant_repr + +(* 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 + +val rewrite_double_underscore_longidents: Env.t -> Longident.t -> Longident.t + +(** [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 +======= +(* *) +(**************************************************************************) + +(** Printing functions *) + + +open Types + +type namespace := Shape.Sig_component_kind.t + +val namespaced_ident: namespace -> Ident.t -> string +val string_of_label: Types.arg_label -> 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 + + (** Prints a modality. If it is the identity modality, prints [id], which + defaults to nothing. *) + val modality : ?id:unit printer -> 'a Mode.Modality.Axis.t -> 'a 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 +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* *) (**************************************************************************) diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index 9860b00e5..670e38b6d 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -40,10 +40,16 @@ let fmt_location f loc = 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.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y.txt s.txt; | Longident.Lapply (y, z) -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z +======= + fprintf f "%a(%a)" fmt_longident_aux y.txt fmt_longident_aux z.txt +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt @@ -151,6 +157,12 @@ let fmt_partiality f x = | Total -> () | Partial -> fprintf f " (Partial)" +let fmt_presence f x = + match x with + | Types.Mp_present -> fprintf f "(Present)" + | Types.Mp_absent -> fprintf f "(Absent)" + + let line i f s (*...*) = fprintf f "%s" (String.make (2*i) ' '); fprintf f s (*...*) @@ -214,7 +226,6 @@ let typevar_jkind ~print_quote ppf (v, l) = let tuple_component_label i ppf = function | None -> line i ppf "Label: None\n" | Some s -> line i ppf "Label: Some \"%s\"\n" s -;; let typevars ppf vs = List.iter (typevar_jkind ~print_quote:true ppf) vs @@ -398,7 +409,7 @@ let rec core_type i ppf x = line i ppf "Ttyp_poly%a\n" (fun ppf -> List.iter (typevar_jkind ~print_quote:true ppf)) sl; core_type i ppf ct; - | Ttyp_package { pack_path = s; pack_fields = l } -> + | Ttyp_package { tpt_path = s; tpt_cstrs = l } -> line i ppf "Ttyp_package %a\n" fmt_path s; list i package_with ppf l; | Ttyp_open (path, _mod_ident, t) -> @@ -439,17 +450,17 @@ and label_ambiguity i ppf = function and poly_param : type a. _ -> _ -> a poly_param -> unit = fun i ppf -> function | Param ty -> - line i ppf "Param %a\n" (Format_doc.compat Printtyp.raw_type_expr) ty + line i ppf "Param %a\n" Rawprinttyp.type_expr ty | Arrow args -> line i ppf "Arrow\n"; list (i+1) (fun i ppf (label, ty) -> arg_label i ppf label; option i (fun i f -> - line i f "%a" (Format_doc.compat Printtyp.raw_type_expr)) ppf ty) + line i f "%a" Rawprinttyp.type_expr) ppf ty) ppf args | Method ({txt}, ty) -> fprintf ppf "Method %s %a\n" txt - (Format_doc.compat Printtyp.raw_type_expr) ty + Rawprinttyp.type_expr ty and type_inspection : type a. _ -> _ -> a type_inspection -> unit = fun i ppf -> function @@ -464,12 +475,7 @@ 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; + List.iter (pattern_extra i ppf) x.pat_extra; match x.pat_desc with | Tpat_any -> line i ppf "Tpat_any\n"; | Tpat_var { id = s; sort; mode = m; _ } -> @@ -545,7 +551,9 @@ and labeled_pattern_with_sorts : pattern i ppf x; line i ppf "%a\n" fmt_sort sort -and pattern_extra i ppf (extra_pat, _, attrs) = +and pattern_extra i ppf (extra_pat, loc, attrs) = + line i ppf "extra %a\n" fmt_location loc; + let i = i + 1 in match extra_pat with | Tpat_unpack -> line i ppf "Tpat_extra_unpack\n"; @@ -579,15 +587,18 @@ and function_body i ppf (body : function_body) = line i ppf "Tfunction_cases%a %a\n" fmt_partiality fc_partial fmt_location fc_loc; + let i = i+1 in alloc_mode_raw i ppf fc_arg_mode; line i ppf "%a\n" fmt_sort fc_arg_sort; - attributes (i+1) ppf fc_attributes; - List.iter (fun e -> expression_extra (i+1) ppf e []) fc_exp_extra; - list (i+1) case ppf fc_cases + attributes i ppf fc_attributes; + List.iter (fun e -> expression_extra i ppf (e, fc_loc, [])) fc_exp_extra; + list i case ppf fc_cases -and expression_extra i ppf x attrs = - match x with - | Texp_constraint (ct) -> +and expression_extra i ppf (extra, loc, attrs) = + line i ppf "extra %a\n" fmt_location loc; + let i = i + 1 in + match extra with + | Texp_constraint ct -> line i ppf "Texp_constraint\n"; attributes i ppf attrs; core_type i ppf ct; @@ -647,12 +658,7 @@ 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; + List.iter (expression_extra i ppf) x.exp_extra; match x.exp_desc with | Texp_ident { path; _ } -> line i ppf "Texp_ident %a\n" fmt_path path; | Texp_apply_layout (exp, args) -> @@ -686,16 +692,17 @@ and expression i ppf x = Option.iter (zero_alloc_assume i ppf) za; expression i ppf e; list i label_x_apply_arg ppf l; - | Texp_match (e, sort, l, partial) -> - line i ppf "Texp_match%a\n" - fmt_partiality partial; + | Texp_match (e, sort, l1, l2, partial) -> + line i ppf "Texp_match%a\n" fmt_partiality partial; expression i ppf e; line i ppf "%a\n" fmt_sort sort; - 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_unboxed_unit -> line i ppf "Texp_unboxed_unit\n"; | Texp_unboxed_bool b -> line i ppf "Texp_unboxed_bool %a\n" fmt_bool b; | Texp_tuple (l, am) -> @@ -1187,9 +1194,8 @@ and signature_item i ppf x = 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 + line i ppf "Tsig_module %a\n" fmt_presence md.md_presence; + module_declaration i ppf md | Tsig_modsubst ms -> line i ppf "Tsig_modsubst \"%a\" = %a\n" fmt_ident ms.ms_id fmt_path ms.ms_manifest; @@ -1228,7 +1234,7 @@ and signature_item i ppf x = jkind_declaration i ppf jd and module_declaration i ppf md = - line i ppf "%a" fmt_modname md.md_id; + line i ppf "%a\n" fmt_modname md.md_id; attributes i ppf md.md_attributes; module_type (i+1) ppf md.md_type; @@ -1326,7 +1332,7 @@ and structure_item i ppf x = line i ppf "Tstr_exception\n"; type_exception i ppf ext; | Tstr_module x -> - line i ppf "Tstr_module\n"; + line i ppf "Tstr_module %a\n" fmt_presence x.mb_presence; module_binding i ppf x | Tstr_recmodule bindings -> line i ppf "Tstr_recmodule\n"; diff --git a/src/ocaml/typing/rawprinttyp.ml b/src/ocaml/typing/rawprinttyp.ml new file mode 100644 index 000000000..e0f86e8ca --- /dev/null +++ b/src/ocaml/typing/rawprinttyp.ml @@ -0,0 +1,196 @@ +(**************************************************************************) +(* *) +(* 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 Mode +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 string_of_label : Types.arg_label -> string = function + Nolabel -> "" + | Labelled s | Position 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;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 labeled_type ppf (label, ty) = + begin match label with + | Some s -> fprintf ppf "label=\"%s\" " s + | None -> () + end; + raw_type ppf ty +and raw_type_list tl = raw_list raw_type tl +and labeled_type_list tl = raw_list labeled_type tl +and raw_lid_type_list tl = + raw_list (fun ppf (lid, typ) -> + let lid = Longident.unflatten lid |> Option.get in + fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) + tl +and raw_row_desc ppf 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) +and raw_type_desc ppf ty = + let env = Env.empty in + match ty with + Tvar { name; jkind } -> + fprintf ppf "Tvar (@,%a,@,%a)" + print_name name (Format_doc.compat (Jkind.format env)) jkind + | Tarrow((l,arg,ret),t1,t2,c) -> + fprintf ppf "@[Tarrow((\"%s\",%a,%a),@,%a,@,%a,@,%s)@]" + (string_of_label l) + (Format_doc.compat (Alloc.print ~verbose:true ())) arg + (Format_doc.compat (Alloc.print ~verbose:true ())) ret + raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" labeled_type_list tl + | Tunboxed_tuple tl -> + fprintf ppf "@[<1>Tunboxed_tuple@,%a@]" labeled_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) + | Tquote t -> + fprintf ppf "@[Tquote@ %a@]" raw_type t + | Tsplice t -> + fprintf ppf "@[Tsplice@ %a@]" raw_type t + | Tquote_eval t -> + fprintf ppf "@[Tquote_eval@ %a@]" raw_type t + | 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; jkind } -> + fprintf ppf "Tunivar (@,%a,@,%a)" + print_name name (Format_doc.compat (Jkind.format env)) jkind + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Trepr (t, sort_vars) -> + let print_sort_univar ppf uv = + fprintf ppf "%s" (Option.value uv.Jkind_types.Sort.name ~default:"_") + in + fprintf ppf "@[Trepr(@,%a,@,[@[%a@]])@]" + raw_type t + (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@ ") + print_sort_univar) sort_vars + | Tvariant row -> + raw_row_desc ppf row + | Tpackage pack -> + fprintf ppf "@[Tpackage(@,%a,@,%a)@]" + path pack.pack_path + raw_lid_type_list pack.pack_cstrs + | Tof_kind jkind -> + fprintf ppf "Tof_kind@ %a" (Format_doc.compat (Jkind.format env)) jkind +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 +| Some Types.Fixed_existential -> fprintf ppf "Some Fixed_existential" + +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 := [] +let row_field = raw_field +let row_desc = raw_row_desc + +let () = Btype.print_raw := type_expr +let () = Jkind.set_raw_type_expr type_expr diff --git a/src/ocaml/typing/rawprinttyp.mli b/src/ocaml/typing/rawprinttyp.mli new file mode 100644 index 000000000..cffde2342 --- /dev/null +++ b/src/ocaml/typing/rawprinttyp.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* 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 +val row_field: Format.formatter -> Types.row_field -> unit +val row_desc: Format.formatter -> Types.row_desc -> unit diff --git a/src/ocaml/typing/tast_iterator.ml b/src/ocaml/typing/tast_iterator.ml index 67ef97da9..f81b2328a 100644 --- a/src/ocaml/typing/tast_iterator.ml +++ b/src/ocaml/typing/tast_iterator.ml @@ -76,6 +76,20 @@ type iterator = let iter_snd f (_, y) = f y let iter_loc sub {loc; _} = sub.location sub loc +let rec iter_loc_lid sub lid = + let open Longident in + match lid with + | Lident _ -> () + | Ldot (lid, id) -> + iter_loc sub lid; iter_loc_lid sub lid.txt; iter_loc sub id + | Lapply (lid, lid') -> + iter_loc sub lid; iter_loc_lid sub lid.txt; + iter_loc sub lid'; iter_loc_lid sub lid'.txt + +let iter_loc_lid sub {loc; txt} = + iter_loc sub {loc; txt}; + iter_loc_lid sub txt + let location _sub _l = () let attribute sub x = @@ -122,7 +136,7 @@ let module_substitution sub ms = sub.location sub ms_loc; sub.attributes sub ms_attributes; iter_loc sub ms_name; - iter_loc sub ms_txt + iter_loc_lid sub ms_txt let include_kind sub = function | Tincl_structure -> () @@ -237,7 +251,7 @@ 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; + iter_loc_lid sub x.tyext_txt; List.iter (fun (c, _) -> sub.typ sub c) x.tyext_params; List.iter (sub.extension_constructor sub) x.tyext_constructors @@ -256,7 +270,7 @@ let extension_constructor sub ec = | Text_decl (_, ctl, cto) -> constructor_args sub ctl; Option.iter (sub.typ sub) cto - | Text_rebind (_, lid) -> iter_loc sub lid + | Text_rebind (_, lid) -> iter_loc_lid sub lid let[@warning "+9"] jkind_declaration sub ({jkind_id=_; jkind_name; jkind_jkind=_; jkind_annotation; @@ -271,9 +285,9 @@ 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_type (_, lid) -> iter_loc_lid sub lid | Tpat_unpack -> () - | Tpat_open (_, lid, env) -> iter_loc sub lid; sub.env sub env + | Tpat_open (_, lid, env) -> iter_loc_lid sub lid; sub.env sub env | Tpat_constraint (ct, ma) -> sub.typ sub ct; sub.modes sub ma | Tpat_inspected_type (Label_disambiguation _) -> () | Tpat_inspected_type (Polymorphic_parameter (Param _)) -> () @@ -294,7 +308,7 @@ let pat | Tpat_tuple l -> List.iter (fun (_, p) -> sub.pat sub p) l | Tpat_unboxed_tuple l -> List.iter (fun (_, p, _) -> sub.pat sub p) l | Tpat_construct (lid, _, l, vto) -> - iter_loc sub lid; + iter_loc_lid sub lid; List.iter (sub.pat sub) l; Option.iter (fun (vs, ct) -> List.iter @@ -305,9 +319,9 @@ let pat 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 + List.iter (fun (lid, _, i) -> iter_loc_lid sub lid; sub.pat sub i) l | Tpat_record_unboxed_product (l, _) -> - List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l + List.iter (fun (lid, _, i) -> iter_loc_lid sub lid; sub.pat sub i) l | Tpat_array (_, _, l) -> List.iter (sub.pat sub) l | Tpat_alias { pattern = p; name = s; _ } -> sub.pat sub p; iter_loc sub s | Tpat_lazy p -> sub.pat sub p @@ -371,7 +385,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = let iter_fields fields = Array.iter (function | _, Kept _ -> () - | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) + | _, Overridden (lid, exp) -> iter_loc_lid sub lid; sub.expr sub exp) fields in let iter_block_access sub = function @@ -382,7 +396,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Uaccess_unboxed_field (lid, _) -> iter_loc sub lid in match exp_desc with - | Texp_ident { lid; _ } -> iter_loc sub lid + | Texp_ident { lid; _ } -> iter_loc_lid sub lid | Texp_apply_layout (exp, _) -> sub.expr sub exp | Texp_constant _ -> () | Texp_let (rec_flag, list, exp) -> @@ -401,18 +415,20 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | (_, Arg (exp, _)) -> sub.expr sub exp | (_, Omitted _) -> ()) 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_unboxed_unit -> () | Texp_unboxed_bool _ -> () - | Texp_tuple (list, _) -> List.iter (fun (_,e) -> sub.expr sub e) list - | Texp_unboxed_tuple list -> List.iter (fun (_,e,_) -> sub.expr sub e) list + | Texp_tuple (list, _) -> List.iter (fun (_, e) -> sub.expr sub e) list + | Texp_unboxed_tuple list -> List.iter (fun (_, e, _) -> sub.expr sub e) list | Texp_construct (lid, _, args, _) -> - iter_loc sub lid; + iter_loc_lid sub lid; List.iter (sub.expr sub) args | Texp_variant (_, expo) -> Option.iter (fun (expr, _) -> sub.expr sub expr) expo | Texp_record { fields; extended_expression; _} -> @@ -422,13 +438,13 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = iter_fields fields; Option.iter (fun (exp, _) -> sub.expr sub exp) extended_expression; | Texp_field (exp, _, lid, _, _, _) -> - iter_loc sub lid; + iter_loc_lid sub lid; sub.expr sub exp | Texp_unboxed_field (exp, _, lid, _, _) -> - iter_loc sub lid; + iter_loc_lid sub lid; sub.expr sub exp | Texp_setfield (exp1, _, lid, _, exp2) -> - iter_loc sub lid; + iter_loc_lid sub lid; sub.expr sub exp1; sub.expr sub exp2 | Texp_array (_, _, list, _) -> List.iter (sub.expr sub) list @@ -456,7 +472,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = sub.expr sub exp) comp_clauses | Texp_atomic_loc (exp, _, lid, _, _) -> - iter_loc sub lid; + iter_loc_lid sub lid; sub.expr sub exp | Texp_ifthenelse (exp1, exp2, expo) -> sub.expr sub exp1; @@ -474,7 +490,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = sub.expr sub for_body | Texp_send (exp, _, _) -> sub.expr sub exp - | Texp_new (_, lid, _, _) -> iter_loc sub lid + | Texp_new (_, lid, _, _) -> iter_loc_lid sub lid | Texp_instvar (_, _, s) -> iter_loc sub s | Texp_mutvar id -> iter_loc sub id | Texp_setinstvar (_, _, s, exp) -> @@ -501,7 +517,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = List.iter (sub.binding_op sub) ands; sub.case sub body | Texp_unreachable -> () - | Texp_extension_constructor (lid, _) -> iter_loc sub lid + | Texp_extension_constructor (lid, _) -> iter_loc_lid sub lid | Texp_open (od, e) -> sub.open_declaration sub od; sub.expr sub e @@ -517,9 +533,9 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Texp_quotation exp -> sub.expr sub exp | Texp_antiquotation exp -> sub.expr sub exp -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 package_type sub {tpt_cstrs; tpt_txt; _} = + List.iter (fun (lid, p) -> iter_loc_lid sub lid; sub.typ sub p) tpt_cstrs; + iter_loc_lid sub tpt_txt let binding_op sub {bop_loc; bop_op_name; bop_exp; _} = sub.location sub bop_loc; @@ -576,8 +592,8 @@ let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = 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_ident (_, lid) -> iter_loc_lid sub lid + | Tmty_alias (_, lid) -> iter_loc_lid sub lid | Tmty_signature sg -> sub.signature sub sg | Tmty_functor (arg, mtype2, mmode2) -> functor_parameter sub arg; @@ -586,15 +602,17 @@ let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = | Tmty_with (mtype, list) -> sub.module_type sub mtype; List.iter (fun (_, lid, e) -> - iter_loc sub lid; sub.with_constraint sub e) list + iter_loc_lid sub lid; sub.with_constraint sub e) list | Tmty_typeof mexpr -> sub.module_expr sub mexpr - | Tmty_strengthen (mtype, _, _) -> sub.module_type sub mtype + | Tmty_strengthen (mtype, _, lid) -> + sub.module_type sub mtype; + iter_loc_lid sub lid 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_module (_, lid) -> iter_loc_lid sub lid + | Twith_modsubst (_, lid) -> iter_loc_lid sub lid | Twith_modtype mty -> sub.module_type sub mty | Twith_modtypesubst mty -> sub.module_type sub mty | Twith_jkind jd -> sub.jkind_declaration sub jd @@ -604,7 +622,7 @@ let with_constraint sub = function 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; + iter_snd (iter_loc_lid sub) open_expr; sub.env sub open_env let open_declaration sub {open_loc; open_expr; open_env; open_attributes; _} = @@ -627,14 +645,25 @@ let module_coercion sub = function | Tcoerce_primitive {pc_loc; pc_env; _} -> sub.location sub pc_loc; sub.env sub pc_env + | Tcoerce_invalid -> () -let module_expr sub {mod_loc; mod_desc; mod_env; mod_attributes; _} = +let module_expr sub {mod_loc; mod_desc; mod_mode; mod_env; mod_attributes; _} = sub.location sub mod_loc; sub.attributes sub mod_attributes; + begin match mod_mode with + | _, None -> () + | _, Some (_, txt, loc) -> iter_loc_lid sub {txt; loc} + end; sub.env sub mod_env; match mod_desc with +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 | Tmod_typed_hole -> () | Tmod_ident (_, lid) -> iter_loc sub lid +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | Tmod_ident (_, lid) -> iter_loc sub lid +======= + | Tmod_ident (_, lid) -> iter_loc_lid sub lid +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | Tmod_structure st -> sub.structure sub st | Tmod_functor (arg, mexpr) -> functor_parameter sub arg; @@ -686,7 +715,7 @@ let class_expr sub {cl_loc; cl_desc; cl_env; cl_attributes; _} = List.iter (fun (_, e) -> sub.expr sub e) ivars; sub.class_expr sub cl | Tcl_ident (_, lid, tyl) -> - iter_loc sub lid; + iter_loc_lid sub lid; List.iter (sub.typ sub) tyl | Tcl_open (od, e) -> sub.open_description sub od; @@ -699,7 +728,7 @@ let class_type sub {cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes; _} = match cltyp_desc with | Tcty_signature csg -> sub.class_signature sub csg | Tcty_constr (_, lid, list) -> - iter_loc sub lid; + iter_loc_lid sub lid; List.iter (sub.typ sub) list | Tcty_arrow (_, ct, cl) -> sub.typ sub ct; @@ -739,11 +768,11 @@ let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = | Ttyp_tuple list -> List.iter (fun (_, t) -> sub.typ sub t) list | Ttyp_unboxed_tuple list -> List.iter (fun (_, t) -> sub.typ sub t) list | Ttyp_constr (_, lid, list) -> - iter_loc sub lid; + iter_loc_lid 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; + iter_loc_lid sub lid; List.iter (sub.typ sub) list | Ttyp_alias (ct, _, jkind) -> sub.typ sub ct; @@ -754,7 +783,7 @@ let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = sub.typ sub ct | Ttyp_package pack -> sub.package_type sub pack | Ttyp_open (_, mod_ident, t) -> - iter_loc sub mod_ident; + iter_loc_lid sub mod_ident; sub.typ sub t | Ttyp_quote t -> sub.typ sub t | Ttyp_splice t -> sub.typ sub t diff --git a/src/ocaml/typing/tast_mapper.ml b/src/ocaml/typing/tast_mapper.ml index a11182174..4581bd9e0 100644 --- a/src/ocaml/typing/tast_mapper.ml +++ b/src/ocaml/typing/tast_mapper.ml @@ -85,6 +85,22 @@ 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 rec map_loc_lid sub lid = + let open Longident in + match lid with + | Lident id -> Lident id + | Ldot (lid, id) -> + let lid = { lid with txt = map_loc_lid sub lid.txt } in + Ldot (map_loc sub lid, map_loc sub id) + | Lapply (lid, lid') -> + let lid = { lid with txt = map_loc_lid sub lid.txt } in + let lid' = { lid' with txt = map_loc_lid sub lid'.txt } in + Lapply(map_loc sub lid, map_loc sub lid') + +let map_loc_lid sub {loc; txt} = + let txt = map_loc_lid sub txt in + map_loc sub {loc; txt} + let location _sub l = l let attribute sub x = @@ -134,7 +150,7 @@ let module_declaration sub x = 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_txt = map_loc_lid 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} @@ -267,7 +283,7 @@ let type_declarations sub (rec_flag, 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_txt = map_loc_lid 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 @@ -298,7 +314,7 @@ let extension_constructor sub x = Option.map (sub.typ sub) cto ) | Text_rebind (path, lid) -> - Text_rebind (path, map_loc sub lid) + Text_rebind (path, map_loc_lid sub lid) in let ext_attributes = sub.attributes sub x.ext_attributes in {x with ext_loc; ext_name; ext_kind; ext_attributes} @@ -317,9 +333,9 @@ let[@warning "+9"] jkind_declaration sub 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_type (path,lid) -> Tpat_type (path, map_loc_lid sub lid) + | Tpat_open (path,lid,env) -> + Tpat_open (path, map_loc_lid sub lid, sub.env sub env) | Tpat_constraint (ct, ma) -> Tpat_constraint (sub.typ sub ct, sub.modes sub ma) | Tpat_inspected_type (Label_disambiguation _) as d -> d @@ -345,22 +361,24 @@ let pat | Tpat_unboxed_tuple l -> Tpat_unboxed_tuple (List.map (fun (label, p, sort) -> label, sub.pat sub p, sort) l) - | Tpat_construct (loc, cd, l, vto) -> + | Tpat_construct (lid, cd, l, vto) -> let vto = Option.map (fun (vl,cty) -> List.map (fun (v, jk) -> (map_loc sub v, Option.map (sub.jkind_annotation sub) jk)) vl, sub.typ sub cty) vto in - Tpat_construct (map_loc sub loc, cd, List.map (sub.pat sub) l, vto) + Tpat_construct (map_loc_lid sub lid, 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_record + (List.map (tuple3 (map_loc_lid sub) id (sub.pat sub)) l, closed) | Tpat_record_unboxed_product (l, closed) -> Tpat_record_unboxed_product - (List.map (tuple3 (map_loc sub) id (sub.pat sub)) l, closed) - | Tpat_array (am, arg_sort, l) -> Tpat_array (am, arg_sort, List.map (sub.pat sub) l) + (List.map (tuple3 (map_loc_lid sub) id (sub.pat sub)) l, closed) + | Tpat_array (am, arg_sort, l) -> + Tpat_array (am, arg_sort, List.map (sub.pat sub) l) | Tpat_alias { pattern; id; name; uid; sort; mode; type_expr } -> Tpat_alias { pattern = sub.pat sub pattern; id; name = map_loc sub name; uid; @@ -501,23 +519,23 @@ let expr sub x = Array.map (function | label, Kept (t, mut, uu) -> label, Kept (t, mut, uu) | label, Overridden (lid, exp) -> - label, Overridden (map_loc sub lid, sub.expr sub exp)) + label, Overridden (map_loc_lid sub lid, sub.expr sub exp)) fields in let map_block_access sub = function | Baccess_field (lid, ld) -> - Baccess_field (map_loc sub lid, ld) + Baccess_field (map_loc_lid sub lid, ld) | Baccess_block (mut, idx) -> Baccess_block (mut, sub.expr sub idx) in let map_unboxed_access sub = function | Uaccess_unboxed_field (lid, ld) -> - Uaccess_unboxed_field (map_loc sub lid, ld) + Uaccess_unboxed_field (map_loc_lid sub lid, ld) in let exp_desc = match x.exp_desc with | Texp_ident r -> - Texp_ident { r with lid = map_loc sub r.lid } + Texp_ident { r with lid = map_loc_lid sub r.lid } | Texp_apply_layout (exp, args) -> Texp_apply_layout (sub.expr sub exp, args) | Texp_constant _ as d -> d @@ -536,23 +554,24 @@ let expr sub x = | Texp_apply (exp, list, pos, am, za) -> Texp_apply ( sub.expr sub exp, - List.map (function - | (lbl, Arg (exp, sort)) -> (lbl, Arg (sub.expr sub exp, sort)) - | (lbl, Omitted o) -> (lbl, Omitted o)) + List.map + (tuple2 id (Typedtree.map_apply_arg (tuple2 (sub.expr sub) id))) list, pos, am, za ) - | Texp_match (exp, sort, cases, p) -> + | Texp_match (exp, sort, cases, eff_cases, p) -> Texp_match ( sub.expr sub exp, sort, 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_unboxed_unit -> Texp_unboxed_unit | Texp_unboxed_bool b -> Texp_unboxed_bool b @@ -562,7 +581,8 @@ let expr sub x = Texp_unboxed_tuple (List.map (fun (label, e, s) -> label, sub.expr sub e, s) list) | Texp_construct (lid, cd, args, am) -> - Texp_construct (map_loc sub lid, cd, List.map (sub.expr sub) args, am) + Texp_construct + (map_loc_lid sub lid, cd, List.map (sub.expr sub) args, am) | Texp_variant (l, expo) -> Texp_variant (l, Option.map (fun (e, am) -> (sub.expr sub e, am)) expo) | Texp_record { fields; representation; extended_expression; alloc_mode } -> @@ -582,20 +602,20 @@ let expr sub x = (fun (exp, sort) -> (sub.expr sub exp, sort)) extended_expression } | Texp_field (exp, sort, lid, ld, float, ubr) -> - Texp_field (sub.expr sub exp, sort, map_loc sub lid, ld, float, ubr) + Texp_field (sub.expr sub exp, sort, map_loc_lid sub lid, ld, float, ubr) | Texp_unboxed_field (exp, sort, lid, ld, uu) -> - Texp_unboxed_field (sub.expr sub exp, sort, map_loc sub lid, ld, uu) + Texp_unboxed_field (sub.expr sub exp, sort, map_loc_lid sub lid, ld, uu) | Texp_setfield (exp1, am, lid, ld, exp2) -> Texp_setfield ( sub.expr sub exp1, am, - map_loc sub lid, + map_loc_lid sub lid, ld, sub.expr sub exp2 ) | Texp_atomic_loc (exp, sort, lid, ld, alloc_mode) -> Texp_atomic_loc - (sub.expr sub exp, sort, map_loc sub lid, ld, alloc_mode) + (sub.expr sub exp, sort, map_loc_lid sub lid, ld, alloc_mode) | Texp_array (amut, sort, list, alloc_mode) -> Texp_array (amut, sort, List.map (sub.expr sub) list, alloc_mode) | Texp_idx (ba, uas) -> @@ -636,7 +656,7 @@ let expr sub x = | Texp_new (path, lid, cd, apos) -> Texp_new ( path, - map_loc sub lid, + map_loc_lid sub lid, cd, apos ) @@ -697,7 +717,7 @@ let expr sub x = | Texp_unreachable -> Texp_unreachable | Texp_extension_constructor (lid, path) -> - Texp_extension_constructor (map_loc sub lid, path) + Texp_extension_constructor (map_loc_lid sub lid, path) | Texp_open (od, e) -> Texp_open (sub.open_declaration sub od, sub.expr sub e) | Texp_probe {name; handler; enabled_at_init;} -> @@ -720,10 +740,10 @@ let expr sub x = 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 tpt_txt = map_loc_lid sub x.tpt_txt in + let tpt_cstrs = List.map + (tuple2 (map_loc_lid sub) (sub.typ sub)) x.tpt_cstrs in + {x with tpt_txt; tpt_cstrs} let binding_op sub x = let bop_loc = sub.location sub x.bop_loc in @@ -796,8 +816,8 @@ let module_type sub x = 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_ident (path, lid) -> Tmty_ident (path, map_loc_lid sub lid) + | Tmty_alias (path, lid) -> Tmty_alias (path, map_loc_lid sub lid) | Tmty_signature sg -> Tmty_signature (sub.signature sub sg) | Tmty_functor (arg, mtype2, mmode2) -> Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2, @@ -805,12 +825,12 @@ let module_type sub x = | Tmty_with (mtype, list) -> Tmty_with ( sub.module_type sub mtype, - List.map (tuple3 id (map_loc sub) (sub.with_constraint sub)) list + List.map (tuple3 id (map_loc_lid sub) (sub.with_constraint sub)) list ) | Tmty_typeof mexpr -> Tmty_typeof (sub.module_expr sub mexpr) | Tmty_strengthen (mtype, p, lid) -> - Tmty_strengthen (sub.module_type sub mtype, p, lid) + Tmty_strengthen (sub.module_type sub mtype, p, map_loc_lid sub lid) in let mty_attributes = sub.attributes sub x.mty_attributes in {x with mty_loc; mty_desc; mty_env; mty_attributes} @@ -820,14 +840,14 @@ let with_constraint sub = function | 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) + | Twith_module (path, lid) -> Twith_module (path, map_loc_lid sub lid) + | Twith_modsubst (path, lid) -> Twith_modsubst (path, map_loc_lid sub lid) | Twith_jkind jd -> Twith_jkind (sub.jkind_declaration sub jd) | Twith_jkindsubst jd -> Twith_jkindsubst (sub.jkind_declaration sub jd) 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_expr = tuple2 id (map_loc_lid sub) od.open_expr; open_env = sub.env sub od.open_env; open_attributes = sub.attributes sub od.open_attributes} @@ -855,14 +875,28 @@ let module_coercion sub = function | Tcoerce_primitive pc -> Tcoerce_primitive {pc with pc_loc = sub.location sub pc.pc_loc; pc_env = sub.env sub pc.pc_env} + | Tcoerce_invalid -> Tcoerce_invalid 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_mode = + match x.mod_mode with + | _, None -> x.mod_mode + | mode, Some (locks, txt, loc) -> + let { txt; loc } = map_loc_lid sub { txt; loc } in + mode, Some (locks, txt, loc) + in let mod_desc = match x.mod_desc with +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc sub lid) | Tmod_typed_hole -> Tmod_typed_hole +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc sub lid) +======= + | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc_lid sub lid) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | Tmod_structure st -> Tmod_structure (sub.structure sub st) | Tmod_functor (arg, mexpr) -> Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr) @@ -892,7 +926,7 @@ let module_expr sub x = ) in let mod_attributes = sub.attributes sub x.mod_attributes in - {x with mod_loc; mod_desc; mod_env; mod_attributes} + {x with mod_loc; mod_desc; mod_mode; mod_env; mod_attributes} let module_binding sub x = let mb_loc = sub.location sub x.mb_loc in @@ -927,9 +961,8 @@ let class_expr sub x = | Tcl_apply (cl, args) -> Tcl_apply ( sub.class_expr sub cl, - List.map (function - | (lbl, Arg (exp, sort)) -> (lbl, Arg (sub.expr sub exp, sort)) - | (lbl, Omitted o) -> (lbl, Omitted o)) + List.map + (tuple2 id (Typedtree.map_apply_arg (tuple2 (sub.expr sub) id))) args ) | Tcl_let (rec_flag, value_bindings, ivars, cl) -> @@ -943,7 +976,7 @@ let class_expr sub x = sub.class_expr sub cl ) | Tcl_ident (path, lid, tyl) -> - Tcl_ident (path, map_loc sub lid, List.map (sub.typ sub) tyl) + Tcl_ident (path, map_loc_lid 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 @@ -959,7 +992,7 @@ let class_type sub x = | Tcty_constr (path, lid, list) -> Tcty_constr ( path, - map_loc sub lid, + map_loc_lid sub lid, List.map (sub.typ sub) list ) | Tcty_arrow (label, ct, cl) -> @@ -1014,13 +1047,13 @@ let typ sub x = Ttyp_unboxed_tuple (List.map (fun (label, t) -> label, sub.typ sub t) list) | Ttyp_constr (path, lid, list) -> - Ttyp_constr (path, map_loc sub lid, List.map (sub.typ sub) list) + Ttyp_constr (path, map_loc_lid 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, + map_loc_lid sub lid, List.map (sub.typ sub) list ) | Ttyp_alias (ct, s, jkind) -> @@ -1033,7 +1066,7 @@ let typ sub x = | 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) + Ttyp_open (path, map_loc_lid sub mod_ident, sub.typ sub t) | Ttyp_repr (vars, ct) -> Ttyp_repr (vars, sub.typ sub ct) | Ttyp_newlayout (vars, ct) -> Ttyp_newlayout (vars, sub.typ sub ct) | Ttyp_of_kind jkind -> @@ -1101,11 +1134,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 7b04a6eb4..a317b3f19 100644 --- a/src/ocaml/typing/typeclass.ml +++ b/src/ocaml/typing/typeclass.ml @@ -495,7 +495,7 @@ let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = val_attributes = attrs; val_zero_alloc = Zero_alloc.default; 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 ~mode:Mode.Value.legacy name desc met_env @@ -512,7 +512,7 @@ let add_self_met loc id sign self_var_kind vars cl_num val_attributes = attrs; val_zero_alloc = Zero_alloc.default; 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 ~mode:Mode.Value.legacy id desc met_env @@ -529,7 +529,7 @@ let add_instance_var_met loc label id sign cl_num attrs met_env = val_attributes = attrs; Types.val_loc = loc; val_zero_alloc = Zero_alloc.default; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) } in Env.add_value ~mode:Mode.Value.legacy id desc met_env @@ -688,10 +688,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 ~new_var_jkind:Any val_env ~closed:false Alloc.Const.legacy styp) - ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) in begin match @@ -737,8 +736,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 () -> Typecore.type_exp val_env sdefinition) in begin @@ -1106,7 +1104,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) @@ -1114,9 +1112,9 @@ and class_structure cl_num virt self_scope final val_env met_env loc in let met_env = List.fold_right - (fun {Typecore.pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> + (fun {Typecore.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=Typecore.As_var) pv_type pv_attributes met_env) self_pat_vars met_env in let fields = @@ -1208,13 +1206,15 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let scases = [ Exp.case (Pat.construct ~loc - (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) + (mknoloc (Longident.(Ldot (mknoloc (Lident "*predef*"), + mknoloc "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")))) + (mknoloc (Longident.(Ldot (mknoloc (Lident "*predef*"), + mknoloc "None")))) None) default; ] @@ -1227,7 +1227,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = in let param_name = "*opt*" ^ param_suffix in let smatch = - Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident param_name))) + Exp.match_ ~loc + (Exp.ident ~loc (mknoloc (Longident.Lident param_name))) scases in let sfun = @@ -1244,13 +1245,9 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = if Typecore.has_poly_constraint spat then raise(Error(spat.ppat_loc, val_env, Polymorphic_class_parameter)); 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 @@ -1282,7 +1279,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let partial = let dummy = Typecore.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 val_env' = val_env' @@ -1312,9 +1309,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 @@ -1468,8 +1464,9 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = |> Subst.Lazy.force_value_description in let ty = - Ctype.with_local_level ~post:Ctype.generalize + Ctype.with_local_level_generalize (fun () -> Ctype.instance vd.val_type) + ~before_generalize:Ctype.generalize in let expr = {exp_desc = @@ -1533,8 +1530,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 @@ -1657,8 +1656,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 = @@ -1749,8 +1748,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 *) @@ -1901,31 +1902,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) @@ -1934,8 +1924,11 @@ let final_decl env define_class | Some reason -> let printer = if define_class - then Format_doc.doc_printf "%a" (Printtyp.class_declaration id) clty - else Format_doc.doc_printf "%a" (Printtyp.cltype_declaration id) 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; @@ -2039,20 +2032,37 @@ 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 +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let res, newenv = Ctype.with_local_level_for_class begin fun () -> +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let res, env = + Ctype.with_local_level_for_class begin fun () -> +======= + let res, env = + Ctype.with_local_level_generalize_for_class begin fun () -> +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 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 + (* XCR rtjoa: there was no ~post here before - do we need to generalize? with + local level generalize for class differs from the normal one + + dkalinichenko: I'm not sure we do, but if we didn't before, let's not start? + + rtjoa: agreed, but will just leave this here until the testsuite passes + *) + ~before_generalize:ignore in let res = List.rev_map (final_decl newenv define_class) res in let decls = List.fold_right extract_type_decls res [] in @@ -2182,6 +2192,8 @@ let approx_class_declarations env sdecls = List.iter (check_recmod_decl env) sdecls; decls, env + + (*******************************) (* Error report *) @@ -2194,12 +2206,14 @@ 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_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 @@ -2208,20 +2222,20 @@ let report_error_doc env ppf = | 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 + 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 - Printtyp.report_unification_error ppf env err + 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 @@ -2242,7 +2256,7 @@ let report_error_doc 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 @@ -2251,15 +2265,15 @@ let report_error_doc 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@]" - out_type (Printtyp.tree_of_typexp Type abbrev) - out_type (Printtyp.tree_of_typexp Type actual) - 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) -> let msg = Format_doc.doc_printf in - Printtyp.report_unification_error ppf env err + Errortrace_report.unification ppf env err (msg "The expression %a has type" Style.inline_code ("new " ^ c) ) @@ -2290,11 +2304,11 @@ let report_error_doc env ppf = (Style.as_inline_code Printtyp.longident) lid expected provided | Parameter_mismatch err -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf env err + 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@]" @@ -2303,7 +2317,7 @@ let report_error_doc 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@ \ @@ -2323,27 +2337,35 @@ let report_error_doc 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; + 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 (Printtyp.tree_of_typexp Type meth_ty) - out_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>%a@]@ \ @[%a@]@]" pp_doc msg print_reason reason | Non_generalizable_class {id; clty; nongen_vars } -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let manual_ref = [ 6; 1; 2] in Printtyp.prepare_for_printing nongen_vars; +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in + Printtyp.prepare_for_printing nongen_vars; +======= + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in + Out_type.prepare_for_printing nongen_vars; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 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 @@ -2359,13 +2381,13 @@ let report_error_doc env 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 -> Errortrace_report.unification ppf env err (msg "Type") (msg "is not compatible with type") ) | Self_clash err -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf env err + Errortrace_report.unification ppf env err (msg "This object is expected to have type") (msg "but actually has type") | Mutability_mismatch (_lab, mut) -> diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index 75951c588..25599db20 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -22,10 +22,11 @@ open Misc open Asttypes open Parsetree open Types -open Mode +open Data_types open Typedtree open Btype open Ctype +open Mode (* Merlin-specific: change some module paths to match the compiler *) module Misc = struct @@ -113,10 +114,12 @@ type contains_gadt = let wrong_kind_sort_of_constructor (lid : Longident.t) = match lid with - | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> + | Lident "true" | Lident "false" + | Ldot(_, {txt="true"; _}) | Ldot(_, {txt="false"; _}) -> Boolean - | Lident "[]" | Lident "::" | Ldot(_, "[]") | Ldot(_, "::") -> List - | Lident "()" | Ldot(_, "()") -> Unit + | Lident "[]" | Lident "::" + | Ldot(_, {txt="[]"; _}) | Ldot(_, {txt="::"; _}) -> List + | Lident "()" | Ldot(_, {txt="()"; _}) -> Unit | _ -> Constructor type existential_restriction = @@ -128,6 +131,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 submode_reason = | Application of type_expr | Constructor of Longident.t @@ -155,10 +163,6 @@ type mode_mismatch_kind = Parameter | Return type error = | Constructor_arity_mismatch of Longident.t * int * int - | Constructor_labeled_arg - | Partial_tuple_pattern_bad_type - | Extra_tuple_label of string option * type_expr - | Missing_tuple_label of string option * type_expr | Label_mismatch of record_form_packed * Longident.t * Errortrace.unification_error | Pattern_type_clash : @@ -168,7 +172,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; @@ -241,19 +245,21 @@ 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 | Invalid_extension_constructor_payload | Not_an_extension_constructor + | Invalid_atomic_loc_payload + | Label_not_atomic of Longident.t + | Atomic_in_pattern of Longident.t | Probe_format | Probe_name_format of string | Probe_name_undefined of string | Probe_is_enabled_format | Extension_not_enabled : _ Language_extension.t -> error - | Atomic_in_pattern of Longident.t - | Invalid_atomic_loc_payload - | Label_not_atomic of Longident.t | Modalities_on_atomic_field of Longident.t | Literal_overflow of string | Unknown_literal of string * char @@ -270,11 +276,18 @@ 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 record_form_packed * type_expr + | Constructor_labeled_arg + | Partial_tuple_pattern_bad_type + | Extra_tuple_label of string option * type_expr + | Missing_tuple_label of string option * type_expr + | Repeated_tuple_exp_label of string + | Repeated_tuple_pat_label of string | Wrong_expected_record_boxing of wrong_kind_context * record_form_packed * type_expr - | Expr_not_a_record_type of record_form_packed * type_expr | Expr_record_type_has_wrong_boxing of record_form_packed * type_expr | Invalid_unboxed_access of { prev_el_type : type_expr; ua : Parsetree.unboxed_access } @@ -515,7 +528,7 @@ let check_probe_name name loc env = 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} let is_borrow e = match e.pexp_desc with @@ -1023,7 +1036,8 @@ let constant_integer i ~suffix : end | Some suffix -> Error (Unknown_constant_literal suffix) -let constant : Parsetree.constant -> (Typedtree.constant, error) result = +let constant_desc + : Parsetree.constant_desc -> (Typedtree.constant, error) result = function | Pconst_integer (i, suffix) -> begin match constant_integer i ~suffix with @@ -1084,6 +1098,8 @@ let constant : Parsetree.constant -> (Typedtree.constant, error) result = Error (Unknown_literal (Misc.format_as_unboxed_literal i, suffix)) end +let constant const = constant_desc const.pconst_desc + let constant_or_raise env loc cst = match constant cst with | Ok c -> @@ -1125,6 +1141,16 @@ let extract_option_type env ty = Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty | _ -> assert false +let is_floatarray_type env ty = + match get_desc (expand_head env ty) with + Tconstr(path, [], _) -> Path.same path Predef.path_floatarray + | _ -> false + +let is_iarray_type env ty = + match get_desc (expand_head env ty) with + | Tconstr(path, [_], _) -> Path.same path Predef.path_iarray + | _ -> false + let protect_expansion env ty = if Env.has_local_constraints env then generic_instance ty else ty @@ -1338,8 +1364,49 @@ let check_project_mutability ~loc ~env mut_name mutability mode = if Types.is_mutable mutability then submode ~loc ~env mode (mode_project_mutable mut_name) +(* Represents information about an array type inferred using type-directed + disambiguation. *) +type array_info = + { ty_elt : (type_expr * Jkind.sort) option; + mut : mutable_flag } + +let disambiguate_array_literal ~loc env expected_ty = + let return (ty_elt : (type_expr * Jkind.sort) option) (mut : mutable_flag) = + if not (is_principal expected_ty) then + Location.prerr_warning loc + (not_principal "this type-based array disambiguation"); + { ty_elt; mut } + in + if is_floatarray_type env expected_ty then + return (Some (instance Predef.type_float, Jkind.Sort.scannable)) Mutable + else if is_iarray_type env expected_ty then + return None Immutable + else + { ty_elt = None; mut = Mutable } + (* 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 (Jkind.Sort.(of_const Const.for_continuation)); + val_lpoly = Lpoly.determined []; + Types.val_loc = loc; val_attributes = []; + val_modalities = Modality.undefined; + val_zero_alloc = Zero_alloc.default; + 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 @@ -1352,10 +1419,42 @@ let unify_exp_types loc env ty expected_ty = | Tags(l1,l2) -> raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) +(* 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 + +(** [sexp] 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))) + (* helper notation for Pattern_env.t *) let (!!) (penv : Pattern_env.t) = penv.env (* Unification inside type_pat *) +(* If [penv] is available, calling this function requires + [penv.in_counterexample = false] *) let unify_pat_types loc env ty ty' = try unify env ty ty' with | Unify err -> @@ -1364,33 +1463,47 @@ let unify_pat_types loc env ty ty' = raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) (* GADT unification inside solve_Ppat_construct and check_counter_example_pat *) +(* We need to distinguish [pat] and [expected] if [refine = true] and + [penv.in_counterexample = false] (see [unify_gadt] for details) *) let nothing_equated = TypePairs.create 0 -let unify_pat_types_return_equated_pairs ~refine loc penv ty ty' = +let unify_pat_types_return_equated_pairs ~refine loc penv ~pat ~expected = try - if refine then unify_gadt penv ty ty' - else (unify !!penv ty ty'; nothing_equated) + if refine || penv.Pattern_env.in_counterexample + then unify_gadt penv ~pat ~expected + else (unify !!penv pat expected; 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') +(* Unify pattern types in functions that can be called either from + [type_pat] or [check_counter_example_pat]. + Since it calls normal unification when [penv.in_counterexample = false], + or [unify_gadt] when [penv.in_counterexample = true], + [ty] and [ty'] always have symmetric roles. *) +let unify_pat_types_penv loc penv ty ty' = + (* [penv.in_counterexample = true] only in calls originating + from [check_counter_example_pat], + which in turn may contain only non-leaking type variables *) + ignore (unify_pat_types_return_equated_pairs ~refine:false loc penv + ~pat:ty ~expected:ty') (** [sdesc_for_hint] is used by error messages to report literals in their original formatting *) +(* If [penv] is available, calling this function requires + [penv.in_counterexample = false] *) 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 unify_head_only loc penv constr ~expected:ty = + let path = cstr_res_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 + unify_pat_types_penv loc penv ty' ty (* Creating new conjunctive types is not allowed when typing patterns *) (* make all Reither present in open variants *) @@ -1435,17 +1548,22 @@ 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_uid: Uid.t; pv_mode: Value.l; - pv_kind : value_kind; + pv_value_kind : value_kind; pv_type: type_expr; pv_loc: Location.t; - pv_as_var: bool; + pv_kind: pattern_variable_kind; pv_attributes: attributes; pv_sort: Jkind_types.Sort.t; + pv_uid : Uid.t; pv_lpoly: Lpoly.t; } @@ -1495,7 +1613,21 @@ 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_mode = Value.disallow_right Value.legacy; + pv_value_kind = desc.val_kind; + pv_type = desc.val_type; + pv_loc = desc.val_loc; + pv_kind = Continuation_var; + pv_attributes = desc.val_attributes; + pv_sort = Jkind.Sort.(of_const Const.for_continuation); + pv_uid= desc.val_uid; + pv_lpoly = desc.val_lpoly}] + +let create_type_pat_state ?cont allow_modules = let tps_module_variables = match allow_modules with | Modules_allowed { scope } -> @@ -1503,7 +1635,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 = []; } @@ -1541,18 +1673,18 @@ let iter_pattern_variables_type f : pattern_variable list -> unit = List.iter (fun {pv_type; _} -> f pv_type) let iter_pattern_variables_type_mut ~f_immut ~f_mut pvs = - List.iter (fun {pv_type; pv_kind; pv_lpoly; _} -> - match pv_kind with + List.iter (fun {pv_type; pv_value_kind; pv_lpoly; _} -> + match pv_value_kind with | Val_mut _ -> f_mut pv_type | _ -> f_immut pv_lpoly pv_type) pvs let add_pattern_variables ?check ?check_as env pv = List.fold_right - (fun {pv_id; pv_mode; pv_kind; pv_type; pv_loc; pv_as_var; + (fun {pv_id; pv_mode; pv_value_kind; pv_type; pv_loc; pv_kind; pv_attributes; pv_uid; pv_lpoly} env -> - let check = if pv_as_var then check_as else check in + let check = if pv_kind=As_var then check_as else check in Env.add_value ?check ~mode:pv_mode pv_id - {val_type = pv_type; val_kind = pv_kind; val_lpoly = pv_lpoly; + {val_type = pv_type; val_kind = pv_value_kind; val_lpoly = pv_lpoly; Types.val_loc = pv_loc; val_attributes = pv_attributes; val_modalities = Modality.undefined; val_zero_alloc = Zero_alloc.default; @@ -1618,28 +1750,28 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name mode | 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_unit_name ()); - } :: module_variables - in - tps.tps_module_variables <- - Modvars_allowed { scope; module_variables; }; - id + 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_unit_name ()) in + let pv_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in tps.tps_pattern_variables <- {pv_id = id; pv_mode = mode; - pv_kind = kind; + pv_value_kind = kind; 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; pv_sort = sort; @@ -1712,7 +1844,7 @@ and build_as_type_and_mode_extra env p ~mode : _ -> _ * _ = 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); @@ -1833,7 +1965,8 @@ and build_as_type_aux (env : Env.t) p ~mode = (* Constraint solving during typing of patterns *) let solve_Ppat_alias ~mode env pat = - with_local_level ~post:(fun (ty_var, _) -> generalize ty_var) + with_local_level_generalize + ~before_generalize:(fun (ty_var, _) -> generalize ty_var) (fun () -> build_as_type_and_mode ~mode env pat) (* Extracts the first element from a list matching a label. Roughly: @@ -1866,9 +1999,6 @@ let extract_or_mk_pat label rem closed = If [closed] is [Open], then no "missing label" errors are possible; instead, [_] patterns will be generated for those labels. An unnecessarily [Open] pattern results in a warning. - - (Note: an alternative approach to creating [_] patterns could be to add a - [closed] flag to the typedtree) *) let reorder_pat loc penv patl closed labeled_tl expected_ty = let take_next (taken, rem) (label, _) = @@ -1889,7 +2019,7 @@ let reorder_pat loc penv patl closed labeled_tl expected_ty = (* This assumes the [args] have already been reordered according to the [expected_ty], if needed. *) -let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty = +let solve_Ppat_tuple ~alloc_mode loc env args expected_ty = (* CR layouts v5: consider sharing code with [solve_Ppat_unboxed_tuple] below when we allow non-values in boxed tuples. *) let arity = List.length args in @@ -1908,21 +2038,20 @@ let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty = let ann = (* CR layouts v5: restriction to value here to be relaxed. *) List.map2 - (fun (label, p) mode -> + (fun (label, _) mode -> ( label, - p, newgenvar (Jkind.Builtin.value_or_null ~why:Tuple_element), simple_pat_mode mode )) args arg_modes in - let ty = newgenty (Ttuple (List.map (fun (lbl, _, t, _) -> lbl, t) ann)) in + let ty = newgenty (Ttuple (List.map (fun (lbl, t, _) -> lbl, t) ann)) in let expected_ty = generic_instance expected_ty in - unify_pat_types_refine ~refine loc env ty expected_ty; + unify_pat_types_penv loc env ty expected_ty; ann (* This assumes the [args] have already been reordered according to the [expected_ty], if needed. *) -let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = +let solve_Ppat_unboxed_tuple ~alloc_mode loc env args expected_ty = let arity = List.length args in let arg_modes = match alloc_mode.tuple_modes with @@ -1938,13 +2067,12 @@ let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = in let ann = List.map2 - (fun (label, p) mode -> + (fun (label, _) mode -> let jkind, sort = Jkind.of_new_sort_var ~why:Jkind.History.Unboxed_tuple_element ~level:(Ctype.get_current_level ()) in ( label, - p, newgenvar jkind, simple_pat_mode mode, sort @@ -1952,15 +2080,18 @@ let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = args arg_modes in let ty = - newgenty (Tunboxed_tuple (List.map (fun (lbl, _, t, _, _) -> lbl, t) ann)) + newgenty (Tunboxed_tuple (List.map (fun (lbl, t, _, _) -> lbl, t) ann)) in let expected_ty = generic_instance expected_ty in - unify_pat_types_refine ~refine loc env ty expected_ty; + unify_pat_types_penv loc env ty expected_ty; ann 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 = + assert (not penv.in_counterexample); 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 existentials = List.map (fun (name, jkind_annot_opt) -> @@ -1971,19 +2102,25 @@ let solve_constructor_annotation ~default:(Jkind.Builtin.value ~why:Existential_type_variable) jkind_annot_opt in - let decl = new_local_type ~loc:name.loc Definition jkind in + let tv = newvar jkind in + let decl = + new_local_type ~loc:name.loc Definition jkind + ~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}, jkind_annot_opt) + {name with txt = id}, (decl, tv), jkind_annot_opt) 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 Alloc.Const.legacy 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 @@ -1995,56 +2132,102 @@ let solve_constructor_annotation unify_pat_types cty.ctyp_loc !!penv ty1 (newty (Ttuple (List.map (fun t -> None, t) ty_args))); match get_desc (expand_head !!penv ty2) with - Ttuple tyl -> (List.map snd tyl) + Ttuple tyl -> List.map snd tyl | _ -> assert false in - if existentials <> [] then ignore begin - let ids = List.map (fun (x, _) -> x.txt) existentials in + if existentials <> [] then begin + let ids_decls = List.map (fun (x,dm,_) -> (x.txt,dm)) existentials 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 +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 if rem <> [] then raise (error (cty.ctyp_loc, !!penv, Unbound_existential (ids, ty))) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + 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 (); +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 end; - ty_args, Some (existentials, cty) + ty_args, Some (List.map (fun (ty, _, jkind) -> ty, jkind) existentials, cty) -let solve_Ppat_construct ~refine tps penv loc constr no_existentials +let solve_Ppat_construct tps (penv : Pattern_env.t) 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; + unify_head_only loc penv constr ~expected:(instance expected_ty); (* 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 + let refine = constr.cstr_generalized && no_existentials = None in + (* Here [ty_res] contains only fresh (non-leaking) type variables, + so the requirement of [unify_gadt] is fulfilled. *) + unify_pat_types_return_equated_pairs ~refine loc penv ~pat:ty_res + ~expected:expected_ty 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_args_ty, ty_res, equated_types, existential_ctyp = + 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 - let ty_args_ty = - List.map (fun ca -> - ca.Types.ca_type) ty_args - in - ty_args, ty_args_ty, ty_res, unify_res ty_res expected_ty, None + ty_args, ty_res, unify_res ty_res expected_ty, None | Some (name_list, sty) -> let existential_treatment = if name_list = [] then @@ -2057,41 +2240,37 @@ 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 ty_args_ty = List.map (fun ca -> - ca.Types.ca_type) ty_args in + let equated_types = lazy (unify_res ty_res expected_ty) in + let ty_args_ty = List.map (fun ca -> ca.Types.ca_type) ty_args in let ty_args_ty, existential_ctyp = solve_constructor_annotation tps penv name_list sty ty_args_ty - ty_ex + ty_ex (fun () -> ignore (Lazy.force equated_types)) in let ty_args = List.map2 (fun arg ca_type -> {arg with Types.ca_type}) ty_args ty_args_ty in - ty_args, ty_args_ty, 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) + (ty_args, equated_types, existential_ctyp) end in - if !Clflags.principal && not refine then begin + if !Clflags.principal && not penv.in_counterexample then begin (* Do not warn for counter-examples *) let exception Warn_only_once in try TypePairs.iter (fun (t1, t2) -> - generalize_structure t1; - generalize_structure 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.type_expr t1 - Printtyp.type_expr t2 + "typing this pattern requires considering@ @[%a@]@ and@ \ + @[%a@]@ as@ equal.@ \ + But@ the@ knowledge@ of@ these@ types" + (Style.as_inline_code Printtyp.Doc.type_expr) t1 + (Style.as_inline_code Printtyp.Doc.type_expr) t2 in Location.prerr_warning loc (Warnings.Not_principal msg); raise Warn_only_once) @@ -2100,42 +2279,54 @@ let solve_Ppat_construct ~refine tps penv loc constr no_existentials end; (ty_args, existential_ctyp) -let solve_Ppat_record_field ~refine loc penv label label_lid record_ty +let solve_Ppat_record_field loc penv label label_lid record_ty record_form = - 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) + unify_pat_types_penv loc penv ty_res (instance record_ty) with Error(_loc, _env, Pattern_type_clash(err, _)) -> raise(error(label_lid.loc, !!penv, Label_mismatch(P record_form, label_lid.txt, err))) end; - (ty_arg, [ty_res; ty_arg]) + ty_arg end -let solve_Ppat_array ~refine loc env mutability expected_ty = - let type_some_array = - if Types.is_mutable mutability then Predef.type_array - else Predef.type_iarray - in - let jkind, arg_sort = - Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) - in - let ty_elt = newgenvar jkind in +let solve_Ppat_array loc env (mutability : mutable_flag) expected_ty + : _ * _ * mutable_flag = let expected_ty = generic_instance expected_ty in - unify_pat_types_refine ~refine - loc env (type_some_array ty_elt) expected_ty; - ty_elt, arg_sort + match mutability with + | Immutable -> + let jkind, arg_sort = + Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) + in + let ty_elt = newgenvar jkind in + unify_pat_types_penv loc env (Predef.type_iarray ty_elt) expected_ty; + ty_elt, arg_sort, Immutable + | Mutable -> + match disambiguate_array_literal ~loc !!env expected_ty with + | { ty_elt = Some (ty_elt, sort); mut } -> ty_elt, sort, mut + | { ty_elt = None; mut } -> + let array_type = match mut with + | Immutable -> Predef.type_iarray + | Mutable -> Predef.type_array + in + let jkind, arg_sort = + Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) + in + let ty_elt = newgenvar jkind in + unify_pat_types_penv loc env (array_type ty_elt) expected_ty; + ty_elt, arg_sort, mut -let solve_Ppat_lazy ~refine loc env expected_ty = +let solve_Ppat_lazy loc env expected_ty = let nv = newgenvar (Jkind.Builtin.value ~why:Lazy_expression) in - unify_pat_types_refine ~refine loc env (Predef.type_lazy_t nv) + unify_pat_types_penv loc env (Predef.type_lazy_t nv) (generic_instance expected_ty); nv let solve_Ppat_constraint tps loc env mode 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 mode sty) in tps.tps_pattern_force <- force :: tps.tps_pattern_force; @@ -2149,7 +2340,7 @@ let solve_Ppat_constraint tps loc env mode sty expected_ty = in (cty, ty, expected_ty') -let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = +let solve_Ppat_variant loc env tag no_arg expected_ty = (* CR layouts v5: relax the restriction to value here. *) let arg_type = if no_arg @@ -2165,7 +2356,7 @@ let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = (* 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; + unify_pat_types_penv loc env (newgenty(Tvariant row)) expected_ty; (arg_type, make_row (newvar (Jkind.Builtin.value ~why:Row_variable)), instance expected_ty) @@ -2248,7 +2439,8 @@ let build_or_pat env loc lid = let type_for_loop_like_index ~error:err ~loc ~env ~param ~any ~var = match param.ppat_desc with | Ppat_any -> - any (Ident.create_local "_for", Uid.mk ~current_unit:(Env.get_unit_name ())) + any (Ident.create_local "_for", + Uid.mk ~current_unit:(Env.get_current_unit ())) | Ppat_var name -> var ~name ~pv_mode:Value.(min |> disallow_right) @@ -2277,11 +2469,13 @@ let type_for_loop_index ~loc ~env ~param = -> let check s = Warnings.Unused_for_index s in let pv_id = Ident.create_local 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 let pv = { pv_id; pv_uid; pv_mode; - pv_kind = Val_reg Jkind.Sort.(of_const Const.for_loop_index); - pv_type; pv_loc; pv_as_var; + pv_value_kind = + Val_reg Jkind.Sort.(of_const Const.for_loop_index); + pv_type; pv_loc; + pv_kind = if pv_as_var then As_var else Std_var; pv_attributes; pv_sort = Jkind.Sort.(of_const Const.for_loop_index); pv_lpoly = Lpoly.determined []; @@ -2419,7 +2613,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 @@ -2434,10 +2628,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_doc.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], @@ -2455,7 +2651,8 @@ end) = struct if Warnings.is_active (Name_out_of_scope ("", Name "")) then begin let path_s = Printtyp.wrap_printing_env ~error:true env - (fun () -> Format_doc.asprintf "%a" Printtyp.type_path tpath) in + (fun () -> Format_doc.asprintf "%a" Printtyp.Doc.type_path tpath) + in warn lid.loc (Warnings.Name_out_of_scope (path_s, Name (Longident.last lid.txt))) end @@ -2738,7 +2935,8 @@ let disambiguate_sort_lid_a_list let qual_lid = match qual, lid.txt with | Some modname, Longident.Lident s -> - {lid with txt = Longident.Ldot (modname, s)} + let name = { lid with txt = s } in + {lid with txt = Longident.Ldot (modname, name)} | _ -> lid in lid, process_label qual_lid, a @@ -2914,19 +3112,18 @@ let rec has_literal_pattern p = | Ppat_lazy p | Ppat_open (_, p) -> has_literal_pattern p - | Ppat_tuple (ps, _) -> has_literal_pattern_labeled_tuple ps | Ppat_array (_, ps) -> List.exists has_literal_pattern ps - | Ppat_unboxed_tuple (ps, _) -> has_literal_pattern_labeled_tuple ps + | Ppat_tuple (ps, _) + | Ppat_unboxed_tuple (ps, _) -> + List.exists (fun (_,p) -> has_literal_pattern p) ps | Ppat_record (ps, _) | Ppat_record_unboxed_product (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 -and has_literal_pattern_labeled_tuple labeled_ps = - List.exists (fun (_, p) -> has_literal_pattern p) labeled_ps - let check_scope_escape loc env level ty = try Ctype.check_scope_escape env level ty with Escape esc -> @@ -2986,9 +3183,6 @@ let as_comp_pattern | Value -> as_computation_pattern pat | Computation -> pat -let components_have_label (labeled_components : (string option * 'a) list) = - List.exists (function Some _, _ -> true | _ -> false) labeled_components - let forbid_atomic_field_patterns loc penv (label_lid, label, pat) = (* Pattern-matching under atomic record fields is not allowed. We still allow wildcard patterns, so that it is valid to list all @@ -3042,10 +3236,11 @@ let rec type_pat and type_pat_aux : type k . type_pat_state -> k pattern_category -> no_existentials:_ -> - alloc_mode:expected_pat_mode -> mutable_flag:mutable_flag -> penv:_ -> - _ -> _ -> _ -> k general_pattern + alloc_mode:expected_pat_mode -> mutable_flag:mutable_flag -> + penv:Pattern_env.t -> _ -> _ -> _ -> k general_pattern = fun tps category ~no_existentials ~alloc_mode ~mutable_flag ~penv sp expected_ty sort -> + assert (penv.in_counterexample = false); let type_pat tps category ?(alloc_mode=alloc_mode) ?(penv=penv) = type_pat tps category ~no_existentials ~alloc_mode ~mutable_flag ~penv in @@ -3063,46 +3258,17 @@ and type_pat_aux let rp = crp and rvp x = crp (pure category x) and rcp x = crp (only_impure category x) in - let type_pat_array mutability spl pat_attributes = - (* Sharing the code between the two array cases means we're guaranteed to - keep them in sync, at the cost of a worse diff with upstream; it - shouldn't be too bad. We can inline this when we upstream this code and - combine the two array pattern constructors. *) - let ty_elt, arg_sort = - solve_Ppat_array ~refine:false loc penv mutability expected_ty - in - let modalities = Typemode.mutable_modalities mutability in - check_project_mutability ~loc ~env:!!penv Array_elements mutability - alloc_mode.mode; - let is_contained_by : Mode.Hint.is_contained_by = - {containing = Array Modality; container = (loc, Pattern)} - in - let alloc_mode = - apply_is_contained_by is_contained_by ~modalities alloc_mode.mode - in - let alloc_mode = simple_pat_mode alloc_mode in - let pl = - List.map (fun p -> type_pat ~alloc_mode tps Value p ty_elt arg_sort) spl - in - rvp { - pat_desc = Tpat_array (mutability, arg_sort, pl); - pat_loc = loc; pat_extra=[]; - pat_type = instance expected_ty; - pat_attributes; - pat_env = !!penv; - pat_unique_barrier = Unique_barrier.not_computed () } - in let type_tuple_pat spl closed = (* CR layouts v5: consider sharing code with [type_unboxed_tuple_pat] below when we allow non-values in boxed tuples. *) + assert (closed = Open || List.length spl >= 2); + Option.iter + (fun l -> raise (Error (loc, !!penv, Repeated_tuple_pat_label l))) + (Misc.repeated_label spl); let args = match get_desc (expand_head !!penv expected_ty) with (* If it's a principally-known tuple pattern, try to reorder *) | Ttuple labeled_tl when is_principal expected_ty -> - begin match closed with - | Open -> Language_extension.assert_enabled ~loc Labeled_tuples () - | Closed -> () - end; reorder_pat loc penv spl closed labeled_tl expected_ty (* If not, it's not allowed to be open (partial) *) | _ -> @@ -3110,18 +3276,15 @@ and type_pat_aux | Open -> raise (error (loc, !!penv, Partial_tuple_pattern_bad_type)) | Closed -> spl in - let spl_ann = - solve_Ppat_tuple ~refine:false ~alloc_mode loc penv args expected_ty + let expected_tys = + solve_Ppat_tuple ~alloc_mode loc penv args expected_ty in let pl = - List.map (fun (lbl, p, t, alloc_mode) -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - lbl; + List.map2 (fun (lbl, t, alloc_mode) (_, p) -> lbl, type_pat tps Value ~alloc_mode p t Jkind.Sort.(of_const Const.for_tuple_element)) - spl_ann + expected_tys args in rvp { pat_desc = Tpat_tuple pl; @@ -3134,14 +3297,14 @@ and type_pat_aux let type_unboxed_tuple_pat spl closed = Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; + assert (closed = Open || List.length spl >= 2); + Option.iter + (fun l -> raise (Error (loc, !!penv, Repeated_tuple_pat_label l))) + (Misc.repeated_label spl); let args = match get_desc (expand_head !!penv expected_ty) with (* If it's a principally-known tuple pattern, try to reorder *) | Tunboxed_tuple labeled_tl when is_principal expected_ty -> - begin match closed with - | Open -> Language_extension.assert_enabled ~loc Labeled_tuples () - | Closed -> () - end; reorder_pat loc penv spl closed labeled_tl expected_ty (* If not, it's not allowed to be open (partial) *) | _ -> @@ -3149,17 +3312,13 @@ and type_pat_aux | Open -> raise (error (loc, !!penv, Partial_tuple_pattern_bad_type)) | Closed -> spl in - let spl_ann = - solve_Ppat_unboxed_tuple ~refine:false ~alloc_mode loc penv args - expected_ty + let expected_tys = + solve_Ppat_unboxed_tuple ~alloc_mode loc penv args expected_ty in let pl = - List.map (fun (lbl, p, t, alloc_mode, sort) -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - lbl; + List.map2 (fun (lbl, t, alloc_mode, sort) (_, p) -> lbl, type_pat tps Value ~alloc_mode p t sort, sort) - spl_ann + expected_tys args in let ty = newty (Tunboxed_tuple (List.map (fun (lbl, p, _) -> lbl, p.pat_type) pl)) @@ -3195,7 +3354,7 @@ and type_pat_aux in let type_label_pat (label_lid, label, sarg) = let ty_arg = - solve_Ppat_record_field ~refine:false loc penv label label_lid + solve_Ppat_record_field loc penv label label_lid record_ty record_form in check_project_mutability ~loc ~env:!!penv (Record_field label.lbl_name) label.lbl_mut alloc_mode.mode; @@ -3361,14 +3520,14 @@ and type_pat_aux pat_env = !!penv; pat_unique_barrier = Unique_barrier.not_computed () } | Ppat_interval (l, r) -> + let open Ast_helper in let expand_interval lo hi ~make = - let open Ast_helper.Pat in - let gloc = Location.ghostify loc in + let gloc = {loc with Location.loc_ghost=true} in let rec loop lo hi = - if lo = hi then constant ~loc:gloc (make lo) + if lo = hi then Pat.constant ~loc:gloc (make gloc lo) else - or_ ~loc:gloc - (constant ~loc:gloc (make lo)) + Pat.or_ ~loc:gloc + (Pat.constant ~loc:gloc (make gloc lo)) (loop (lo + 1) hi) in let p = if lo <= hi then loop lo hi else loop hi lo in @@ -3382,10 +3541,10 @@ and type_pat_aux with | Const_char c1, Const_char c2 -> expand_interval (Char.code c1) (Char.code c2) - ~make:(fun i -> Pconst_char (Char.chr i)) + ~make:(fun loc i -> Const.char ~loc (Char.chr i)) | Const_untagged_char c1, Const_untagged_char c2 -> expand_interval (Char.code c1) (Char.code c2) - ~make:(fun i -> Pconst_untagged_char (Char.chr i)) + ~make:(fun loc i -> Const.untagged_char ~loc (Char.chr i)) | _ -> raise (error (loc, !!penv, Invalid_interval)) end @@ -3432,25 +3591,38 @@ and type_pat_aux let sargs = match sarg' with None -> [] - | Some sarg' -> - match sarg' with - | {ppat_desc = Ppat_tuple (spl, _)} as sp when + | Some {ppat_desc = Ppat_tuple (spl, _)} when constr.cstr_arity > 1 || Builtin_attributes.explicit_arity sp.ppat_attributes -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 if components_have_label spl then raise (error(loc, !!penv, Constructor_labeled_arg)) else List.map snd spl | {ppat_desc = Ppat_any} as sp when +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + if components_have_label spl then + raise (Error(loc, !!penv, Constructor_labeled_arg)) + else + List.map snd spl + | {ppat_desc = Ppat_any} as sp when +======= + List.map (fun (l, sp) -> + match l with + | Some _ -> raise (Error(loc, !!penv, Constructor_labeled_arg)) + | None -> sp + ) spl + | Some({ppat_desc = Ppat_any} as sp) when +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 constr.cstr_arity = 0 && existential_styp = None -> Location.prerr_warning sp.ppat_loc Warnings.Wildcard_arg_to_constant_constr; [] - | {ppat_desc = Ppat_any} as sp when constr.cstr_arity > 1 -> + | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 -> replicate_list sp constr.cstr_arity - | sp -> [sp] in + | 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 :: _ -> @@ -3462,7 +3634,7 @@ and type_pat_aux constr.cstr_arity, List.length sargs))); let (args, existential_ctyp) = - solve_Ppat_construct ~refine:false tps penv loc constr no_existentials + solve_Ppat_construct tps penv loc constr no_existentials existential_styp expected_ty in @@ -3521,7 +3693,7 @@ and type_pat_aux 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 + solve_Ppat_variant loc penv tag constant expected_ty in let arg = (* PR#6235: propagate type information *) match sarg, arg_type with @@ -3544,24 +3716,53 @@ and type_pat_aux Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; type_record_pat Unboxed_product lid_sp_list closed | Ppat_array (mut, spl) -> - let mut = - match mut with + (match mut with + | Asttypes.Mutable -> () + | Asttypes.Immutable -> + Language_extension.assert_enabled ~loc Immutable_arrays ()); + let ty_elt, arg_sort, mutability = + solve_Ppat_array loc penv mut expected_ty + in + let mutability = + match mutability with | Mutable -> Mutable { mode = Value.Comonadic.legacy; (* CR aspsmith: Revisit once we support atomic arrays *) atomic = Nonatomic } - | Immutable -> - Language_extension.assert_enabled ~loc Immutable_arrays (); - Immutable + | Immutable -> Immutable + in + let modalities = Typemode.mutable_modalities mutability in + check_project_mutability ~loc ~env:!!penv Array_elements mutability + alloc_mode.mode; + let is_contained_by : Mode.Hint.is_contained_by = + {containing = Array Modality; container = (loc, Pattern)} + in + let alloc_mode = + apply_is_contained_by is_contained_by ~modalities alloc_mode.mode + in + let alloc_mode = simple_pat_mode alloc_mode in + let pl = + List.map + (fun p -> type_pat ~alloc_mode tps Value p ty_elt arg_sort) spl in - type_pat_array mut spl sp.ppat_attributes + rvp { + pat_desc = Tpat_array (mutability, arg_sort, pl); + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv; + pat_unique_barrier = Unique_barrier.not_computed () } | 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 + ~before_generalize:(fun (_, tys) -> List.iter generalize tys) + begin fun () -> (* Introduce a new scope using with_local_level without generalizations *) let env1, p1, env2, p2 = with_local_level begin fun () -> @@ -3605,7 +3806,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), [p1.pat_type; p2.pat_type] + end + in + rp { pat_desc = pat_desc; pat_loc = loc; pat_extra = []; pat_type = instance expected_ty; pat_attributes = sp.ppat_attributes; @@ -3613,7 +3817,7 @@ and type_pat_aux pat_unique_barrier = Unique_barrier.not_computed () } | Ppat_lazy sp1 -> submode ~loc ~env:!!penv alloc_mode.mode mode_force_lazy; - let nv = solve_Ppat_lazy ~refine:false loc penv expected_ty in + let nv = solve_Ppat_lazy loc penv expected_ty in let alloc_mode = global_pat_mode alloc_mode in let p1 = type_pat ~alloc_mode tps Value sp1 nv @@ -3682,6 +3886,8 @@ and type_pat_aux pat_attributes = sp.ppat_attributes; pat_unique_barrier = Unique_barrier.not_computed (); } + | Ppat_effect _ -> + raise (Error (loc, !!penv, Effect_pattern_below_toplevel)) | Ppat_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -3689,11 +3895,11 @@ let type_pat tps category ?no_existentials ~mutable_flag penv = type_pat tps category ~no_existentials ~mutable_flag ~penv let type_pattern - category ~lev ~alloc_mode env spat expected_ty sort allow_modules + category ~lev ~alloc_mode env spat expected_ty ?cont sort allow_modules = - let tps = create_type_pat_state allow_modules in + 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 + ~equations_scope:lev ~in_counterexample:false in let pat = type_pat tps category ~alloc_mode ~mutable_flag:Immutable new_penv spat expected_ty sort @@ -3711,7 +3917,7 @@ let type_pattern_list let tps = create_type_pat_state allow_modules in let equations_scope = get_current_level () in let new_penv = Pattern_env.make env - ~is_lpoly ~equations_scope ~allow_recursive_equations:false in + ~is_lpoly ~equations_scope ~in_counterexample:false in let type_pat (attrs, pat_mode, exp_mode, pat) ty sort = Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> @@ -3730,13 +3936,13 @@ let type_pattern_list let type_class_arg_pattern cl_num val_env met_env l spat = let pvs, pat = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let tps = create_type_pat_state Modules_rejected in let nv = newvar (Jkind.Builtin.value ~why:Class_term_argument) in let alloc_mode = simple_pat_mode Value.legacy in let equations_scope = get_current_level () in let new_penv = Pattern_env.make val_env - ~equations_scope ~allow_recursive_equations:false in + ~equations_scope ~in_counterexample:false in let pat = type_pat tps Value ~no_existentials:In_class_args ~alloc_mode ~mutable_flag:Immutable new_penv spat nv @@ -3753,15 +3959,13 @@ let type_class_arg_pattern cl_num val_env met_env l spat = (type_option (newvar Predef.option_argument_jkind)); tps.tps_pattern_variables, pat end - ~post:(fun (pvs, _) -> iter_pattern_variables_type generalize_structure - pvs) in let (pv, val_env, met_env) = List.fold_right - (fun {pv_id; pv_uid; pv_type; pv_loc; pv_as_var; pv_attributes; pv_sort} + (fun {pv_id; pv_uid; pv_type; pv_loc; pv_kind; pv_attributes; pv_sort} (pv, val_env, met_env) -> let check s = - if pv_as_var then Warnings.Unused_var { name = s; mutated = false } + if pv_kind = As_var then Warnings.Unused_var { name = s; mutated = false } else Warnings.Unused_var_strict { name = s; mutated = false } in let id' = Ident.rename pv_id in let val_env = @@ -3803,7 +4007,7 @@ let type_self_pattern env spat = let alloc_mode = simple_pat_mode Value.legacy in let equations_scope = get_current_level () in let new_penv = Pattern_env.make env - ~equations_scope ~allow_recursive_equations:false in + ~equations_scope ~in_counterexample:false in let pat = type_pat tps Value ~no_existentials:In_self_pattern ~alloc_mode ~mutable_flag:Immutable new_penv spat nv @@ -3839,7 +4043,8 @@ let rec pat_tuple_arity spat = | Ppat_constant _ | Ppat_unboxed_unit | Ppat_unboxed_bool _ | Ppat_interval _ | Ppat_construct _ | Ppat_variant _ | Ppat_record _ | Ppat_record_unboxed_product _ | Ppat_array _ | Ppat_type _ - | Ppat_lazy _ | Ppat_unpack _ | Ppat_extension _ -> Not_local_tuple + | Ppat_lazy _ | Ppat_unpack _ | Ppat_extension _ | Ppat_effect _ -> + Not_local_tuple | Ppat_or(sp1, sp2) -> combine_pat_tuple_arity (pat_tuple_arity sp1) (pat_tuple_arity sp2) | Ppat_constraint(p, _, _) | Ppat_open(_, p) | Ppat_alias(p, _) -> pat_tuple_arity p @@ -4012,13 +4217,13 @@ let enter_nonsplit_or info = let rec check_counter_example_pat ~info ~(penv : Pattern_env.t) type_pat_state tp expected_ty k = + assert (penv.in_counterexample = true); 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 alloc_mode = simple_pat_mode Value.min in let solve_expected (x : pattern) : pattern = - unify_pat_types_refine ~refine x.pat_loc penv x.pat_type + unify_pat_types_penv x.pat_loc penv x.pat_type (instance expected_ty); x in @@ -4039,7 +4244,7 @@ let rec check_counter_example_pat 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 + solve_Ppat_record_field loc penv label label_lid record_ty record_form in check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) in @@ -4084,41 +4289,43 @@ let rec check_counter_example_pat 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 -> - let tpl_ann = - solve_Ppat_tuple ~refine ~alloc_mode loc penv tpl - expected_ty + let expected_tys = + solve_Ppat_tuple ~alloc_mode loc penv tpl expected_ty in - map_fold_cont (fun (l,p,t,_) k -> check_rec p t (fun p -> k (l, p))) + let tpl_ann = List.combine tpl expected_tys in + map_fold_cont (fun ((l,p),(_,t,_)) k -> check_rec p t (fun p -> k (l, p))) tpl_ann (fun pl -> - mkp k (Tpat_tuple pl) - ~pat_type:(newty (Ttuple (List.map (fun (l,p) -> (l,p.pat_type)) - pl)))) + let pat_type = + newty (Ttuple (List.map (fun (l,p) -> (l,p.pat_type)) pl)) + in + mkp k (Tpat_tuple pl) ~pat_type) | Tpat_unboxed_tuple tpl -> - let tpl_ann = - solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc penv - (List.map (fun (l,t,_) -> l, t) tpl) - expected_ty + let expected_tys = + solve_Ppat_unboxed_tuple ~alloc_mode loc penv + (List.map (fun (l,t,_) -> l, t) tpl) expected_ty in List.iter2 - (fun (_, _, orig_sort) (_, _, _, _, sort) -> + (fun (_, _, orig_sort) (_, _, _, sort) -> (* Sanity check *) assert (Jkind.Sort.equate orig_sort sort)) - tpl tpl_ann; + tpl expected_tys; + let tpl_ann = List.combine tpl expected_tys in map_fold_cont - (fun (l,p,t,_,sort) k -> check_rec p t (fun p -> k (l, p, sort))) + (fun ((l,p,_),(_,t,_,sort)) k -> check_rec p t (fun p -> k (l, p, sort))) tpl_ann (fun pl -> - mkp k (Tpat_unboxed_tuple pl) - ~pat_type:(newty (Tunboxed_tuple - (List.map (fun (l,p,_) -> (l,p.pat_type)) - pl)))) + let pat_type = + newty (Tunboxed_tuple + (List.map (fun (l,p,_) -> (l,p.pat_type)) pl)) + in + mkp k (Tpat_unboxed_tuple pl) ~pat_type) | 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 + solve_Ppat_construct + type_pat_state penv loc constr None None expected_ty in map_fold_cont (fun (p,t) -> check_rec p t.Types.ca_type) @@ -4128,7 +4335,7 @@ let rec check_counter_example_pat | 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 + solve_Ppat_variant loc penv tag constant expected_ty in let k arg = mkp k ~pat_type (Tpat_variant(tag, arg, ref row)) in begin @@ -4140,11 +4347,18 @@ let rec check_counter_example_pat | Tpat_record(fields, closed) -> type_label_pats fields closed Legacy | Tpat_record_unboxed_product(fields, closed) -> type_label_pats fields closed Unboxed_product - | Tpat_array (mut, original_arg_sort, tpl) -> - let ty_elt, arg_sort = solve_Ppat_array ~refine loc penv mut expected_ty in + | Tpat_array (mutability, original_arg_sort, tpl) -> + let mut : mutable_flag = + match mutability with + | Mutable _ -> Mutable + | Immutable -> Immutable + in + let ty_elt, arg_sort, _ = + solve_Ppat_array loc penv mut expected_ty + in assert (Jkind.Sort.equate original_arg_sort arg_sort); map_fold_cont (fun p -> check_rec p ty_elt) tpl - (fun pl -> mkp k (Tpat_array (mut, arg_sort, pl))) + (fun pl -> mkp k (Tpat_array (mutability, arg_sort, pl))) | Tpat_or(tp1, tp2, _) -> (* We are in counter-example mode, but try to avoid backtracking *) let must_split = @@ -4186,7 +4400,7 @@ let rec check_counter_example_pat mkp k (Tpat_or (p1, p2, None)) end | Tpat_lazy tp1 -> - let nv = solve_Ppat_lazy ~refine loc penv expected_ty in + let nv = solve_Ppat_lazy 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)) @@ -4196,14 +4410,16 @@ let check_counter_example_pat ~counter_example_args penv tp expected_ty = 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) + wrap_trace_gadt_instances ~force:true !!penv + (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 + ~equations_scope:lev ~in_counterexample:true in let state = save_state penv in let counter_example_args = { @@ -4268,9 +4484,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) @@ -4290,15 +4506,21 @@ let rec list_labels_aux env visited ls ty_fun = 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 + | 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 = - 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 + -(* Collecting arguments for function applications *) +(* Collecting arguments for function applications. *) (* See also Note [Type-checking applications] *) type untyped_apply_arg = @@ -4311,12 +4533,30 @@ type untyped_apply_arg = mode_fun : Alloc.lr; mode_arg : Alloc.lr; wrapped_in_some : bool; } + (* [arg] is a [Known_arg] in: + - [f arg] when is known to be a function (f : _ -> _) + - [f ~lab:arg] when (f : lab:_ -> _) + - [f ?lab:arg] when (f : ?lab:_ -> _) + In these cases we have [wrapped_in_some = false]. + + - [f ~lab:arg] when (f : ?lab:_ -> _) + In this case [wrapped_in_some = true]. + + [ty_arg] is the (possibly generic) expected type of the argument, + and [ty_arg0] is an instance of [ty_arg]. *) | Unknown_arg of { sarg : Parsetree.expression; ty_arg_mono : type_expr; sort_arg : Jkind.sort; mode_fun : Alloc.lr; mode_arg : Alloc.lr} + (* [arg] is an [Unknown_arg] in: + [f arg] when [f] is not known (either a type variable, + or the [commu_ok] case where a function type is known + but not principally). + + [ty_arg_mono] is the expected type of the argument, usually just + a fresh type variable. *) | Eliminated_optional_arg of { expected_label: arg_label; mode_fun: Alloc.lr; @@ -4324,6 +4564,11 @@ type untyped_apply_arg = sort_arg : Jkind.sort; mode_arg : Alloc.lr; level: int; } + (* When [f : ?foo:ty -> _ -> _], [~foo] is an [Eliminated_optional_arg] + in [f x] ([foo] is an optional argument that was not passed, but a + following positional argument was passed). + + [level] is the level of the function arrow. *) type untyped_omitted_param = { mode_fun: Alloc.lr; @@ -4340,30 +4585,6 @@ let is_partial_apply args = | Arg _ -> false) args -let remaining_function_type ty_ret mode_ret rev_args = - let ty_ret, _, _ = - List.fold_left - (fun (ty_ret, mode_ret, closed_args) (lbl, arg) -> - match arg with - | Arg (Unknown_arg { mode_arg; _ } | Known_arg { mode_arg; _ }) -> - let closed_args = mode_arg :: closed_args in - (ty_ret, mode_ret, closed_args) - | Arg (Eliminated_optional_arg - { mode_fun; ty_arg; mode_arg; level; _ }) - | Omitted { mode_fun; ty_arg; mode_arg; level } -> - let arrow_desc = lbl, mode_arg, mode_ret in - let ty_ret = - newty2 ~level - (Tarrow (arrow_desc, ty_arg, ty_ret, commu_ok)) - in - let mode_ret, _ = - Alloc.newvar_above (Alloc.join (mode_fun :: closed_args)) - in - (ty_ret, mode_ret, closed_args)) - (ty_ret, mode_ret, []) rev_args - in - ty_ret - (** Within a single application, constrain the curried arrow type as given by [close_over] and [partial_apply]. This constraint is not required for soundness, but useful in the lack of a signature, in which case the @@ -4478,10 +4699,49 @@ let check_curried_application_complete ~env ~app_loc args = seems to be easy to make this not quadratic, though.) *) +let remaining_function_type_for_error ty_ret mode_ret rev_args = + let ty_ret, _, _ = + List.fold_left + (fun (ty_ret, mode_ret, closed_args) (lbl, arg) -> + match arg with + | Arg (Unknown_arg { mode_arg; _ } | Known_arg { mode_arg; _ }) -> + let closed_args = mode_arg :: closed_args in + (ty_ret, mode_ret, closed_args) + | Arg (Eliminated_optional_arg + { mode_fun; ty_arg; mode_arg; level; _ }) + | Omitted { mode_fun; ty_arg; mode_arg; level } -> + let arrow_desc = lbl, mode_arg, mode_ret in + let ty_ret = + newty2 ~level + (Tarrow (arrow_desc, ty_arg, ty_ret, commu_ok)) + in + let mode_ret, _ = + Alloc.newvar_above (Alloc.join (mode_fun :: closed_args)) + in + (ty_ret, mode_ret, closed_args)) + (ty_ret, mode_ret, []) rev_args + in + ty_ret + +let get_arg_loc = function + | (_, Arg ( Known_arg { sarg; _ } + | Unknown_arg { sarg; _ })) -> Some sarg.pexp_loc + | (_, Arg (Eliminated_optional_arg _)) + | (_, Omitted _) -> None + +let previous_arg_loc rev_args ~funct = + (* [rev_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). *) + rev_args + |> List.find_map get_arg_loc + |> Option.value ~default:funct.exp_loc + (* This function processes any arguments remaining after traversing the type of the function; these would be over-saturated arguments or arguments to a function whose type is not known. *) -let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar = +let collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs + ret_tvar = let labels_match ~param ~arg = param = arg || !Clflags.classic && arg = Nolabel && not (is_omittable param) @@ -4490,12 +4750,6 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar let ls, tvar = list_labels env ty_fun in tvar || List.mem l ls in - let get_arg_loc = function - | (_, Arg ( Known_arg { sarg; _ } - | Unknown_arg { sarg; _ })) -> Some sarg.pexp_loc - | (_, Arg (Eliminated_optional_arg _)) - | (_, Omitted _) -> None - in let rec loop ty_fun mode_fun rev_args sargs = match sargs with | [] -> ty_fun, mode_fun, List.rev rev_args @@ -4552,7 +4806,9 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar (sort_arg, mode_arg, tpoly_get_mono ty_arg, mode_ret, ty_res) | td -> let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in - let ty_res = remaining_function_type ty_fun mode_fun rev_args in + let ty_res = + remaining_function_type_for_error ty_fun mode_fun rev_args + in match get_desc ty_res with | Tarrow _ -> if !Clflags.classic || not (has_label lbl ty_fun) then @@ -4563,6 +4819,7 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar Msupport.resume_raise (error(funct.exp_loc, env, Incoherent_label_order)) | _ -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let previous_arg_loc = (* [rev_args] is the arguments typed until now, in reverse order of appearance. Not all arguments have a location @@ -4579,10 +4836,29 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar in Msupport.resume_raise (error(funct.exp_loc, env, Apply_non_function { +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let previous_arg_loc = + (* [rev_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). *) + (* CR ccasinghino: the above comment is confusing - these + arguments are in reverse order according to the function + type, but not according to their positions in the source + program. We diverge from upstream here by not trying to + provide a good location in the [Eliminated_optional_arg] + case - maybe fix one day if it is noticeable. *) + rev_args + |> List.find_map get_arg_loc + |> Option.value ~default:funct.exp_loc + in + raise(Error(funct.exp_loc, env, Apply_non_function { +======= + raise(Error(funct.exp_loc, env, Apply_non_function { +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 funct; func_ty = expand_head env funct.exp_type; res_ty = expand_head env ty_res; - previous_arg_loc; + previous_arg_loc = previous_arg_loc rev_args ~funct; extra_arg_loc = sarg.pexp_loc; })) with Msupport.Resume -> let ty_arg, kind_arg = new_rep_var ~why:Function_argument () in @@ -4592,26 +4868,48 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar let arg = Unknown_arg { sarg; ty_arg_mono; mode_fun; mode_arg; sort_arg } in loop ty_res mode_ret ((lbl, Arg arg) :: rev_args) rest in - loop ty_fun mode_fun rev_args sargs + loop ty_fun0 mode_fun rev_args sargs (* See Note [Type-checking applications] for an overview *) -let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret_tvar = +let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs + ret_tvar = let warned = ref false in let rec loop ty_fun ty_fun0 mode_fun rev_args sargs = - let type_unknown_args () = - (* We're not looking at a *known* function type anymore, or there are no - arguments left. *) - collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs ret_tvar - in - if sargs = [] then type_unknown_args () else + if sargs = [] then + collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs + ret_tvar + else let ty_fun' = expand_head env ty_fun in - match get_desc ty_fun', get_desc (expand_head env ty_fun0), sargs with - | Tarrow (ad, ty_arg, ty_ret, com), - Tarrow (_, ty_arg0, ty_ret0, _), - (_, sarg1) :: _ - when is_commu_ok com -> - let lv = get_level ty_fun' in + 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 lopt = + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + | Tarrow (ad, ty_arg, ty_ret, com), + Tarrow (_, ty_arg0, ty_ret0, _) + when is_commu_ok com -> + Some (ad, `Arrow (ty_arg, ty_ret, ty_arg0, ty_ret0)) + | _ -> None + in + let first_arg_loc = + match sargs with + | (_, sarg) :: _ -> sarg.pexp_loc + | [] -> Location.none + in + match lopt with + | None -> + (* We're not looking at a *known* function type anymore. *) + collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs + ret_tvar + | Some (ad, arrow_kind) -> + begin let (l, mode_arg, mode_ret) = ad in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let may_warn loc w = if not !warned && !Clflags.principal && lv <> generic_level then begin @@ -4625,48 +4923,47 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret | Error err -> raise(error(sarg1.pexp_loc, env, Function_type_not_rep(ty_arg, err))) in +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + 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 sort_arg = + match type_sort ~why:Function_argument ~fixed:false env ty_arg with + | Ok sort -> sort + | Error err -> raise(Error(sarg1.pexp_loc, env, + Function_type_not_rep(ty_arg, err))) + in +======= +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let name = label_name l and optional = is_optional l and omittable = is_omittable l in - let use_arg ~commuted sarg l' = - let wrapped_in_some = optional && not (is_optional l') in - if wrapped_in_some then - may_warn sarg.pexp_loc - (not_principal "using an optional argument here"); - Arg (Known_arg - { sarg; ty_arg; ty_arg0; commuted; sort_arg; - mode_fun; mode_arg; wrapped_in_some }) - in - let eliminate_omittable_arg expected_label = - may_warn funct.exp_loc - (Warnings.Non_principal_labels "eliminated omittable argument"); - Arg - (Eliminated_optional_arg - { mode_fun; ty_arg; mode_arg - ; sort_arg; level = lv; expected_label}) - in - let remaining_sargs, arg = + let remaining_sargs, arg_opt = 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 omittable && l' = Nolabel) then - (remaining_sargs, use_arg ~commuted:false sarg l') + (remaining_sargs, Some (sarg, l', ~commuted:false)) else if omittable && not (List.exists (fun (l, _) -> name = label_name l) - remaining_sargs) && + remaining_sargs) && List.exists (function (Nolabel, _) -> true | _ -> false) sargs then - (sargs, eliminate_omittable_arg l) + (sargs, None) else raise(error(sarg.pexp_loc, env, Apply_wrong_label(l', ty_fun', omittable))) end else (* Arguments can be commuted, try to fetch the argument - corresponding to the first parameter. *) + corresponding to the first parameter. *) match extract_label name sargs with | Some (l', sarg, commuted, remaining_sargs) -> if commuted then begin @@ -4686,27 +4983,54 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret Location.prerr_warning sarg.pexp_loc (Warnings.Nonoptional_label label)); - remaining_sargs, use_arg ~commuted sarg l' + remaining_sargs, Some (sarg, l', ~commuted) | None -> - sargs, - if omittable && List.mem_assoc Nolabel sargs then - eliminate_omittable_arg l - else begin - (* No argument was given for this parameter, we abstract over - it. *) + sargs, None + in + match arrow_kind with + | `Arrow (ty_arg, ty_ret, ty_arg0, ty_ret0) -> + let sort_arg = + match + type_sort ~why:Function_argument ~fixed:false env ty_arg + with + | Ok sort -> sort + | Error err -> + raise(Error(first_arg_loc, env, + Function_type_not_rep(ty_arg, err))) + in + let arg = + match arg_opt with + | Some (sarg, l', ~commuted) -> + let wrapped_in_some = optional && not (is_optional l') in + if wrapped_in_some then + may_warn sarg.pexp_loc + (not_principal "using an optional argument here"); + Arg (Known_arg + { sarg; ty_arg; ty_arg0; commuted; sort_arg; + mode_fun; mode_arg; wrapped_in_some }) + | None -> + if omittable && List.mem_assoc Nolabel sargs then begin + may_warn funct.exp_loc (Warnings.Non_principal_labels + "eliminated omittable argument"); + Arg (Eliminated_optional_arg + { mode_fun; ty_arg; mode_arg + ; sort_arg; level = lv; expected_label = l}) + end 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 { mode_fun; ty_arg; mode_arg; level = lv; sort_arg } end - in - loop ty_ret ty_ret0 mode_ret ((l, arg) :: rev_args) remaining_sargs - | _ -> - type_unknown_args () + in + loop ty_ret ty_ret0 mode_ret ((l, arg) :: rev_args) remaining_sargs + end in loop ty_fun ty_fun0 mode_fun [] sargs (* See Note [Type-checking applications] for an overview *) -let type_omitted_parameters expected_mode env loc ty_ret mode_ret args = +let type_omitted_parameters_and_build_result_type expected_mode env loc ty_ret + mode_ret args = let ty_ret, mode_ret, _, _, args = List.fold_left (fun (ty_ret, mode_ret, open_args, closed_args, args) (lbl, arg, sch) -> @@ -4781,7 +5105,7 @@ let rec is_nonexpansive exp = is_nonexpansive pat_exp.vb_expr && is_nonexpansive body | Texp_apply(e, (_,Omitted _)::el, _, _, _) -> is_nonexpansive e && List.for_all is_nonexpansive_arg (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... *) @@ -5134,7 +5458,7 @@ let rec approx_type env sty = let mret = Alloc.newvar () in newty (Tarrow ((p,marg,mret), newmono arg, ret, commu_ok)) | Ptyp_tuple args -> - newty (Ttuple (List.map (fun (label, t) -> label, approx_type env t) args)) + newty (Ttuple (List.map (fun (l, t) -> l, approx_type env t) 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 @@ -5239,6 +5563,10 @@ let rec type_approx env sexp ty_expected = ignore (type_approx_constraint env (Pcoerce (sty1, sty2)) ty_expected ~loc : type_expr) + | Pexp_pack (_, Some ptyp) -> + let sty = Ast_helper.Typ.package ~loc ptyp in + ignore @@ + type_approx_constraint env (Pconstraint sty) ~loc ty_expected | _ -> () and type_tuple_approx (env: Env.t) loc ty_expected l = @@ -5304,7 +5632,10 @@ let check_univars env kind exp ty_expected vars = in let pty = instance ty_expected in let exp_ty, vars = - with_local_level_iter ~post:generalize begin fun () -> + with_local_level_generalize + ~before_generalize:(fun (exp_ty, vars) -> + List.iter generalize (exp_ty :: vars)) + begin fun () -> match get_desc pty with Tpoly (body, tl) -> (* Enforce scoping for type_let: @@ -5349,19 +5680,13 @@ let check_univars env kind exp ty_expected vars = ()) univars vars; unify_exp_types exp.exp_loc env exp_ty ty'; - ((exp_ty, vars), exp_ty::vars) + (exp_ty, vars) | _ -> assert false end in let ty, complete = polyfy env exp_ty vars in if not complete then error ty 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 @@ -5446,10 +5771,13 @@ let check_partial_application ~statement exp = | Texp_probe _ | Texp_probe_is_enabled _ | Texp_src_pos | Texp_function _ | Texp_quotation _ | Texp_antiquotation _ -> 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_apply_layout (e, _) -> check e @@ -5526,8 +5854,6 @@ let contains_variant_either ty = try loop ty; false with Exit -> true end -let shallow_iter_ppat_labeled_tuple f lst = List.iter (fun (_,p) -> f p) lst - let shallow_iter_ppat f p = match p.ppat_desc with | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ @@ -5537,10 +5863,11 @@ 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 (fun (_,p) -> f p) lst - | Ppat_unboxed_tuple (lst, _) -> shallow_iter_ppat_labeled_tuple f lst + | Ppat_tuple (lst, _) -> List.iter (fun (_, p) -> f p) lst + | Ppat_unboxed_tuple (lst, _) -> List.iter (fun (_, p) -> f p) lst | Ppat_construct (_, Some (_, p)) | Ppat_exception p | Ppat_alias (p,_) | Ppat_open (_,p) @@ -5585,15 +5912,18 @@ let may_contain_gadts p = (* One of the things we do in the presence of GADT constructors (see above definition) is treat `let p = e in ...` as a match `match e with p -> ...`. This changes the way type inference works to check the expression first, and - using its type in the checking of the pattern. We want that behavior for + use its type in the checking of the pattern. We want that behavior for labeled tuple patterns as well. *) let turn_let_into_match p = - exists_ppat (fun p -> - match p.ppat_desc with - | Ppat_construct _ -> true - | Ppat_tuple (_, Open) -> true - | Ppat_tuple (ps, _) when components_have_label ps -> true - | _ -> false) p + exists_ppat + (fun p -> + match p.ppat_desc with + | Ppat_construct _ -> true + | Ppat_tuple (_, Open) -> true + | Ppat_tuple (spl, Closed) -> + List.exists (fun (l, _) -> Option.is_some l) spl + | _ -> 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 @@ -5621,7 +5951,7 @@ 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 @@ -5630,31 +5960,10 @@ let check_absent_variant env = 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. - - 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 *) +(* To find reasonable names for let-bound and lambda-bound idents *) let rec name_pattern default = function [] -> Ident.create_local default, @@ -5670,6 +5979,7 @@ let name_cases default lst = (* Typing of expressions *) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (** [sdesc_for_hint] is used by error messages to report literals in their original formatting *) let unify_exp ?sdesc_for_hint env exp expected_ty = @@ -5679,6 +5989,18 @@ let unify_exp ?sdesc_for_hint env exp expected_ty = with Error(loc, env, Expr_type_clash(err, tfc, None)) -> raise (error(loc, env, Expr_type_clash(err, tfc, sdesc_for_hint))) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +(** [sdesc_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 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))) + +======= +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let is_exclave_extension_node = function | "extension.exclave" | "ocaml.exclave" | "exclave" -> true | _ -> false @@ -5693,7 +6015,7 @@ let rec is_inferred sexp = [Nolabel, sbody]) when is_exclave_extension_node txt -> is_inferred sbody | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint (_, Some _, _) - | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true + | Pexp_coerce _ | Pexp_send _ | Pexp_new _ | Pexp_pack (_, Some _) -> true | Pexp_sequence (_, e) | Pexp_open (_, e) | Pexp_constraint (e, None, _) -> is_inferred e | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 @@ -5752,6 +6074,10 @@ let with_explanation explanation f = 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 + let unique_use ~loc ~env mode_l mode_r = if not (Language_extension.is_at_least Unique Language_extension.maturity_of_unique_for_drf) then begin @@ -5869,7 +6195,7 @@ let split_function_ty let { ty = ty_fun; explanation }, loc_fun = in_function in let separate = !Clflags.principal || Env.has_local_constraints env in let { ty_arg; ty_ret; arg_mode; ret_mode } as filtered_arrow = - with_local_level_if separate begin fun () -> + with_local_level_generalize_structure_if separate begin fun () -> let force_tpoly = (* If [has_poly] is true then we rely on the later call to type_pat to enforce the invariant that the parameter type @@ -5893,9 +6219,6 @@ let split_function_ty ; ret_mode = Mode.Alloc.newvar () } end - ~post:(fun {ty_arg; ty_ret; _} -> - generalize_structure ty_arg; - generalize_structure ty_ret) in apply_mode_annots ~loc:loc_fun ~env Parameter mode_annots arg_mode; apply_mode_annots ~loc:loc_fun ~env Return ret_mode_annots ret_mode; @@ -5994,25 +6317,6 @@ and type_function_ret_info = ret_sort: Jkind.sort; } -(* 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 generalize_structure_type_block_access_result - { ba; base_ty; el_ty; flat_float = _ } = - generalize_structure base_ty; - generalize_structure el_ty; - match ba with - | Baccess_field _ -> () - | Baccess_block (_, idx) -> - generalize_structure_exp idx - -let generalize_structure_type_unboxed_access_result - (el_ty, Uaccess_unboxed_field _) = - generalize_structure el_ty - (* value binding elaboration *) let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; pvb_modes=modes; _ } = @@ -6199,13 +6503,12 @@ and type_expect_ env (expected_mode : expected_mode) 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 let type_expect_record (type rep) ~overwrite (record_form : rep record_form) @@ -6219,11 +6522,11 @@ and type_expect_ | None -> None | Some sexp -> let exp, mode = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let mode = Value.newvar () in let exp = type_exp ~recarg env (mode_default mode) sexp in exp, mode - end ~post:(fun (exp, _) -> generalize_structure_exp exp) + end in Some (exp, Mode.Value.disallow_right mode) in @@ -6270,7 +6573,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 @@ -6511,7 +6814,7 @@ and type_expect_ exp_env = env } end in - match desc with + match sexp.pexp_desc with | Pexp_ident lid -> let path, actual_mode, layout_args, desc, kind = type_ident env ~recarg lid @@ -6550,6 +6853,78 @@ and type_expect_ (Longident.Lident ("self-" ^ cl_num)) env in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + submode ~loc ~env actual_mode expected_mode; + if List.is_empty layout_args then exp + else { exp with exp_desc = Texp_apply_layout (exp, layout_args) } + | Pexp_constant(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 expected_mode + 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_unboxed_unit -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; +======= + submode ~loc ~env actual_mode expected_mode; + if List.is_empty layout_args then exp + else { exp with exp_desc = Texp_apply_layout (exp, layout_args) } + | 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 expected_mode + 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_unboxed_unit -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 Texp_ident { path; lid; desc; kind; unique_use = unique_use ~loc ~env actual_mode (as_single_mode expected_mode); mode = actual_mode } @@ -6660,7 +7035,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 @@ -6709,9 +7084,10 @@ 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 (Jkind.Builtin.any ~why:Dummy_jkind))) + unify_exp ~sexp new_env body + (newvar (Jkind.Builtin.any ~why:Dummy_jkind))) in let exp = match mutable_flag, pat_exp_list with @@ -6809,39 +7185,35 @@ and type_expect_ | Nontail | Default -> Value.newvar () in let funct_expected_mode = mode_default funct_mode in - (* does the function return a tvar which is too generic? *) + let outer_level = get_current_level () in + let outer_level_var () = + newvar2 outer_level (Jkind.Builtin.any ~why:Dummy_jkind) + in let rec ret_tvar seen ty_fun = let ty = expand_head env ty_fun in if TypeSet.mem ty seen then false 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 (outer_level_var ()) ty_arg with Unify _ -> assert false); ret_tvar (TypeSet.add ty seen) ty_fun | Tvar _ -> - let v = newvar (Jkind.Builtin.any ~why:Dummy_jkind) in + let v = outer_level_var () in let rt = get_level ty > get_level v in unify_var env v ty; rt | _ -> - let v = newvar (Jkind.Builtin.any ~why:Dummy_jkind) in - unify_var env v ty; + unify_var env (outer_level_var ()) ty; false in + (* one more level for warning on non-returning functions *) + with_local_level_generalize ~before_generalize:ignore begin fun () -> let type_sfunct sfunct = - (* one more level for warning on non-returning functions *) - let funct, ty = - with_local_level - begin fun () -> - let funct = - with_local_level_if_principal - (fun () -> type_exp env funct_expected_mode sfunct) - ~post: generalize_structure_exp - in - let ty = instance funct.exp_type in - (funct, ty) - end + let funct = + with_local_level_generalize_structure_if_principal + (fun () -> type_exp env funct_expected_mode sfunct) in + let ty = instance funct.exp_type in let rt = wrap_trace_gadt_instances env (ret_tvar TypeSet.empty) ty in rt, funct in @@ -6922,6 +7294,7 @@ and type_expect_ in check_tail_call_local_returning loc env ap_mode pm; exp + end | Pexp_match(sarg, caselist) -> let is_bor = is_borrow sarg in let env, expected_mode, exp_extra = @@ -6939,25 +7312,46 @@ and type_expect_ tuple_pat_mode mode modes_pat, mode_tuple mode modes in let arg, sort = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let expected_ty, sort = new_rep_var ~why:Match () in let arg = type_expect env arg_expected_mode sarg (mk_expected expected_ty) in arg, sort - end ~post:(fun (arg, _) -> - may_lower_contravariant_then_generalize env arg) + end ~before_generalize:(fun (arg, _) -> + may_lower_contravariant env arg; + generalize arg.exp_type) + 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_pat_mode expected_mode arg.exp_type + sort 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 expected_mode ty_expected_explained loc + eff_caselist eff_conts in - let cases, partial = - type_cases Computation env arg_pat_mode expected_mode - arg.exp_type sort 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, sort, cases, partial); + exp_desc = Texp_match(arg, sort, val_cases, eff_cases, partial); exp_loc = loc; exp_extra; exp_type = instance ty_expected; exp_attributes = sexp.pexp_attributes; @@ -6969,13 +7363,32 @@ and type_expect_ sbody ty_expected_explained in let arg_mode = simple_pat_mode Value.legacy in - let cases, _ = + 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 arg_mode expected_mode Predef.type_exn Jkind.Sort.(of_const Const.for_exception) ty_expected_explained - ~check_if_total:false loc caselist in + ~check_if_total:false loc exn_caselist + in + let eff_cases = + match eff_caselist with + | [] -> [] + | eff_caselist -> + type_effect_cases Value env expected_mode 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; @@ -6987,8 +7400,8 @@ and type_expect_ type_unboxed_tuple ~loc ~env ~expected_mode ~ty_expected ~explanation ~attributes:sexp.pexp_attributes sexpl | Pexp_construct(lid, sarg) -> - type_construct ~overwrite env expected_mode loc lid - sarg ty_expected_explained sexp.pexp_attributes + type_construct ~overwrite ~sexp env expected_mode lid sarg + ty_expected_explained | Pexp_variant(l, sarg) -> (* Keep sharing *) let ty_expected1 = protect_expansion env ty_expected in @@ -7054,18 +7467,8 @@ and type_expect_ Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; type_expect_record ~overwrite Unboxed_product lid_sexp_list opt_sexp | Pexp_field(srecord, lid) -> - let (record, record_sort, rmode, label, _, ambiguity) = - type_label_access Legacy env srecord Env.Projection lid - in - let ty_arg = - with_local_level_if_principal begin fun () -> - (* [ty_arg] is the type of field, [ty_res] is the type of record, they - could share type variables, which are now instantiated *) - let (_, ty_arg, ty_res) = instance_label ~fixed:false label in - (* we now link the two record types *) - unify_exp env record ty_res; - ty_arg - end ~post:generalize_structure + let record, record_sort, rmode, label, ambiguity, ty_arg = + solve_Pexp_field ~label_usage:Env.Projection env sexp srecord Legacy lid in check_project_mutability ~loc:record.exp_loc ~env (Record_field label.lbl_name) label.lbl_mut rmode; @@ -7123,18 +7526,9 @@ and type_expect_ exp_env = env } | Pexp_unboxed_field(srecord, lid) -> Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; - let (record, record_sort, rmode, label, _, ambiguity) = - type_label_access Unboxed_product env srecord Env.Projection lid - in - let ty_arg = - with_local_level_if_principal begin fun () -> - (* [ty_arg] is the type of field, [ty_res] is the type of record, they - could share type variables, which are now instantiated *) - let (_, ty_arg, ty_res) = instance_label ~fixed:false label in - (* we now link the two record types *) - unify_exp env record ty_res; - ty_arg - end ~post:generalize_structure + let record, record_sort, rmode, label, ambiguity, ty_arg = + solve_Pexp_field ~label_usage:Env.Projection env sexp srecord + Unboxed_product lid in if Types.is_mutable label.lbl_mut then fatal_error @@ -7190,7 +7584,7 @@ and type_expect_ (Texp_inspected_type (Label_disambiguation ambiguity), loc, []) :: record.exp_extra } in - unify_exp env record ty_record; + unify_exp ~sexp env record ty_record; rue { exp_desc = Texp_setfield (record, Locality.disallow_right (regional_to_local @@ -7200,27 +7594,71 @@ and type_expect_ exp_type = instance Predef.type_unit; exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_array(mut, sargl) -> + | Pexp_array(mutability, sargl) -> + (* [: :] syntax requires the iarray extension. + Check for it before proceeding with type-based disambiguation. *) + (match mutability with + | Mutable -> () + | Immutable -> + Language_extension.assert_enabled ~loc Immutable_arrays ()); + let ty_elt, elt_sort, mutability = + let ty_expected = generic_instance ty_expected in + match mutability with + | Immutable -> + let jkind, elt_sort = + Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) + in + let ty_elt = newgenvar jkind in + with_explanation (fun () -> + unify_exp_types loc env (Predef.type_iarray ty_elt) ty_expected); + ty_elt, elt_sort, Asttypes.Immutable + | Mutable -> + match disambiguate_array_literal ~loc env ty_expected with + | { ty_elt = Some (ty_elt, sort); mut } -> ty_elt, sort, mut + | { ty_elt = None; mut } -> + let jkind, elt_sort = + Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) + in + let ty_elt = newgenvar jkind in + let to_unify = + match mut with + | Mutable -> Predef.type_array ty_elt + | Immutable -> Predef.type_iarray ty_elt + in + with_explanation (fun () -> + unify_exp_types loc env to_unify ty_expected); + ty_elt, elt_sort, mut + in let mutability = - match mut with + match mutability with | Mutable -> Mutable { mode = Value.Comonadic.legacy; (* CR aspsmith: Revisit once we support atomic arrays *) atomic = Nonatomic; } - | Immutable -> - Language_extension.assert_enabled ~loc Immutable_arrays (); - Immutable + | Immutable -> Immutable in - type_generic_array - ~loc - ~env - ~expected_mode - ~ty_expected - ~explanation - ~mutability - ~attributes:sexp.pexp_attributes - sargl + let alloc_mode, array_mode = register_allocation ~loc expected_mode in + let modalities = Typemode.mutable_modalities mutability in + let is_contained_by : Mode.Hint.is_contained_by = + {containing = Array Modality; container = (loc, Expression)} + in + let argument_mode = + mode_is_contained_by is_contained_by ~modalities array_mode + in + check_construct_mutability ~loc ~env mutability ~ty:ty_elt array_mode; + let argument_mode = expect_mode_cross env ty_elt argument_mode in + let argl = + List.map + (fun sarg -> type_expect env argument_mode sarg (mk_expected ty_elt)) + sargl + in + re { + exp_desc = Texp_array (mutability, elt_sort, argl, alloc_mode); + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } | Pexp_idx (ba, uas) -> Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; (* Compute the expected base type, to use for disambiguation of the record @@ -7237,8 +7675,7 @@ and type_expect_ let expected_base_ty = expected_base_ty ty_expected in let principal = is_principal ty_expected in let { ba; base_ty; el_ty; flat_float; modality } = - with_local_level_if_principal - ~post:generalize_structure_type_block_access_result + with_local_level_generalize_structure_if_principal (fun () -> let res = type_block_access env expected_base_ty principal ba in (* This unification is to get a better [base_ty], and is not @@ -7273,9 +7710,7 @@ and type_expect_ (fun (el_ty, modality) ua -> (* Generalize after each step, otherwise we'll have more "non-principal" warnings than desired. *) - with_local_level_if_principal - ~post:(fun ((t,_), ua) -> - generalize_structure_type_unboxed_access_result (t,ua)) + with_local_level_generalize_structure_if_principal (fun () -> let (el_ty, ua_modality), ua = type_unboxed_access env loc el_ty ua @@ -7351,7 +7786,7 @@ and type_expect_ type_expect env expected_mode 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 = []; @@ -7461,7 +7896,7 @@ and type_expect_ } | Pexp_constraint (sarg, Some sty, modes) -> let modes = Typemode.transl_mode_annots modes in - let (ty, extra_cty) = + let (ty, exp_extra) = let alloc_mode = Mode.Alloc.Const.Option.value modes.mode_modes @@ -7486,9 +7921,8 @@ and type_expect_ exp_env = env; exp_extra = (Texp_mode modes, loc, []) :: - (Texp_constraint extra_cty, - loc, - sexp.pexp_attributes) :: arg.exp_extra; + (Texp_constraint exp_extra, loc, sexp.pexp_attributes) :: + arg.exp_extra; } | Pexp_coerce(sarg, sty, sty') -> let arg, ty', exp_extra = @@ -7514,9 +7948,8 @@ and type_expect_ let pm = position_and_mode env expected_mode sexp 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.txt) - ~post:(fun (_,_,typ) -> generalize_structure typ) in let typ, obj_extra = match get_desc typ with @@ -7667,7 +8100,7 @@ and type_expect_ | 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 @@ -7678,7 +8111,7 @@ and type_expect_ | _ -> 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 = []; @@ -7709,7 +8142,7 @@ and type_expect_ let body = type_expect new_env expected_mode 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 @@ -7786,8 +8219,7 @@ and type_expect_ } | 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 -> @@ -7809,31 +8241,32 @@ and type_expect_ { 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 tl ty') - ~post:(fun (_,ty'') -> generalize_structure ty'') in let exp = type_expect env expected_mode sbody (mk_expected ty'') in (exp, vars) end - ~post: begin fun (exp,vars) -> - generalize_and_check_univars env "method" exp ty_expected vars + ~before_generalize:begin fun (exp,vars) -> + List.iter generalize (exp.exp_type :: 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 expected_mode sbody in let exp = {exp with exp_type = newmono 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(name, jkind, sbody) -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 type_newtype_expr ~loc ~env ~expected_mode ~rue ~attributes:sexp.pexp_attributes name jkind sbody | Pexp_pack m -> @@ -7862,6 +8295,98 @@ and type_expect_ exp_type = newty (Tpackage (p, fl')); exp_attributes = sexp.pexp_attributes; exp_env = env } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + type_newtype_expr ~loc ~env ~expected_mode ~rue ~attributes:sexp.pexp_attributes + name jkind sbody + | 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 + let mode = Typedtree.mode_without_locks_exn modl.mod_mode in + submode ~loc ~env mode expected_mode; + 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 } +======= + let body, ety, id, uid = + type_newtype env name jkind (fun env -> + let expr = type_exp env expected_mode 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 (id, name, jkind, uid), + loc, sexp.pexp_attributes) :: body.exp_extra + } + | Pexp_pack (m, optyp) -> + begin match optyp with + | Some ptyp -> + let t = Ast_helper.Typ.package ~loc:ptyp.ppt_loc ptyp in + let pty, exp_extra = type_constraint env t Alloc.Const.legacy in + begin match get_desc (instance pty) with + | Tpackage pack -> + let (modl, pack') = !type_package env m pack in + let mode = Typedtree.mode_without_locks_exn modl.mod_mode in + submode ~loc ~env mode expected_mode; + let ty = newty (Tpackage pack') in + unify_exp_types m.pmod_loc env (instance pty) ty; + rue { + exp_desc = Texp_pack modl; + exp_loc = loc; + exp_extra = [Texp_constraint exp_extra, loc, []]; + exp_type = instance pty; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + fatal_error "[type_expect] Package not translated to a package" + end + | None -> + let pack = + match get_desc (Ctype.expand_head env (instance ty_expected)) with + Tpackage pack -> + 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"); + pack + | Tvar _ -> + raise (Error (loc, env, Cannot_infer_signature)) + | _ -> + raise (Error (loc, env, Not_a_packed_module ty_expected)) + in + let (modl, pack') = !type_package env m pack in + let mode = Typedtree.mode_without_locks_exn modl.mod_mode in + submode ~loc ~env mode expected_mode; + rue { + exp_desc = Texp_pack modl; + exp_loc = loc; exp_extra = []; + exp_type = newty (Tpackage pack'); + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | Pexp_open (od, e) -> Env.check_no_open_quotations loc env Open_qt; let tv = newvar (Jkind.Builtin.any ~why:Dummy_jkind) in @@ -7896,15 +8421,16 @@ and type_expect_ (* CR layouts v5: eliminate value requirement *) let ty = newvar (Jkind.Builtin.value_or_null ~why:Tuple_element) in let loc = Location.ghostify slet.pbop_op.loc in - let spat_acc = Ast_helper.Pat.tuple ~loc [None, spat_acc; None, spat] Closed in + let spat_acc = + Ast_helper.Pat.tuple ~loc [None, spat_acc; None, spat] Closed + in let ty_acc = newty (Ttuple [None, ty_acc; None, ty]) in loop spat_acc ty_acc Jkind.Sort.scannable rest in let op_path, op_desc, op_type, spat_params, ty_params, param_sort, ty_func_result, body_sort, ty_result, op_result_sort, ty_andops, sort_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 = op_desc.val_type in @@ -7937,10 +8463,9 @@ 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, param_sort, - ty_func_result, body_sort, ty_result, op_result_sort, - ty_andops, sort_andops), - [ty_andops; ty_params; ty_func_result; ty_result]) + (op_path, op_desc, op_type, spat_params, ty_params, param_sort, + ty_func_result, body_sort, ty_result, op_result_sort, + ty_andops, sort_andops) end in let exp, exp_sort, ands = @@ -8031,7 +8556,9 @@ and type_expect_ begin match payload with | PStr ([{ pstr_desc = Pstr_eval - ({pexp_desc=(Pexp_constant (Pconst_string(name,_,None))); + ({pexp_desc= + (Pexp_constant + { pconst_desc = Pconst_string(name,_,None); _}); pexp_loc = name_loc; _ } , _)}]) -> @@ -8064,14 +8591,13 @@ and type_expect_ { pexp_desc = Pexp_field (srecord, lid); _ } as sexp, _ ) } ] -> - let (record, record_sort, rmode, label, _, _ambiguity) = - type_label_access Legacy env srecord Env.Mutation lid + let record, record_sort, rmode, label, ambiguity, ty_arg = + solve_Pexp_field ~label_usage:Env.Mutation env sexp srecord + Legacy lid in Env.mark_label_used Env.Projection label.lbl_uid; if (not (Types.is_atomic label.lbl_mut)) then raise (Error (loc, env, Label_not_atomic lid.txt)); - let (_, ty_arg, ty_res) = instance_label ~fixed:false label in - unify_exp env record ty_res; let alloc_mode, argument_mode = register_allocation ~loc expected_mode in @@ -8083,6 +8609,11 @@ and type_expect_ raise (Error (loc, env, Modalities_on_atomic_field lid.txt)) end; submode ~loc ~env rmode argument_mode; + let record = + { record with exp_extra = + (Texp_inspected_type (Label_disambiguation ambiguity), loc, []) + :: record.exp_extra } + in rue { exp_desc = Texp_atomic_loc @@ -8404,18 +8935,18 @@ and type_coerce match sty with | None -> let (cty', ty', force) = - with_local_level begin fun () -> + with_local_level_generalize_structure begin fun () -> Typetexp.transl_simple_type_delayed env type_mode sty' end - ~post:(fun (_, ty, _) -> generalize_structure ty) 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 expected_mode 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', _, _)) @@ -8427,14 +8958,14 @@ and type_coerce && closed_type_expr ~env ty' -> if not gen && (* first try a single coercion *) let snap = snapshot () in - let ty, _b = enlarge_type env ty' in + let ty, _b = enlarge_type env (generic_instance 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 + let force' = subtype env arg_type (generic_instance ty') in force (); force' (); if not gen && !Clflags.principal then Location.prerr_warning loc @@ -8444,7 +8975,7 @@ and type_coerce raise (error (loc, env, Not_subtype err)) end; | _ -> - let ty, b = enlarge_type env ty' in + let ty, b = enlarge_type env (generic_instance 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 @@ -8455,14 +8986,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 type_mode sty and (cty', ty', force') = Typetexp.transl_simple_type_delayed env type_mode sty' in - ((cty, ty, force, cty', ty', force'), - [ ty; ty' ]) + (cty, ty, force, cty', ty', force') end in begin try @@ -8479,10 +9009,10 @@ and type_coerce and type_constraint env sty type_mode = (* Pretend separate = true, 1% slowdown for lablgtk *) let cty = - with_local_level begin fun () -> - Typetexp.transl_simple_type ~new_var_jkind:Any env ~closed:false type_mode sty + with_local_level_generalize_structure begin fun () -> + Typetexp.transl_simple_type ~new_var_jkind:Any env ~closed:false type_mode + sty end - ~post:(fun cty -> generalize_structure cty.ctyp_type) in cty.ctyp_type, cty @@ -8502,14 +9032,66 @@ and type_constraint_expect type_coerce constraint_arg env expected_mode loc ty_constrain ty_coerce type_mode ~loc_arg | Pconstraint ty_constrain -> - let ty, extra_cty = type_constraint env ty_constrain type_mode in + let ty, cty = type_constraint env ty_constrain type_mode in constraint_arg.type_with_constraint env expected_mode ty, ty, - Texp_constraint extra_cty + Texp_constraint cty 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 the jkind annotation written + by the user. +*) +and type_newtype + : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) + -> a * type_expr * Ident.t * Uid.t = + fun env { txt = name; loc = name_loc } jkind_annot_opt type_body -> + let jkind = + Jkind.of_annotation_option_default env ~context:(Newtype_declaration name) + ~default:(Jkind.Builtin.value ~why:Univar) jkind_annot_opt + in + let ty = + if Typetexp.valid_tyvar_name name then + newvar ~name jkind + else + newvar jkind + 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 jkind 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; + 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 = (* CR zqian: [lookup_value] should close over the memaddr of all prefix modules. *) @@ -8856,7 +9438,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 { function_ = _, params_suffix, body; newtypes; params_contain_gadt = suffix_contains_gadt; @@ -9077,7 +9659,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]. *) @@ -9136,7 +9718,7 @@ and type_label_access ~level:(Ctype.get_current_level ()) in let record = - with_local_level_if_principal ~post:generalize_structure_exp + with_local_level_generalize_structure_if_principal (fun () -> type_expect ~recarg:Allowed env (mode_default mode) srecord (mk_expected (newvar record_jkind))) @@ -9190,6 +9772,25 @@ and type_label_access (record, record_sort, Mode.Value.disallow_right mode, make_fake_label record_form, expected_type, Unambiguous) +and solve_Pexp_field + : 'rep . label_usage:_ -> _ -> _ -> _ -> 'rep record_form -> _ -> + _ * _ * _ * 'rep gen_label_description * _ * _ = + fun ~label_usage env sexp srecord form lid -> + let (record, record_sort, rmode, label, _, ambiguity) = + type_label_access form env srecord label_usage lid + in + let ty_arg = + with_local_level_generalize_structure_if_principal begin fun () -> + (* [ty_arg] is the type of field, [ty_res] is the type of record, they + could share type variables, which are now instantiated *) + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in + (* we now link the two record types *) + unify_exp ~sexp env record ty_res; + ty_arg + end + in + (record, record_sort, rmode, label, ambiguity, ty_arg) + (* 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.) *) @@ -9208,14 +9809,20 @@ and type_format loc str env = loc = loc; } in let mk_constr name args = - let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in + let lid = + Longident.(Ldot(mknoloc (Lident "CamlinternalFormatBasics"), + mknoloc name)) + in let arg = match args with | [] -> None | [ e ] -> Some e | _ :: _ :: _ -> - Some (mk_exp_loc (Pexp_tuple (List.map (fun e -> None, e) args))) in + Some (mk_exp_loc (Pexp_tuple (List.map (fun e -> None, e) 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 @@ -9459,22 +10066,15 @@ and type_label_exp = fun ~overwrite create env arg_mode loc ty_expected (lid, label, sarg) record_form -> (* 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 = is_poly_Tpoly label.lbl_arg in + let (vars, arg) = + (* raise level to check univars *) + with_local_level_generalize_if is_poly begin fun () -> let unify_as_label ty_expected = - 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) @@ -9484,17 +10084,23 @@ and type_label_exp 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 let (vars, ty_arg) = unify_as_label ty_expected in if label.lbl_private = Private then if create then raise (error(loc, env, Private_type ty_expected)) else +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 raise (error(lid.loc, env, Private_label(lid.txt, ty_expected))); let snap = if vars = [] then None else Some (Btype.snapshot ()) in +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); + let snap = if vars = [] then None else Some (Btype.snapshot ()) in +======= + raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let overwrite = match overwrite with | No_overwrite_label -> No_overwrite @@ -9504,45 +10110,15 @@ and type_label_exp Assigning(ty_arg, mode) in let arg = type_argument ~overwrite env arg_mode sarg ty_arg (instance ty_arg) in - (vars, ty_arg, snap, arg) + (vars, 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 ~overwrite:No_overwrite env arg_mode 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 (vars, arg) -> + may_lower_contravariant env arg; + List.iter generalize (arg.exp_type :: label.lbl_arg :: vars) + ) 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 ~overwrite env (mode : expected_mode) sarg ty_expected' ty_expected = @@ -9608,7 +10184,7 @@ and type_argument_ ?explanation ?recarg ~overwrite env (mode : expected_mode) sa (* we must be very careful about not breaking the semantics *) let exp_mode, _ = Value.newvar_below (as_single_mode mode) in let texp = - with_local_level_if_principal ~post:generalize_structure_exp + with_local_level_generalize_structure_if_principal (fun () -> let expected_mode = mode @@ -9640,7 +10216,7 @@ and type_argument_ ?explanation ?recarg ~overwrite env (mode : expected_mode) sa 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 && @@ -9652,7 +10228,7 @@ and type_argument_ ?explanation ?recarg ~overwrite env (mode : expected_mode) sa marg, ty_arg, mret, 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 begin let alloc_mode, mode_subcomponent = register_allocation ~loc:sarg.pexp_loc ~desc:Function_coercion mode @@ -9669,7 +10245,7 @@ and type_argument_ ?explanation ?recarg ~overwrite env (mode : expected_mode) sa val_zero_alloc = Zero_alloc.default; val_modalities = Modality.undefined; 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 ~mode id desc env in @@ -9772,7 +10348,7 @@ and type_argument_ ?explanation ?recarg ~overwrite env (mode : expected_mode) sa let mode = expect_mode_cross env ty_expected' mode in let texp = type_expect ?recarg ~overwrite env mode sarg (mk_expected ?explanation ty_expected') in - unify_exp env texp ty_expected; + unify_exp ~sexp:sarg env texp ty_expected; texp and type_argument ?explanation ?recarg ~overwrite env mode sarg ty_expected' ty_expected = @@ -9792,22 +10368,21 @@ and type_argument ?explanation ?recarg ~overwrite env mode sarg ty_expected' ty_ ~attributes:(Msupport.recovery_attributes sarg.pexp_attributes)) (* See Note [Type-checking applications] for an overview *) -and type_apply_arg env ~app_loc ~funct ~index ~position_and_mode ~partial_app (lbl, arg) = +and type_apply_arg env ~app_loc ~funct ~index ~position_and_mode ~partial_app + (lbl, arg) = match arg with | Arg (Unknown_arg { sarg; ty_arg_mono; mode_arg; sort_arg }) -> let expected_mode, mode_arg = mode_argument ~funct ~index ~position_and_mode ~partial_app mode_arg in - let arg = - type_expect env expected_mode sarg (mk_expected ty_arg_mono) - in + let arg = type_expect env expected_mode sarg (mk_expected ty_arg_mono) in (match lbl with | Labelled _ | Nolabel -> () | Optional _ -> (* CR layouts v5: relax value requirement *) - unify_exp env arg + unify_exp ~sexp:sarg env arg (type_option(newvar Predef.option_argument_jkind)) | Position _ -> - unify_exp env arg (instance Predef.type_lexing_position)); + unify_exp ~sexp:sarg env arg (instance Predef.type_lexing_position)); (lbl, Arg (arg, mode_arg, sort_arg), None) | Arg (Known_arg { sarg; ty_arg; ty_arg0; mode_arg; wrapped_in_some; sort_arg }) -> @@ -9839,12 +10414,12 @@ and type_apply_arg env ~app_loc ~funct ~index ~position_and_mode ~partial_app (l let separate = !Clflags.principal || Env.has_local_constraints env in - let arg, _, _ = - with_local_level begin fun () -> + let arg, ty_arg, vars = + with_local_level_generalize begin fun () -> let vars, ty_arg' = - with_local_level_if separate begin fun () -> + with_local_level_generalize_structure_if separate begin fun () -> instance_poly_fixed vars ty_arg' - end ~post:(fun (_, ty_arg') -> generalize_structure ty_arg') + end in let (ty_arg0', vars0) = tpoly_get_poly ty_arg0 in let vars0, ty_arg0' = instance_poly_fixed vars0 ty_arg0' in @@ -9855,11 +10430,12 @@ and type_apply_arg env ~app_loc ~funct ~index ~position_and_mode ~partial_app (l in arg, ty_arg, vars end - ~post:(fun (arg, ty_arg, vars) -> + ~before_generalize:(fun (arg, ty_arg, vars) -> if maybe_expansive arg then lower_contravariant env arg.exp_type; - generalize_and_check_univars env "argument" arg ty_arg vars); + List.iter generalize (arg.exp_type :: ty_arg :: vars)) in + check_univars env "argument" arg ty_arg vars; {arg with exp_type = instance arg.exp_type}, sch end in @@ -9886,14 +10462,20 @@ and type_application env app_loc expected_mode position_and_mode | (* Special case for ignore: avoid discarding warning *) [Parsetree.Nolabel, sarg] when is_ignore funct -> let {ty_arg; arg_mode; ty_ret; ret_mode} = - with_local_level_if_principal (fun () -> - filter_arrow_mono env (instance funct.exp_type) Nolabel - ) ~post:(fun {ty_ret; _} -> generalize_structure ty_ret) + with_local_level_generalize_structure_if_principal (fun () -> + filter_arrow_mono env (instance funct.exp_type) Nolabel) in let type_sort ~why ty = match Ctype.type_sort ~why ~fixed:false env ty with | Ok sort -> sort +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 | Error err -> raise (error (app_loc, env, Function_type_not_rep (ty, err))) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | Error err -> raise (Error (app_loc, env, Function_type_not_rep (ty, err))) +======= + | Error err -> + raise (Error (app_loc, env, Function_type_not_rep (ty, err))) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 in let arg_sort = type_sort ~why:Function_argument ty_arg in let arg_mode, _ = @@ -9925,7 +10507,11 @@ and type_application env app_loc expected_mode position_and_mode end in let ty_ret, mode_ret, args, position_and_mode = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> + (* Consider for example the application + [f n] + with + [f : a:bar -> ?opt:baz -> int -> unit] *) let sargs = List.map (fun (label, e) -> Typetexp.transl_label_from_expr label e) sargs in @@ -9933,6 +10519,11 @@ and type_application env app_loc expected_mode position_and_mode collect_apply_args env funct ignore_labels ty (instance ty) (value_to_alloc_r2l funct_mode) sargs ret_tvar in + (* example: [collect_apply_args] returns + [ty_ret = unit] and + [args = [(Label "a", Omitted bar); + (Optional "opt", Arg (Eliminated_optional_arg baz)); + (Nolabel, Arg (Known_arg n))]] *) let partial_app = is_partial_apply untyped_args in let position_and_mode = if partial_app then position_and_mode_default else position_and_mode @@ -9943,14 +10534,29 @@ and type_application env app_loc expected_mode position_and_mode ~position_and_mode ~partial_app arg) untyped_args in + (* example: type-check [n] and generate [None] for [?opt]. + [args] becomes [(Label "a", Omitted bar); + (Optional "opt", Arg None); + (Nolabel, Arg n)] *) let ty_ret, mode_ret, args = - type_omitted_parameters expected_mode env app_loc ty_ret mode_ret - args + type_omitted_parameters_and_build_result_type expected_mode env + app_loc ty_ret mode_ret args in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (try check_curried_application_complete ~env ~app_loc untyped_args with exn -> raise_error exn); +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + check_curried_application_complete ~env ~app_loc untyped_args; +======= + check_curried_application_complete ~env ~app_loc untyped_args; + (* example: + [ty_ret] becomes [a:bar -> unit] + [args] becomes [(Label "a", Omitted ()); + (Optional "opt", Arg None); + (Nolabel, Arg n)] *) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 ty_ret, mode_ret, args, position_and_mode - end ~post:(fun (ty_ret, _, _, _) -> generalize_structure ty_ret) + end in args, ty_ret, mode_ret, position_and_mode @@ -9960,6 +10566,9 @@ and type_tuple ~overwrite ~loc ~env ~(expected_mode : expected_mode) ~ty_expecte we allow non-values in boxed tuples. *) let arity = List.length sexpl in assert (arity >= 2); + Option.iter + (fun l -> raise (Error (loc, env, Repeated_tuple_exp_label l))) + (Misc.repeated_label sexpl); let alloc_mode, value_mode = register_allocation_value_mode ~loc expected_mode.mode in @@ -10011,9 +10620,6 @@ and type_tuple ~overwrite ~loc ~env ~(expected_mode : expected_mode) ~ty_expecte let expl = Misc.Stdlib.List.map3 (fun (label, body) ((_, ty), argument_mode) overwrite -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - label; let argument_mode = mode_default argument_mode in let argument_mode = expect_mode_cross env ty argument_mode in (label, type_expect ~overwrite env argument_mode body (mk_expected ty))) @@ -10032,6 +10638,9 @@ and type_unboxed_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; let arity = List.length sexpl in assert (arity >= 2); + Option.iter + (fun l -> raise (Error (loc, env, Repeated_tuple_exp_label l))) + (Misc.repeated_label sexpl); let argument_mode = expected_mode.mode |> apply_is_contained_by {containing = Tuple; container = (loc, Expression)} @@ -10075,9 +10684,6 @@ and type_unboxed_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected let expl = List.map2 (fun (label, body) ((_, ty, sort), argument_mode) -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - label; let argument_mode = mode_default argument_mode in let argument_mode = expect_mode_cross env ty argument_mode in (label, type_expect env argument_mode body (mk_expected ty), sort)) @@ -10093,8 +10699,8 @@ and type_unboxed_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected exp_attributes = attributes; exp_env = env } -and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg - ty_expected_explained attrs = +and type_construct ~overwrite ~sexp env (expected_mode : expected_mode) 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 @@ -10104,8 +10710,16 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg | Not_a_variant_type -> let srt = wrong_kind_sort_of_constructor lid.txt in let ctx = Expression explanation in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let err = Wrong_expected_kind(srt, ctx, ty_expected) in raise (error (loc, env, err)) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let error = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (Error (loc, env, error)) +======= + let error = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (Error (sexp.pexp_loc, env, error)) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 in let constrs = Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env @@ -10117,6 +10731,7 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg in let sargs = match sarg with +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 | None -> [] | Some se -> begin match se.pexp_desc with @@ -10130,40 +10745,74 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg | _ -> [se] end in +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + | None -> [] + | Some se -> begin + match se.pexp_desc with + | Pexp_tuple sel when + constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs + -> + if components_have_label sel then + raise(Error(loc, env, Constructor_labeled_arg)) + else + List.map (fun (_, e) -> e) sel + | _ -> [se] + end + in +======= + None -> [] + | Some {pexp_desc = Pexp_tuple sel} when + constr.cstr_arity > 1 + || Builtin_attributes.explicit_arity sexp.pexp_attributes + -> + List.map (fun (l, se) -> + match l with + | Some _ -> + raise (Error(sexp.pexp_loc, env, Constructor_labeled_arg)) + | None -> se + ) sel + | Some se -> [se] in +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 if List.length sargs <> constr.cstr_arity then +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 raise(error(loc, env, Constructor_arity_mismatch (lid.txt, constr.cstr_arity, List.length sargs))); +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + 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))); +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let separate = !Clflags.principal || Env.has_local_constraints env in let unify_as_construct ty_expected = - with_local_level_if separate 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, [], None); - exp_loc = loc; + exp_loc = sexp.pexp_loc; exp_extra = [ - Texp_inspected_type (Label_disambiguation ambiguity), loc, []]; + Texp_inspected_type (Label_disambiguation ambiguity), + sexp.pexp_loc, + [] + ]; 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 + with_explanation explanation (fun () -> + unify_exp ~sexp env {texp with exp_type = instance ty_res} + (instance ty_expected)); (ty_args, ty_res, texp) end - ~post:(fun (ty_args, ty_res, _) -> - generalize_structure ty_res; - List.iter (fun {Types.ca_type=ty; _} -> generalize_structure ty) ty_args) in let ty_args, ty_res, texp = unify_as_construct ty_expected in let ty_args0, ty_res = @@ -10172,7 +10821,7 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg | _ -> 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 @@ -10186,7 +10835,13 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))})}] -> Required | _ -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 raise (error(loc, env, Inlined_record_expected)) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + raise (Error(loc, env, Inlined_record_expected)) +======= + raise (Error(sexp.pexp_loc, env, Inlined_record_expected)) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 end in let constructor_mode = @@ -10205,12 +10860,14 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg | Variant_unboxed | Variant_with_null -> expected_mode, None | Variant_boxed _ when constr.cstr_constant -> expected_mode, None | Variant_boxed _ | Variant_extensible -> - let alloc_mode, argument_mode = register_allocation ~loc expected_mode in + let alloc_mode, argument_mode = + register_allocation ~loc:sexp.pexp_loc expected_mode + in argument_mode, Some alloc_mode in begin match overwrite, constr.cstr_repr with | Overwriting(_, _, _), Variant_unboxed -> - raise (Error (loc, env, Overwrite_of_invalid_term)); + raise (Error (sexp.pexp_loc, env, Overwrite_of_invalid_term)); | _, _ -> () end; let overwrites = @@ -10236,7 +10893,7 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg (fun e ({Types.ca_type=ty; ca_modalities=modalities; _},t0) overwrite -> let is_contained_by : Mode.Hint.is_contained_by = { containing = Constructor (constr.cstr_name, Modality); - container = (loc, Expression) } + container = (sexp.pexp_loc, Expression) } in let argument_mode = mode_is_contained_by is_contained_by ~modalities argument_mode @@ -10247,9 +10904,21 @@ and type_construct ~overwrite env (expected_mode : expected_mode) loc lid sarg if constr.cstr_private = Private then begin match constr.cstr_repr with | Variant_extensible -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 raise(error(loc, env, Private_constructor (constr, ty_res))) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + raise(Error(loc, env, Private_constructor (constr, ty_res))) +======= + raise(Error(sexp.pexp_loc, env, Private_constructor (constr, ty_res))) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | Variant_boxed _ | Variant_unboxed -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 raise (error(loc, env, Private_type ty_res)); +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + raise (Error(loc, env, Private_type ty_res)); +======= + raise (Error(sexp.pexp_loc, env, Private_type ty_res)); +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | Variant_with_null -> assert false (* [Variant_with_null] can't be made private due to [or_null_reexport]. *) end; @@ -10275,7 +10944,22 @@ and type_statement ?explanation ?(position=RNontail) env sexp = | Texp_while _ -> true | _ -> false in + let expected_ty, sort = + if !Clflags.strict_sequence then + (* CR layouts v5: when we have unboxed unit, allow it for -strict-sequence + *) + instance Predef.type_unit, Jkind.Sort.scannable + else begin + (* We're requiring the statement to have a representable jkind. But that + doesn't actually rule out things like "assert false"---we'll just end + up getting a sort variable for its jkind. *) + (* CR layouts v10: Abstract jkinds will introduce cases where we really + have [any] and can't get a sort here. *) + new_rep_var ~why:Statement () + end + in (* Raise the current level to detect non-returning functions *) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let exp = with_local_level (fun () -> type_exp env (mode_max_with_position position) sexp) @@ -10308,6 +10992,63 @@ and type_statement ?explanation ?(position=RNontail) env sexp = raise(error(exp.exp_loc, env, Expr_type_clash(err, None, Some sexp.pexp_desc)))); exp, sort +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let exp = + with_local_level + (fun () -> type_exp env (mode_max_with_position position) 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 + (* CR layouts v5: when we have unboxed unit, allow it for -strict-sequence *) + let expected_ty = instance Predef.type_unit in + with_explanation explanation (fun () -> + unify_exp env exp expected_ty); + exp, Jkind.Sort.scannable + else begin + (* We're requiring the statement to have a representable jkind. But that + doesn't actually rule out things like "assert false"---we'll just end up + getting a sort variable for its jkind. *) + (* CR layouts v10: Abstract jkinds will introduce cases where we really have + [any] and can't get a sort here. *) + let tv, sort = new_rep_var ~why:Statement () in + check_partial_application ~statement:true exp; + with_explanation explanation (fun () -> + try unify_var env ty tv + with Unify err -> + raise(Error(exp.exp_loc, env, + Expr_type_clash(err, None, Some sexp.pexp_desc)))); + exp, sort +======= + with_local_level_generalize + (fun () -> type_exp env (mode_max_with_position position) sexp, sort) + ~before_generalize: begin fun (exp, _sort) -> + 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 + with_explanation explanation (fun () -> + unify_exp ~sexp env exp expected_ty) + else begin + check_partial_application ~statement:true exp; + with_explanation explanation (fun () -> + try unify_var env ty expected_ty + with Unify err -> + raise(Error(exp.exp_loc, env, + Expr_type_clash(err, None, Some sexp)))); + end +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 end (* Most of the arguments are the same as [type_cases]. @@ -10324,20 +11065,22 @@ and type_statement ?explanation ?(position=RNontail) 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 pat_mode ty_arg sort_arg ty_res loc caselist ~type_body ~check_if_total -> let has_errors = Msupport.monitor_errors () in @@ -10350,7 +11093,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 @@ -10380,25 +11123,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 ~alloc_mode:pat_mode env pattern - ty_arg sort_arg allow_modules + type_pattern ?cont category ~lev ~alloc_mode:pat_mode env + pattern ty_arg sort_arg allow_modules in pattern_force := force @ !pattern_force; { typed_pat = pat; @@ -10411,9 +11158,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 @@ -10421,7 +11165,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 = @@ -10429,7 +11173,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) *) @@ -10455,7 +11199,7 @@ 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') -> + ~before_generalize: begin fun (half_typed_cases, _, _, ty_arg') -> generalize ty_arg'; List.iter (fun { pat_vars; _ } -> iter_pattern_variables_type generalize pat_vars @@ -10464,11 +11208,12 @@ and map_half_typed_cases 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 @@ -10480,23 +11225,26 @@ 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 { name = s; mutated = false }) ~check_as:(fun s -> Warnings.Unused_var { name = s; mutated = false}) 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 = @@ -10575,80 +11323,13 @@ and map_half_typed_cases (* Ensure that existential types do not escape *) ~post:(fun ty_res' -> enforce_current_level env ty_res') -(** 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 the jkind annotation written - by the user. -*) -and type_newtype - : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) - -> a * type_expr * Ident.t * Uid.t = - fun env name jkind_annot_opt type_body -> - let { txt = name; loc = name_loc } : _ Location.loc = name in - let jkind = - Jkind.of_annotation_option_default env ~context:(Newtype_declaration name) - ~default:(Jkind.Builtin.value ~why:Univar) jkind_annot_opt - in - let ty = - if Typetexp.valid_tyvar_name name then - newvar ~name jkind - else - newvar jkind - in - (* Use [with_local_level] just for scoping *) - with_local_level begin fun () -> - (* Create a fake abstract type declaration for name. *) - let decl = new_local_type ~loc:name_loc Definition jkind 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; - let uid = decl.type_uid in - (result, ety, id, uid) - end - -(** [type_newtype] where the "body" is just an expression. *) -and type_newtype_expr - ~loc ~env ~expected_mode ~rue ~attributes name jkind_annot_opt sbody = - let body, ety, id, uid = - type_newtype env name jkind_annot_opt (fun env -> - let expr = type_exp env expected_mode 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 (id, name, jkind_annot_opt, uid), - loc, attributes) :: body.exp_extra } - (* Typing of match cases *) and type_cases : type k . k pattern_category -> - _ -> _ -> _ -> _ -> _ -> _ -> check_if_total:bool -> _ -> + _ -> _ -> _ -> _ -> _ -> _ -> ?conts:_ -> check_if_total:bool -> _ -> Parsetree.case list -> k case list * partial = fun category env pat_mode expr_mode - ty_arg sort_arg ty_res_explained ~check_if_total loc caselist -> + ty_arg sort_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 @@ -10671,17 +11352,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 pat_mode ty_arg sort_arg ty_res loc caselist - ~check_if_total + map_half_typed_cases ?conts category env pat_mode ty_arg sort_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 mode_max scond + (type_expect when_env mode_max scond (mk_expected ~explanation:When_guard Predef.type_bool)) in let exp = @@ -10689,6 +11377,7 @@ and type_cases in { c_lhs = pat; + c_cont = cont; c_guard = guard; c_rhs = {exp with exp_type = ty_infer} } @@ -10775,6 +11464,37 @@ and type_function_cases_expect {mode_modes = Alloc.disallow_right ret_mode; mode_desc = []} } end +and type_effect_cases + : type k . k pattern_category -> _ -> _ -> _ -> _ -> Parsetree.case list -> + _ -> k case list + = fun category env rhs_mode ty_res_explained loc caselist conts -> + let { ty = ty_res; explanation = _ } = ty_res_explained 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 scope = create_scope () in + let name = Ctype.get_new_abstract_name env "%eff" in + let id = Ident.create_scoped ~scope name in + let decl = + Ctype.new_local_type ~loc Definition (Jkind.for_effect_arg id) + 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 sort_eff = Jkind.Sort.(of_const Const.for_effect) in + let cases, _ = + type_cases category new_env (simple_pat_mode Value.legacy) rhs_mode + ty_arg sort_eff ty_res_explained ~conts ~check_if_total:false loc + caselist + in + cases + end + (* Typing of let bindings *) and type_let ?check ?check_strict ?(force_toplevel = false) @@ -10825,21 +11545,29 @@ and type_let ?check ?check_strict ?(force_toplevel = false) let attrs_list = List.map (fun (attrs, _, _, _) -> attrs) spatl in let is_recursive = (rec_flag = Recursive) in - let (pat_list, exp_list, new_env, mvs, sorts, _pvs) = - with_local_level begin fun () -> + let (pat_list, exp_list, new_env, mvs, sorts, pvs) = + with_local_level_generalize begin fun () -> if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); let (pat_list, new_env, force, pvs, mvs), sorts = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let nvs, sorts = List.split (List.map (fun _ -> new_rep_var ~why:Let_binding ()) spatl) in let (pat_list, _new_env, _force, pvs, _mvs as res) = - with_local_level_if is_recursive (fun () -> + with_local_level_generalize_if is_recursive (fun () -> type_pattern_list Value existential_context env mutable_flag spatl nvs sorts allow_modules ~is_lpoly +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 ) ~post:(fun (_, _, _, pvs, _) -> iter_pattern_variables_type generalize pvs) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + ) ~post:(fun (_, _, _, pvs, _) -> + iter_pattern_variables_type generalize pvs) +======= + ) ~before_generalize:(fun (_, _, _, pvs, _) -> + iter_pattern_variables_type generalize pvs) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 in (* If recursive, first unify with an approximation of the expression *) @@ -10893,11 +11621,6 @@ and type_let ?check ?check_strict ?(force_toplevel = false) pat_list; res, sorts 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -10913,8 +11636,7 @@ and type_let ?check ?check_strict ?(force_toplevel = false) let mode_pat_typ_list = List.map (fun (m, pat) -> - let ty = pat.pat_type in - m, {pat with pat_type = instance ty}, ty) + m, {pat with pat_type = instance pat.pat_type}, pat.pat_type) pat_list in (* Only bind pattern variables after generalizing *) @@ -10937,8 +11659,7 @@ and type_let ?check ?check_strict ?(force_toplevel = false) match get_desc expected_ty 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_fixed ~keep_names:true tl ty) in let exp = @@ -10967,7 +11688,7 @@ and type_let ?check ?check_strict ?(force_toplevel = false) (mode_pat_typ_list, exp_list, new_env, mvs, sorts, List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs) end - ~post: begin fun (mode_pat_typ_list, exp_list, _, _, _, pvs) -> + ~before_generalize: begin fun (mode_pat_typ_list, exp_list, _, _, _, pvs) -> List.iter2 (fun (_, pat, _) (exp, _) -> if maybe_expansive exp then lower_contravariant env pat.pat_type) @@ -10986,12 +11707,6 @@ and type_let ?check ?check_strict ?(force_toplevel = false) pv_lpoly) ~f_mut:(unify_var env (newvar (Jkind.Builtin.any ~why:Dummy_jkind))) pvs; - (* update pattern variable jkind reasons *) - List.iter - (fun pv -> - Ctype.check_and_update_generalized_ty_jkind - ~name:pv.pv_id ~loc:pv.pv_loc pv.pv_type) - pvs; List.iter2 (fun (_, _, expected_ty) (exp, vars) -> match vars with @@ -11009,21 +11724,30 @@ and type_let ?check ?check_strict ?(force_toplevel = false) | Some vars -> if maybe_expansive exp then lower_contravariant env exp.exp_type; - generalize_and_check_univars env "definition" - exp expected_ty vars) + List.iter generalize (exp.exp_type :: expected_ty :: vars)) mode_pat_typ_list exp_list; - let update_exp_jkind (_, p, _) (exp, _) = - let pat_name = - match p.pat_desc with - Tpat_var { id; _ } -> Some id - | Tpat_alias { id; _ } -> Some id - | _ -> None in - Ctype.check_and_update_generalized_ty_jkind - ?name:pat_name ~loc:exp.exp_loc exp.exp_type - in - List.iter2 update_exp_jkind mode_pat_typ_list exp_list; end in + (* update pattern variable jkind reasons *) + List.iter + (fun pv -> + Ctype.check_and_update_generalized_ty_jkind + ~name:pv.pv_id ~loc:pv.pv_loc pv.pv_type) + pvs; + List.iter2 + (fun (_, _, expected_ty) (exp, vars) -> + Option.iter (check_univars env "definition" exp expected_ty) vars) + pat_list exp_list; + let update_exp_jkind (_, p, _) (exp, _) = + let pat_name = + match p.pat_desc with + Tpat_var { id; _ } -> Some id + | Tpat_alias { id; _ } -> Some id + | _ -> None in + Ctype.check_and_update_generalized_ty_jkind + ?name:pat_name ~loc:exp.exp_loc exp.exp_type + in + List.iter2 update_exp_jkind pat_list exp_list; let l = List.combine pat_list exp_list in let l = List.combine sorts l in let l = @@ -11208,9 +11932,19 @@ and type_andops env sarg sands expected_sort expected_ty = expected_sort, [] | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let op_path, op_desc, op_type, ty_arg, sort_arg, ty_rest, sort_rest, ty_result, op_result_sort = with_local_level_iter_if_principal begin fun () -> +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let op_path, op_desc, op_type, ty_arg, sort_arg, ty_rest, sort_rest, + ty_result, op_result_sort = + with_local_level_iter_if_principal begin fun () -> +======= + let op_path, op_desc, op_type, ty_arg, sort_arg, ty_rest, sort_rest, + ty_result, op_result_sort = + with_local_level_generalize_structure_if_principal begin fun () -> +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let op_path, op_desc = type_binding_op_ident env sop in let op_type = op_desc.val_type in let ty_arg, sort_arg = new_rep_var ~why:Function_argument () in @@ -11228,11 +11962,9 @@ and type_andops env sarg sands expected_sort 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, sort_arg, ty_rest, sort_rest, - ty_result, op_result_sort), - [ty_rest; ty_arg; ty_result]) + (op_path, op_desc, op_type, ty_arg, sort_arg, ty_rest, sort_rest, + ty_result, op_result_sort) end - ~post:generalize_structure in let let_arg, sort_let_arg, rest = loop env let_sarg rest sort_rest ty_rest @@ -11260,50 +11992,6 @@ and type_andops env sarg sands expected_sort expected_ty = in let_arg, sort_let_arg, List.rev rev_ands -(* Can be re-inlined when we upstream immutable arrays *) -and type_generic_array - ~loc - ~env - ~(expected_mode : expected_mode) - ~ty_expected - ~explanation - ~mutability - ~attributes - sargl - = - let alloc_mode, array_mode = register_allocation ~loc expected_mode in - let type_ = - if Types.is_mutable mutability then Predef.type_array - else Predef.type_iarray - in - let modalities = Typemode.mutable_modalities mutability in - let is_contained_by : Mode.Hint.is_contained_by = - {containing = Array Modality; container = (loc, Expression)} - in - let argument_mode = - mode_is_contained_by is_contained_by ~modalities array_mode - in - let jkind, elt_sort = - Jkind.for_array_element_sort ~level:(Ctype.get_current_level ()) - in - let ty = newgenvar jkind in - let to_unify = type_ ty in - with_explanation explanation (fun () -> - unify_exp_types loc env to_unify (generic_instance ty_expected)); - check_construct_mutability ~loc ~env mutability ~ty array_mode; - let argument_mode = expect_mode_cross env ty argument_mode in - let argl = - List.map - (fun sarg -> type_expect env argument_mode sarg (mk_expected ty)) - sargl - in - re { - exp_desc = Texp_array (mutability, elt_sort, argl, alloc_mode); - exp_loc = loc; exp_extra = []; - exp_type = instance ty_expected; - exp_attributes = attributes; - exp_env = env } - and type_expect_mode ~loc ~env ~(modes : Alloc.Const.Option.t) expected_mode = let min = Alloc.Const.Option.value ~default:Alloc.Const.min modes |> Const.alloc_as_value in let max = Alloc.Const.Option.value ~default:Alloc.Const.max modes |> Const.alloc_as_value in @@ -11567,7 +12255,7 @@ and type_comprehension_expr ~loc ~env ~ty_expected ~attributes cexpr = ~why:Jkind.History.Array_comprehension_element in let element_ty = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let element_ty = newvar jkind in unify_exp_types loc @@ -11575,7 +12263,7 @@ and type_comprehension_expr ~loc ~env ~ty_expected ~attributes cexpr = (instance (container_type element_ty)) (instance ty_expected); element_ty - end ~post:generalize_structure + end in let new_env, comp_clauses = (* To understand why we don't provide modes here, see "What modes should @@ -11701,7 +12389,7 @@ and type_comprehension_iterator let penv = Pattern_env.make env ~equations_scope:(get_current_level ()) - ~allow_recursive_equations:false + ~in_counterexample:false in let pattern = (* To understand why we can currently only provide [global] bindings for @@ -11841,12 +12529,20 @@ let type_let existential_ctx env mutable_flag rec_flag spat_sexp_list = let type_expression env jkind sexp = let exp = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> Typetexp.TyVarEnv.reset (); let expected = mk_expected (newvar jkind) in type_expect env mode_toplevel_expression sexp expected end +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 ~post:(may_lower_contravariant_then_generalize env) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + ~post:(may_lower_contravariant_then_generalize env) +======= + ~before_generalize:(fun exp -> + may_lower_contravariant env exp; + generalize exp.exp_type) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 in let exp = match sexp.pexp_desc with @@ -11873,18 +12569,19 @@ let type_expression env sexp = (* Error report *) -let spellcheck ppf unbound_name valid_names = - Misc.did_you_mean ppf (fun () -> - Misc.spellcheck valid_names unbound_name - ) +let spellcheck unbound_name valid_names = + Misc.did_you_mean (Misc.spellcheck valid_names unbound_name) -let spellcheck_idents ppf unbound valid_idents = - spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) +let spellcheck_idents unbound valid_idents = + spellcheck (Ident.name unbound) (List.map Ident.name valid_idents) open Format_doc module Fmt = Format_doc -let longident = Printtyp.longident +module Printtyp = Printtyp.Doc + +let quoted_longident = Style.as_inline_code Pprintast.Doc.longident +let quoted_constr = Style.as_inline_code Pprintast.Doc.constr let tuple_component ~print_article ppf lbl = let article = @@ -11905,12 +12602,50 @@ 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` *) (* CR layouts v2.5: Should we add a case here for float#? Test it, if so. *) 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 @@ -11950,17 +12685,21 @@ let report_partial_application = function match get_desc tr.Errortrace.got.Errortrace.expanded with | Tarrow _ -> [ Location.msg - "@[@{Hint@}: This function application is partial,@ \ - maybe some arguments are missing.@]" ] + "@[@{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 (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 @@ -12054,17 +12793,10 @@ let report_type_expected_explanation_opt 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 = - match Typedtree.nominal_exp_doc Printtyp.longident funct with - | None -> Fmt.fprintf ppf "This function" - | Some name -> - Fmt.fprintf ppf "The function %a" - (Style.as_inline_code Fmt.pp_doc) name - let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc ~extra_arg_loc ~returns_unit loc = let open Location in @@ -12084,16 +12816,20 @@ let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc 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 has type@ %a@]\ + errorf ~loc:app_loc + "@[@[<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 + ~sub:( + let semicolon = + if returns_unit then + [msg ~loc:tail_loc "@{Hint@}: Did you forget a ';'?"] + else [] + in + semicolon @ + [msg ~loc:extra_arg_loc "This extra argument is not expected."] + ) let msg = Fmt.doc_printf @@ -12103,10 +12839,10 @@ let report_error ~loc env = 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 + quoted_constr lid expected provided | Constructor_labeled_arg -> Location.errorf ~loc - "Constructors cannot have labeled arguments. \ + "Constructors cannot have labeled arguments.@ \ Consider using an inline record instead." | Partial_tuple_pattern_bad_type -> Location.errorf ~loc @@ -12122,8 +12858,7 @@ let report_error ~loc env = (* We only hint if the missing component is labeled. This is unlikely to be a correct fix for traditional tuples. *) match lbl with - | Some _ -> fprintf ppf "@ Hint: use %a to ignore some components." - Style.inline_code ".." + | Some _ -> fprintf ppf "@ Hint: use .. to ignore some components." | None -> () in Location.errorf ~loc @@ -12136,7 +12871,7 @@ let report_error ~loc env = report_unification_error ~loc env err (msg "The %s field %a@ belongs to the type" (record_form_to_string record_form) - (Style.as_inline_code longident) lid) + quoted_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 @@ -12154,21 +12889,18 @@ let report_error ~loc env = "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 - ) () + Location.aligned_error_hint ~loc + "@{Variable @}%a must occur on both sides of this %a pattern" + Style.inline_code (Ident.name id) + Style.inline_code "|" + (spellcheck_idents 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 "This expression has 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 }; @@ -12258,51 +12990,61 @@ let report_error ~loc env = (record_form_to_string record_form) print_labels labels | Label_not_mutable lid -> Location.errorf ~loc "The record field %a is not mutable" - (Style.as_inline_code longident) lid + quoted_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 - )) () + Printtyp.wrap_printing_env ~error:true env (fun () -> + let { ty; explanation } = ty_expected in + if Path.is_constructor_typath type_path then + Location.aligned_error_hint ~loc + "@{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 + (spellcheck name.txt valid_names) + else + let intro ppf = Fmt.fprintf ppf "@[%s type@;<1 2>%a%a@]@\n" + eorp (Style.as_inline_code Printtyp.type_expr) ty + pp_doc (report_type_expected_explanation_opt explanation) + in + let main = + Fmt.doc_printf "@{There is no %s @}%a within type %a" + (Datatype_kind.label_name kind) + Style.inline_code name.txt + (Style.as_inline_code Printtyp.type_path) type_path + in + let main, sub = + match spellcheck name.txt valid_names with + | None -> main, [] + | Some hint -> + let main, hint = Misc.align_error_hint ~main ~hint in + main, [Location.mknoloc hint] + in + Location.errorf ~loc ~sub "%t%a" intro pp_doc main + ) | 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 () -> - Printtyp.report_ambiguous_type_error ppf env tp tpl + let pr = match kind with + | Datatype_kind.Record | Datatype_kind.Record_unboxed_product -> + quoted_longident + | Datatype_kind.Variant -> quoted_constr + in + Location.errorf ~loc "%t" (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) + name pr lid type_name) (msg "The %s %a@ belongs to one of the following %s types:" - name (Style.as_inline_code longident) lid type_name) + name pr 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 - ) () + Location.errorf ~loc + "This expression is not an object;@ it has type %a%a" + (Style.as_inline_code Printtyp.type_expr) ty + pp_doc (report_type_expected_explanation_opt explanation) | Non_value_object (err, explanation) -> Location.error_of_printer ~loc (fun ppf () -> fprintf ppf "Object types must have layout value.@ %a%a" @@ -12319,38 +13061,44 @@ let report_error ~loc env = err) () | 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 - )) () + Printtyp.wrap_printing_env ~error:true env (fun () -> + let intro ppf = + Fmt.fprintf ppf + "@[@[This expression has type@;<1 2>%a@]@,@]" + (Style.as_inline_code Printtyp.type_expr) ty + in + let main = + Fmt.doc_printf "@{It has no method @}%a" + Style.inline_code me + in + let main, sub = + match Option.bind valid_methods (spellcheck me) with + | None -> main, [] + | Some hint -> + let main, hint = Misc.align_error_hint ~main ~hint in + main, [Location.mknoloc hint] + in + Location.errorf ~sub ~loc "%t%a" intro pp_doc main + ) | 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; - ) () + Location.aligned_error_hint ~loc + "@{This expression has no method @}%a" + Style.inline_code me + (spellcheck me valid_methods) | Virtual_class cl -> - Location.errorf ~loc "Cannot instantiate the virtual class %a" - (Style.as_inline_code longident) cl + Location.errorf ~loc "Cannot instantiate the virtual class %a" + quoted_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; - ) () + Location.aligned_error_hint ~loc + "@{Unbound instance variable @}%a" Style.inline_code var + (spellcheck var valid_vars) | Instance_variable_not_mutable v -> - Location.errorf ~loc "The instance variable %a is not mutable" - Style.inline_code 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 () -> - Printtyp.Subtype.report_error ppf env err "is not a subtype of" - ) () + Location.errorf ~loc "%t" (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" @@ -12359,23 +13107,26 @@ let report_error ~loc env = "The instance variable %a is overridden several times" Style.inline_code v | Coercion_failure (ty_exp, err, b) -> - let intro = - let ty_exp = Printtyp.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 - Location.error_of_printer ~loc (fun ppf () -> - Printtyp.report_unification_error ppf env err + 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 + Location.errorf ~loc "%t" (fun ppf -> + 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)" - ) () + (Fmt.Doc.msg "but is here used with type") + ) + ~sub:( + if not b then [] else + [ Location.msg "This simple coercion was not fully general"; + Location.msg + "@{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,@ \ @@ -12432,7 +13183,7 @@ let report_error ~loc env = (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 + quoted_longident lid (Style.as_inline_code Printtyp.type_expr) ty | Private_constructor (constr, ty) -> Location.errorf ~loc @@ -12441,7 +13192,7 @@ let report_error ~loc env = (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 + quoted_longident lid | Incoherent_label_order -> Location.errorf ~loc "This function is applied to arguments@ \ @@ -12473,7 +13224,7 @@ let report_error ~loc env = | At_toplevel -> dprintf "Existential types are not allowed in toplevel bindings" | In_group -> - dprintf "Existential types are not allowed in %a bindings" + dprintf "Existential types are not allowed in grouped (%a) bindings" Style.inline_code "let ... and ..." | In_rec -> dprintf "Existential types are not allowed in recursive bindings" @@ -12518,6 +13269,12 @@ let report_error ~loc env = 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 \ @@ -12562,25 +13319,25 @@ let report_error ~loc env = let name = Language_extension.to_string ext in Location.errorf ~loc "Extension %s must be enabled to use this feature." name - | Atomic_in_pattern lid -> - Location.errorf ~loc - "Atomic fields (here %a) are forbidden in patterns,@ \ - as it is difficult to reason about when the atomic read@ \ - will happen during pattern matching:@ the field may be read@ \ - zero, one or several times depending on the patterns around it." - (Style.as_inline_code longident) lid + | Modalities_on_atomic_field lid -> + Location.errorf ~loc + "Modalities are not allowed on fields given to %a (here, %a)" + Style.inline_code "[%atomic.loc]" + quoted_longident lid | Invalid_atomic_loc_payload -> Location.errorf ~loc "Invalid %a payload, a record field access is expected." Style.inline_code "[%atomic.loc]" | Label_not_atomic lid -> Location.errorf ~loc "The record field %a is not atomic" - (Style.as_inline_code longident) lid - | Modalities_on_atomic_field lid -> - Location.errorf ~loc - "Modalities are not allowed on fields given to %a (here, %a)" - Style.inline_code "[%atomic.loc]" - (Style.as_inline_code longident) lid + quoted_longident lid + | Atomic_in_pattern lid -> + Location.errorf ~loc + "Atomic fields (here %a) are forbidden in patterns,@ \ + as it is difficult to reason about when the atomic read@ \ + will happen during pattern matching:@ the field may be read@ \ + zero, one or several times depending on the patterns around it." + quoted_longident lid | Literal_overflow ty -> Location.errorf ~loc "Integer literal exceeds the range of representable integers of type %a" @@ -12648,6 +13405,20 @@ let report_error ~loc env = "@[<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@]" @@ -12695,6 +13466,14 @@ let report_error ~loc env = which is not a %s type." (Style.as_inline_code Printtyp.type_expr) ty (record_form_to_string record_form) + | Repeated_tuple_exp_label l -> + Location.errorf ~loc + "@[This tuple expression has two labels named %a@]" + Style.inline_code l + | Repeated_tuple_pat_label l -> + Location.errorf ~loc + "@[This tuple pattern has two labels named %a@]" + Style.inline_code l | Expr_record_type_has_wrong_boxing (P record_form, ty) -> let expected, actual = match record_form with @@ -12713,7 +13492,7 @@ let report_error ~loc env = "The index preceding this unboxed access has element type %a,@ \ which is not an unboxed record with field %a." (Style.as_inline_code Printtyp.type_expr) prev_el_type - (Style.as_inline_code longident) lid + quoted_longident lid end | Block_access_record_unboxed -> Location.error ~loc @@ -12730,7 +13509,7 @@ let report_error ~loc env = | Block_index_modality_mismatch { mut; err } -> let step, Modality.Error(ax, { left; right }) = err in let print_modality_doc id = - Printtyp.modality ~id:(fun ppf -> Format_doc.pp_print_string ppf id) ax + Printtyp.modality ~id:(fun ppf () -> Format_doc.pp_print_string ppf id) ax in let expected, actual = match step with | Left_le_right -> right, left @@ -12768,7 +13547,7 @@ let report_error ~loc env = assert (List.length sub = 0); [ Location.msg "@[Hint: All arguments of the constructor %a@\n\ must cross this axis to use it in this position.@]" - (Style.as_inline_code longident) name ] + quoted_longident name ] | Application _ | Other -> sub in Location.error_of_printer ~loc ~sub (fun ppf e -> diff --git a/src/ocaml/typing/typecore.mli b/src/ocaml/typing/typecore.mli index 2244c5818..b6cf2ed24 100644 --- a/src/ocaml/typing/typecore.mli +++ b/src/ocaml/typing/typecore.mli @@ -60,17 +60,22 @@ 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_uid: Uid.t; pv_mode: Mode.Value.l; - pv_kind: value_kind; + pv_value_kind: value_kind; pv_type: type_expr; pv_loc: Location.t; - pv_as_var: bool; + pv_kind: pattern_variable_kind; pv_attributes: Typedtree.attributes; pv_sort: Jkind.Sort.t; + pv_uid: Uid.t; pv_lpoly: Types.Lpoly.t; (** Not yet determined; gets determined during generalization in [type_let]. *) @@ -169,9 +174,14 @@ val type_option_some: val type_option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression val generalizable: int -> type_expr -> bool +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 val generalize_structure_exp: Typedtree.expression -> unit type delayed_check val delayed_checks: delayed_check list ref +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +val generalize_structure_exp: Typedtree.expression -> unit +======= +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 val reset_delayed_checks: unit -> unit val force_delayed_checks: unit -> unit @@ -205,15 +215,17 @@ type unsupported_stack_allocation = | List_comprehension | Array_comprehension +type existential_binding = + | Bind_already_bound + | Bind_not_in_scope + | Bind_non_locally_abstract + type mode_mismatch_kind = Parameter | Return type error = | Constructor_arity_mismatch of Longident.t * int * int - | Constructor_labeled_arg - | Partial_tuple_pattern_bad_type - | Extra_tuple_label of string option * type_expr - | Missing_tuple_label of string option * type_expr - | Label_mismatch of record_form_packed * Longident.t * Errortrace.unification_error + | Label_mismatch of + Data_types.record_form_packed * Longident.t * Errortrace.unification_error | Pattern_type_clash : Errortrace.unification_error * Parsetree.pattern_desc option -> error @@ -222,7 +234,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; @@ -237,7 +249,7 @@ type error = } | Apply_wrong_label of arg_label * type_expr * bool | Label_multiply_defined of string - | Label_missing of record_form_packed * Ident.t list + | Label_missing of Data_types.record_form_packed * Ident.t list | Label_not_mutable of Longident.t | Wrong_name of string * type_expected * wrong_name | Name_type_mismatch of @@ -251,7 +263,7 @@ type error = | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr - | Private_constructor of constructor_description * type_expr + | Private_constructor of Data_types.constructor_description * type_expr | Unbound_instance_variable of string * string list | Instance_variable_not_mutable of string | Not_subtype of Errortrace.Subtype.error @@ -282,20 +294,22 @@ 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 | Invalid_extension_constructor_payload | Not_an_extension_constructor + | Invalid_atomic_loc_payload + | Label_not_atomic of Longident.t + | Atomic_in_pattern of Longident.t | Probe_format | Probe_name_format of string | Probe_name_undefined of string (* [imported CR removed] *) | Probe_is_enabled_format | Extension_not_enabled : _ Language_extension.t -> error - | Atomic_in_pattern of Longident.t - | Invalid_atomic_loc_payload - | Label_not_atomic of Longident.t | Modalities_on_atomic_field of Longident.t | Literal_overflow of string | Unknown_literal of string * char @@ -312,11 +326,20 @@ 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 - | Wrong_expected_record_boxing of wrong_kind_context * record_form_packed * type_expr - | Expr_not_a_record_type of record_form_packed * type_expr - | Expr_record_type_has_wrong_boxing of record_form_packed * type_expr + | Expr_not_a_record_type of Data_types.record_form_packed * type_expr + | Constructor_labeled_arg + | Partial_tuple_pattern_bad_type + | Extra_tuple_label of string option * type_expr + | Missing_tuple_label of string option * type_expr + | Repeated_tuple_exp_label of string + | Repeated_tuple_pat_label of string + | Wrong_expected_record_boxing of + wrong_kind_context * Data_types.record_form_packed * type_expr + | Expr_record_type_has_wrong_boxing of + Data_types.record_form_packed * type_expr | Invalid_unboxed_access of { prev_el_type : type_expr; ua : Parsetree.unboxed_access } | Block_access_record_unboxed @@ -379,8 +402,8 @@ 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 + (Env.t -> Parsetree.module_expr -> package -> + Typedtree.module_expr * package) ref val constant: Parsetree.constant -> (Typedtree.constant, error) result diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index 5ee04771e..cc9b370d9 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -27,6 +27,7 @@ open Asttypes open Parsetree open Primitive open Types +open Data_types open Typetexp module String = Misc.String @@ -424,6 +425,8 @@ in cannot delete it. We haven't separately implemented a fix for ocamlc looping, so we probably have the same issue described in that PR, but users haven't reported it. + rtjoa: It was re-added upsteram in + https://github.com/ocaml/ocaml/pull/13510 *) (* [update_type] performs step 3 of the process described in the comment in [enter_type]: We unify the manifest of each type with the definition of that @@ -443,30 +446,38 @@ in that... These circular types are ruled out just after [update_type] in [transl_type_decl], and then we perform the delayed checks. *) + +(* Update a temporary definition to share recursion *) let update_type temp_env env id loc = + let unify_manifest env type_manifest path type_params = + match type_manifest with + | Some ty -> + (* Since this function is called after generalizing declarations, ty is at + the generic level. Since we need to keep possible sharings in recursive + type definitions, unify without instantiating, but generalize again + after unification. *) + let delayed_jkind_checks, _ = + Ctype.with_local_level_generalize (fun () -> + try + let new_ty = Ctype.newconstr path type_params in + Ctype.unify_delaying_jkind_checks env new_ty ty, new_ty + with Ctype.Unify err -> + raise (Error(loc, Type_clash (env, err)))) + ~before_generalize:(fun (_, new_ty) -> Ctype.generalize new_ty) + in + delayed_jkind_checks + | None -> Misc.fatal_error "Typedecl.update_type" + in let path = Path.Pident id in let decl = Env.find_type path temp_env in - try - let checks = - match decl.type_manifest with - | Some ty -> - Ctype.unify_delaying_jkind_checks - env (Ctype.newconstr path decl.type_params) ty - | None -> Misc.fatal_error "Typedecl.update_type" + let checks = unify_manifest env decl.type_manifest path decl.type_params in + match decl.type_unboxed_version with + | None -> checks + | Some { type_manifest; type_params; _ } -> + let checks_from_unboxed_version = + unify_manifest env type_manifest (Path.unboxed_version path) type_params in - match decl.type_unboxed_version with - | None -> - checks - | Some { type_manifest = Some ty; type_params; _ } -> - let checks_from_unboxed_version = - Ctype.unify_delaying_jkind_checks env - (Ctype.newconstr (Path.unboxed_version path) type_params) ty - in - checks @ checks_from_unboxed_version - | Some { type_manifest = None; _ } -> - Misc.fatal_error "Typedecl.update_type" - with Ctype.Unify err -> - raise (Error(loc, Type_clash (env, err))) + checks @ checks_from_unboxed_version (* Determine if a type's values are represented by floats at run-time. *) (* CR layouts v2.5: Should we check for unboxed float here? Is a record with all @@ -592,7 +603,7 @@ let transl_labels (type rep) ~(record_form : rep record_form) ~new_var_jkind let cty = transl_simple_type ~new_var_jkind env ?univars ~closed Mode.Alloc.Const.legacy 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_modalities = modalities; ld_type = cty; ld_loc = loc; ld_attributes = attrs} @@ -682,13 +693,9 @@ let make_constructor then widen so as to not introduce any new constraints *) (* narrow and widen are now invoked through with_local_scope *) TyVarEnv.with_local_scope begin fun () -> - let closed = - match svars with - | [] -> false - | _ -> true - in + let closed = svars <> [] in let targs, tret_type, args, ret_type, _univars = - Ctype.with_local_level_if closed begin fun () -> + Ctype.with_local_level_generalize_if closed begin fun () -> TyVarEnv.reset (); let univar_list = TyVarEnv.make_poly_univars_jkinds env @@ -723,7 +730,7 @@ let make_constructor end; (targs, tret_type, args, ret_type, univar_list) end - ~post: begin fun (_, _, args, ret_type, univars) -> + ~before_generalize: 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 @@ -747,7 +754,7 @@ let verify_unboxed_attr unboxed_attr sdecl = | [] -> bad "it has no fields" | _::_::_ -> bad "it has more than one field" | [{pld_mutable = Mutable}] -> bad "it is mutable" - | [{pld_mutable = Immutable}] -> () + | [{pld_mutable = Immutable; _}] -> () end | Ptype_record_unboxed_product _ -> bad "[@@unboxed] may not be used on unboxed records" @@ -947,15 +954,14 @@ let transl_declaration env sdecl (id, uid) = verify_unboxed_attr unboxed_attr sdecl; let transl_type sty = let cty = - Ctype.with_local_level begin fun () -> + (* generalize_structure is necessary so that copying during instantiation + traverses inside of any type constructors in the [with]-bound. It's + also necessary because the variables here are at generic level, and so + any containers of them should be, too! *) + Ctype.with_local_level_generalize_structure begin fun () -> Typetexp.transl_simple_type env ~new_var_jkind:Any ~closed:true Mode.Alloc.Const.legacy sty end - (* This call to [generalize_structure] is necessary so that copying - during instantiation traverses inside of any type constructors in the - [with]-bound. It's also necessary because the variables here are at - generic level, and so any containers of them should be, too! *) - ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) in cty.ctyp_type (* CR layouts v2.8: Do this more efficiently. Or probably add with-kinds to Typedtree. Internal ticekt 4435. *) @@ -1053,8 +1059,8 @@ 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_current_unit ()); cd_vars = tvars; - cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); cd_args = targs; cd_res = tret_type; cd_loc = scstr.pcd_loc; @@ -1973,6 +1979,7 @@ let update_constructor_representation raise (Error (loc, Illegal_mixed_product Extension_constructor)); Constructor_mixed shape +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let add_types_to_env ~shapes decls env = match shapes with @@ -1987,6 +1994,23 @@ let add_types_to_env ~shapes decls env = add_type ~long_path:false ~check:true ~shape id decl env) decls shapes env +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + +let add_types_to_env ~shapes decls env = + match shapes with + | None -> + List.fold_right + (fun (id, decl) env -> + add_type ~check:true id decl env) + decls env + | Some shapes -> + List.fold_right2 + (fun (id, decl) shape env -> + add_type ~check:true ~shape id decl env) + decls shapes env + +======= +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* This function updates jkind stored in kinds with more accurate jkinds. It is called after the circularity checks and the delayed jkind checks have happened, so we can fully compute jkinds of types. @@ -3024,17 +3048,17 @@ 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'; type_ikind = Types.ikinds_todo (Format_doc.asprintf "name_recursion path=%a" Path.print (Path.Pident id)) } -else decl + else decl | _ -> decl let name_recursion_decls sdecls decls = @@ -3055,7 +3079,6 @@ let check_redefined_unit (td: Parsetree.type_declaration) = | _ -> () - (* Note [Quality of jkinds during inference] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3181,6 +3204,19 @@ let normalize_decl_jkinds env decls = env decls +let add_types_to_env ~shapes decls env = + match shapes with + | None -> + List.fold_right + (fun (id, decl) env -> + add_type ~check:true id decl env) + decls env + | Some shapes -> + 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; @@ -3207,21 +3243,24 @@ 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, new_env, delayed_jkind_checks = - Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> + let tdecls, decls, temp_env, new_env = + Ctype.with_local_level_generalize + ~before_generalize:(fun (_, decls, _, _) -> + List.iter (fun (_, decl) -> generalize_decl decl) decls) + 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 + Warnings.(is_active (Unused_type_declaration ("", Declaration))) in let ids_slots (id, _uid as ids) = match rec_flag with | Asttypes.Recursive when warn_unused -> @@ -3265,6 +3304,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 ~shapes:None decls env in +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (* Update stubs *) let delayed_jkind_checks = match rec_flag with @@ -3277,6 +3317,22 @@ let transl_type_decl env rec_flag sdecl_list = ids_list sdecl_list in ((tdecls, decls, new_env, delayed_jkind_checks), List.map snd decls) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + (* Update stubs *) + let delayed_jkind_checks = + match rec_flag with + | Asttypes.Nonrecursive -> [] + | Asttypes.Recursive -> + List.map2 + (fun (id, _) sdecl -> + update_type temp_env new_env id sdecl.ptype_loc, + sdecl.ptype_loc) + ids_list sdecl_list + in + ((tdecls, decls, new_env, delayed_jkind_checks), List.map snd decls) +======= + (tdecls, decls, temp_env, new_env) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 end in (* Check for ill-formed abbrevs *) @@ -3318,6 +3374,17 @@ let transl_type_decl env rec_flag sdecl_list = (Path.Pident id) decl to_check) decls; + (* Update temporary definitions (for well-founded recursive types) *) + let delayed_jkind_checks = + match rec_flag with + | Asttypes.Nonrecursive -> [] + | Asttypes.Recursive -> + List.map2 + (fun (id, _) sdecl -> + update_type temp_env new_env id sdecl.ptype_loc, + sdecl.ptype_loc) + ids_list sdecl_list + in (* Now that we've ruled out ill-formed types, we can perform the delayed jkind checks *) List.iter (fun (checks,loc) -> @@ -3472,8 +3539,8 @@ let transl_extension_constructor ~scope env type_path type_params (* Remove "_" names from parameters used in the constructor *) if not cdescr.cstr_generalized then begin let vars = - Ctype.free_variables - (Btype.newgenty (Ttuple (List.map (fun {Types.ca_type=t; _} -> None, t) args))) + Ctype.free_variables_list + (List.map (fun {Types.ca_type=t; _} -> t) args) in List.iter (fun ty -> @@ -3494,12 +3561,13 @@ let transl_extension_constructor ~scope env type_path type_params | Ok _ -> () | Error e -> raise (Error (lid.loc, Constructor_submode_failed e))); (* 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_res_type_path = Data_types.cstr_res_type_path cdescr in + let cstr_res_type_params = + (Env.find_type cstr_res_type_path env).type_params in let cstr_types = (Btype.newgenty - (Tconstr(cstr_type_path, cstr_type_params, ref Mnil))) - :: cstr_type_params + (Tconstr(cstr_res_type_path, cstr_res_type_params, ref Mnil))) + :: cstr_res_type_params in let ext_types = (Btype.newgenty @@ -3508,7 +3576,7 @@ let transl_extension_constructor ~scope env type_path 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))); + Rebind_mismatch(lid.txt, cstr_res_type_path, type_path))); (* Disallow rebinding private constructors to non-private *) begin match cdescr.cstr_private, priv with @@ -3555,7 +3623,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 = @@ -3629,7 +3697,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 type_path styext.ptyext_params in let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in @@ -3643,7 +3711,7 @@ let transl_type_extension extend env loc styext = in (ttype_params, type_params, constructors) end - ~post: begin fun (_, type_params, constructors) -> + ~before_generalize: begin fun (_, type_params, constructors) -> (* Generalize types *) List.iter Ctype.generalize type_params; List.iter @@ -3701,12 +3769,12 @@ 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) -> + ~before_generalize: 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 @@ -4267,7 +4335,7 @@ let transl_value_decl env loc ~modal ~why valdecl = Types.val_loc = loc; val_attributes = valdecl.pval_attributes; val_modalities; val_zero_alloc = zero_alloc; - 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)) @@ -4314,7 +4382,7 @@ let transl_value_decl env loc ~modal ~why valdecl = Types.val_loc = loc; val_attributes = valdecl.pval_attributes; val_modalities; val_zero_alloc = Zero_alloc.default; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); } in let (id, newenv) = @@ -4354,7 +4422,7 @@ let transl_value_decl env ~modal ~why 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]. *) @@ -4419,7 +4487,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env if arity_ok && not sig_decl_abstract && sdecl.ptype_private = Private then Location.deprecated loc "spurious use of private"; - let type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let type_unboxed_version = match get_desc man with | Tconstr (path, args, _) -> @@ -4491,7 +4559,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env type_loc = loc; type_attributes = sdecl.ptype_attributes; type_unboxed_default; - type_uid; + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); type_unboxed_version; } in @@ -4574,7 +4642,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env typ_jkind_annotation = Jkind.get_annotation type_jkind; } end - ~post:(fun ttyp -> generalize_decl ttyp.typ_type) + ~before_generalize:(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., @@ -4597,7 +4665,7 @@ let transl_package_constraint ~loc ty = type_loc = loc; type_attributes = []; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); type_unboxed_version = None; } @@ -4605,7 +4673,7 @@ let transl_package_constraint ~loc ty = let abstract_type_decl ~injective ~jkind ~params = let arity = List.length params in - Ctype.with_local_level ~post:generalize_decl begin fun () -> + Ctype.with_local_level_generalize ~before_generalize:generalize_decl begin fun () -> let params = List.map Ctype.newvar params in { type_params = params; type_arity = arity; @@ -4700,7 +4768,7 @@ let transl_jkind_decl env { pjkind_name; pjkind_manifest; pjkind_attributes; pjkind_loc=loc } = let scope = Ctype.create_scope () in let id = Ident.create_scoped ~scope pjkind_name.txt in - let uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let context = Jkind.History.Jkind_declaration (Pident id) in let jkind_manifest = Option.map (fun annot -> Jkind.Const.of_annotation env ~context annot) @@ -4736,7 +4804,7 @@ let transl_jkind_constraint id env orig_decl new_decl = considerations that require us to re-check the declaration in the inner environment (e.g., [constraint]s) do not occur for lr-jkinds. *) Env.mark_jkind_used orig_decl.jkind_uid; - let jkind_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let jkind_uid = Uid.mk ~current_unit:(Env.get_current_unit ()) in let context = Jkind.History.Jkind_declaration (Pident id) in let jka = match new_decl.pjkind_manifest with @@ -4764,23 +4832,24 @@ let transl_jkind_constraint id env orig_decl new_decl = 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 = @@ -4798,7 +4867,8 @@ let explain_unbound_single ppf tv ty = (fun (_l,f) -> match row_field_repr f with Rpresent (Some t) -> t | Reither (_,[t],_) -> t - | Reither (_,tl,_) -> Btype.newgenty (Ttuple (List.map (fun e -> None, e) tl)) + | Reither (_,tl,_) -> + Btype.newgenty (Ttuple (List.map (fun e -> None, e) tl)) | _ -> Btype.newgenty (Ttuple[])) "case" (fun (lab,_) -> "`" ^ lab ^ " of ") | _ -> trivial ty @@ -4820,7 +4890,7 @@ module Reaching_path = struct Fmt.(pp_print_list ~pp_sep:comma) pp_step ppf reaching_path let pp_colon ~pp_root ~pp_body ppf path = - Fmt.fprintf ppf ":@;<1 2>@[%a@]" (pp ~pp_root ~pp_body) path + Fmt.fprintf ppf ":@\n @[%a@]" (pp ~pp_root ~pp_body) path (* Type-specific operations *) @@ -4837,7 +4907,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 @@ -4846,13 +4916,13 @@ 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 let pp_type_colon = pp_colon - ~pp_root:Printtyp.prepared_type_expr - ~pp_body:Printtyp.prepared_type_expr + ~pp_root:Out_type.prepared_type_expr + ~pp_body:Out_type.prepared_type_expr (* Kind-specific operations *) @@ -4902,287 +4972,337 @@ let report_jkind_mismatch_due_to_bad_inference ppf env ty violation loc = ~offender:(fun ppf -> Printtyp.type_expr ppf ty) env) violation -let quoted_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty -let report_error_doc 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 quoted_constr = Style.as_inline_code Pprintast.Doc.constr + +let explain_unbounded ty decl ppf = + 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 (List.map (fun t -> None, t) 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_record_unboxed_product (tl, _, _), _ -> + explain_unbound ppf ty tl (fun l -> l.Types.ld_type) + "unboxed record field" (fun l -> Ident.name l.Types.ld_id ^ ": ") + | Type_abstract _, Some ty' -> + explain_unbound_single ppf ty ty' + | _ -> () + +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 + +let variance_context = + let open Typedecl_variance in + function + | Type_declaration { id ; decl ; unboxed_version } -> + let pre, post = + if unboxed_version then + (* Unexpected; errors in the unboxed version should have also + been present and reported first for the boxed version. *) + "In the unboxed version of the definition", + "@ Please report this error to the Jane Street compilers team." + else + "In the definition", "" + in + Out_type.add_type_declaration_to_preparation id decl; + Format_doc.doc_printf "%s@\n @[%a@]@\n%s" + pre + (Style.as_inline_code @@ Out_type.prepared_type_declaration id) + decl + post + | Gadt_constructor c -> + Out_type.add_constructor_to_preparation c; + doc_printf "In the GADT constructor@\n @[%a@]@\n" + (Style.as_inline_code Out_type.prepared_constructor) + c + | Extension_constructor (id, e) -> + Out_type.add_extension_constructor_to_preparation e; + doc_printf "In the extension constructor@\n @[%a@]@\n" + (Out_type.prepared_extension_constructor id) + e + +let variance_variable_error ~v1 ~v2 variable error ppf = + let open Typedecl_variance in + match error with + | Variance_not_reflected -> + fprintf ppf + "the type variable@ %a@ has a variance that@ \ + is not reflected by its occurrence in type parameters.@ \ + It was expected to be %s,@ but it is %s." + (Style.as_inline_code Out_type.prepared_type_expr) variable + (variance v2) (variance v1) + | No_variable -> + fprintf ppf + "the type variable@ %a@ cannot be deduced@ \ + from the type parameters." + (Style.as_inline_code Out_type.prepared_type_expr) variable + | Variance_not_deducible -> + fprintf ppf + "the type variable@ %a@ has a variance that@ \ + cannot be deduced from the type parameters.@ \ + It was expected to be %s,@ but it is %s." + (Style.as_inline_code Out_type.prepared_type_expr) variable + (variance v2) (variance v1) + +let variance_error ~loc ~v1 ~v2 = + let open Typedecl_variance in + function + | Variance_variable_error { error; variable; context } -> + (* CR dkalinichenko: OxCaml changes the [Ident_names] map from + stateless to stateful. Normally, it would be reset by + [Printtyp.wrap_printing_env], but [Variance_variable_error] + lacks the [env]. Therefore, we clear [Ident_names] manually. + It'd be good to come up with a better solution. *) + Out_type.Ident_names.reset (); + Out_type.prepare_for_printing [ variable ]; + let intro = variance_context context in + Location.errorf ~loc "%a%t" pp_doc intro + (variance_variable_error ~v1 ~v2 variable error) + | Variance_not_satisfied n -> + Location.errorf ~loc + "In this definition, expected parameter@ \ + variances are not satisfied.@ \ + The %d%s type parameter was expected to be %s,@ but it is %s." + n (Misc.ordinal_suffix n) + (variance v2) (variance v1) + +let report_error ~loc = function | Repeated_parameter -> - fprintf ppf "A type parameter occurs several times" + Location.errorf ~loc "A type parameter occurs several times" | Duplicate_constructor s -> - fprintf ppf "Two constructors are named %a" Style.inline_code s + Location.errorf ~loc "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" + Location.errorf ~loc + "Too many non-constant constructors@ \ + -- maximum is %i non-constant constructors@]" + (Config.max_tag + 1) | Duplicate_label s -> - fprintf ppf "Two labels are named %a" Style.inline_code s + Location.errorf "Two labels are named %a" Style.inline_code s | Unboxed_mutable_label -> - fprintf ppf "Unboxed record labels cannot be mutable" + Location.errorf ~loc "Unboxed record labels cannot be mutable" | 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@]" + Location.errorf ~loc "The type abbreviation %a is cyclic%a" Style.inline_code s Reaching_path.pp_type_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 () -> - Printtyp.reset (); + Out_type.reset (); Reaching_path.add_to_preparation reaching_path; - fprintf ppf "@[The definition of %a contains a cycle%a@]" + Location.errorf ~loc "The definition of %a contains a cycle%a" Style.inline_code s Reaching_path.pp_type_colon reaching_path | Unboxed_recursion (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 is recursive without boxing%a@]" + Location.errorf ~loc + "@[The definition of %a is recursive without boxing%a@]" Style.inline_code s Reaching_path.pp_type_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" - (Style.as_inline_code Printtyp.type_expr) 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 - (Includecore.report_type_mismatch - "the original" "this" "definition" env) + | Definition_mismatch (ty, env, err) -> + let err ppf = match err with + | None -> () + | Some err -> + Format_doc.fprintf ppf "@\n@[%a@]" + (Includecore.report_type_mismatch "the original" "this" "definition" + env) err + in + Location.errorf ~loc + "@[This variant or record definition@ \ + does not match that of type@;<1 2>%a@]%t" + quoted_type ty err | Constraint_failed (env, err) -> let get_jkind_error : _ Errortrace.elt -> _ = function | Bad_jkind (ty, violation) | Bad_jkind_sort (ty, violation) -> Some (ty, violation) | Unequal_var_jkinds _ | Unequal_tof_kind_jkinds _ | Diff _ | Variant _ - | Obj _ | Escape _ | Incompatible_fields _ | Rec_occur _ -> None + | Obj _ | Escape _ | Incompatible_fields _ | Rec_occur _ + | Function_label_mismatch _ | Tuple_label_mismatch _ + | First_class_module _ -> None in begin match List.find_map get_jkind_error err.trace with | Some (ty, violation) -> - report_jkind_mismatch_due_to_bad_inference ppf env ty violation - Check_constraints + Location.errorf ~loc "%t" (fun ppf -> + report_jkind_mismatch_due_to_bad_inference ppf env ty violation + Check_constraints) | None -> - let msg = Format_doc.Doc.msg in - fprintf ppf "@[Constraints are not satisfied in this type.@ "; - Printtyp.report_unification_error ppf env err - (msg "Type") - (msg "should be an instance of"); - fprintf ppf "@]" + Location.errorf ~loc "Constraints are not satisfied in this type.@\n%t" + (fun ppf -> + Errortrace_report.unification ppf env err + (Doc.msg "Type") + (Doc.msg "should be an instance of") + ) end - | Jkind_mismatch_due_to_bad_inference (env, ty, violation, loc) -> - report_jkind_mismatch_due_to_bad_inference ppf env ty violation loc + | Jkind_mismatch_due_to_bad_inference (env, ty, violation, jkind_loc) -> + Location.errorf ~loc "%t" + (fun ppf -> + report_jkind_mismatch_due_to_bad_inference ppf env ty violation + jkind_loc) | Non_regular { definition; used_as; defined_as; reaching_path } -> let reaching_path = Reaching_path.simplify reaching_path 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; - Printtyp.Naming_context.reset (); - 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\ + Out_type.Ident_names.reset (); + Location.errorf ~loc + "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_type (Printtyp.tree_of_typexp Type defined_as) - quoted_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 - fprintf pp "@ after the following expansion(s)%a@ " + fprintf pp "@ after the following expansion(s)%a" Reaching_path.pp_type_colon reaching_path - else fprintf pp ".@ ") + 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 - (msg "Type") - (msg "is not compatible with type"); - fprintf ppf "@]" + Location.errorf ~loc "The type constraints are not consistent.@\n%t" + (fun ppf -> Errortrace_report.unification ppf env err + (Doc.msg "Type") + (Doc.msg "is not compatible with type") + ) | Type_clash (env, err) -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf env err + Location.errorf ~loc "%t" @@ fun ppf -> + 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" + Location.errorf ~loc "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@]" + Location.errorf ~loc + "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 (List.map (fun t -> None, t) 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_record_unboxed_product (tl, _, _), _ -> - explain_unbound ppf ty tl (fun l -> l.Types.ld_type) - "unboxed record field" (fun l -> Ident.name l.Types.ld_id ^ ": ") - | Type_abstract _, Some ty' -> - explain_unbound_single ppf ty ty' - | _ -> () - end; - fprintf ppf "@]" + Location.errorf ~loc + "A type variable is unbound in this type declaration%t" + (explain_unbounded ty decl) | 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 "@]" + let explain ppf = + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") + in + Location.errorf ~loc + "A type variable is unbound in this extension constructor%t" + explain | Cannot_extend_private_type path -> - fprintf ppf "@[%s@ %a@]" - "Cannot extend private type definition" + Location.errorf ~loc + "Cannot extend private type definition@ %a" Printtyp.path path | Not_extensible_type path -> - fprintf ppf "@[%s@ %a@ %s@]" - "Type definition" + Location.errorf ~loc + "Type definition@ %a@ is not extensible@]" (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" + Location.errorf ~loc + "@[This extension@ does not match the definition of type\ + @;<1 2>%a@]@\n@[%a@]" 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 - Printtyp.report_unification_error ppf env err - (msg "The constructor %a@ has type" - (Style.as_inline_code Printtyp.longident) lid) - (msg "but was expected to be of type") + Location.errorf ~loc "%t" @@ fun ppf -> + Errortrace_report.unification ppf env err + (doc_printf "The constructor %a@ has type" + quoted_constr lid) + (Doc.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') + Location.errorf ~loc + "The constructor@ %a@ extends type@ %a@ \ + whose declaration does not match@ the declaration of type@ %a" + quoted_constr lid + Style.inline_code (Path.name p) + 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" + Location.errorf ~loc "The constructor@ %a@ is private" + quoted_constr lid | 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 } -> - Printtyp.prepare_for_printing [ variable ]; - Printtyp.Naming_context.reset (); - begin match context with - | Type_declaration { id ; decl ; unboxed_version } -> - let pre, post = - if unboxed_version then - (* Unexpected; errors in the unboxed version should have also - been present and reported first for the boxed version. *) - "In the unboxed version of the definition", - "@ Please report this error to the Jane Street compilers team." - else - "In the definition", "" - in - Printtyp.add_type_declaration_to_preparation id decl; - fprintf ppf "@[%s@;<1 2>%a@;%s" - pre - (Style.as_inline_code @@ Printtyp.prepared_type_declaration id) - decl - post - | Gadt_constructor c -> - Printtyp.add_constructor_to_preparation c; - fprintf ppf "@[%s@;<1 2>%a@;" - "In the GADT constructor" - (Style.as_inline_code Printtyp.prepared_constructor) - c - | Extension_constructor (id, e) -> - Printtyp.add_extension_constructor_to_preparation e; - fprintf ppf "@[%s@;<1 2>%a@;" - "In the extension constructor" - (Printtyp.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 - "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 - "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 - "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)) + variance_error ~loc ~v1 ~v2 n | Unavailable_type_constructor p -> - fprintf ppf "The definition of type %a@ is unavailable" + Location.errorf ~loc "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" + | Variance (Typedecl_variance.Varying_anonymous (n, reason)) -> + let reason_text = + match reason with + | Variable_constrained ty -> + dprintf + ", because the type variable %a appears@ in other parameters.@ \ + In GADTS, covariant or contravariant type parameters@ \ + must not depend@ on other parameters." + (Style.as_inline_code Printtyp.type_expr) ty + | Variable_instantiated ty -> + dprintf + ", because it is instantiated to the type %a.@ \ + Covariant or contravariant type parameters@ \ + may only appear@ as type variables@ \ + in GADT constructor definitions." + (Style.as_inline_code Printtyp.type_expr) ty + in + Location.errorf ~loc + "In this GADT constructor definition,@ \ + the variance of the@ %d%s parameter@ \ + cannot be checked%t" + n (Misc.ordinal_suffix n) + reason_text | Val_in_structure -> - fprintf ppf "Value declarations are only allowed in signatures" + Location.errorf ~loc "Value declarations are only allowed in signatures" | Multiple_native_repr_attributes -> - fprintf ppf "Too many %a/%a/%a attributes" + Location.errorf ~loc "Too many %a/%a/%a attributes" Style.inline_code "[@@unboxed]" Style.inline_code "[@@untagged]" Style.inline_code "[@@unpacked]" | Cannot_unbox_or_untag_type Unboxed -> - fprintf ppf "@[Don't know how to unbox this type.@ \ - Only %a, %a, %a, %a, vector primitives, and@ \ - the corresponding unboxed types can be marked unboxed.@]" + Location.errorf ~loc + "Don't know how to unbox this type.@ \ + Only %a, %a, %a, %a, vector primitives, and@ \ + the corresponding unboxed types can be marked 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, %a, %a, \ - and@ other immediate types can be untagged.@]" + Location.errorf ~loc + "Don't know how to untag this type. Only %a, %a, %a, \ + and@ other immediate types can be untagged." Style.inline_code "int8" Style.inline_code "int16" Style.inline_code "int" | Cannot_unbox_or_untag_type Unpacked -> - fprintf ppf "@[Don't know how to unpack this type.@ \ - Only types with product layouts can be marked %a.@]" + Location.errorf ~loc + "Don't know how to unpack this type.@ \ + Only types with product layouts can be marked %a." Style.inline_code "unpacked" | Deep_unbox_or_untag_attribute kind -> - fprintf ppf - "@[The attribute %a should be attached to@ \ + Location.errorf ~loc + "The attribute %a should be attached to@ \ a direct argument or result of the primitive,@ \ - it should not occur deeply into its type.@]" + it should not occur deeply into its type." Style.inline_code (match kind with | Unboxed -> "@unboxed" @@ -5198,13 +5318,15 @@ let report_error_doc ppf = function in fprintf ppf "type %a" Style.inline_code path_end in - Jkind.Violation.report_with_offender ~offender - env ppf v + Location.errorf ~loc "%t" (fun ppf -> + Jkind.Violation.report_with_offender ~offender + env ppf v) | Jkind_mismatch_of_type (env, ty, v) -> let offender ppf = fprintf ppf "type %a" (Style.as_inline_code Printtyp.type_expr) ty in - Jkind.Violation.report_with_offender ~offender - env ppf v + Location.errorf ~loc "%t" (fun ppf -> + Jkind.Violation.report_with_offender ~offender + env ppf v) | Jkind_sort {env; kloc; typ; err} -> let s = match kloc with @@ -5227,17 +5349,17 @@ let report_error_doc ppf = function made representable by %a)" Style.inline_code "[@layout_poly]" in - fprintf ppf "@[%s must have a representable layout%t.@ %a@]" s + Location.errorf ~loc "%s must have a representable layout%t.@ %a" s extra (Jkind.Violation.report_with_offender ~offender:(fun ppf -> Printtyp.type_expr ppf typ) env) err | Jkind_empty_record -> - fprintf ppf "@[Records must contain at least one runtime value.@]" + Location.errorf ~loc "Records must contain at least one runtime value." | Non_representable_in_module (env, err, ty) -> let offender ppf = fprintf ppf "type %a" Printtyp.type_expr ty in - fprintf ppf "@[The type of a module-level value must have a@ \ - representable layout.@ %a@]" + Location.errorf ~loc "The type of a module-level value must have a@ \ + representable layout.@ %a" (Jkind.Violation.report_with_offender ~offender env) err @@ -5254,49 +5376,50 @@ let report_error_doc ppf = function | Cstr_tuple { unboxed = true } -> "Unboxed variants" | External | External_with_layout_poly -> assert false in - fprintf ppf - "@[Type %a has layout %a.@ %s may not yet contain types of this layout.@]" + Location.errorf ~loc + "Type %a has layout %a.@ %s may not yet contain types of this layout." (Style.as_inline_code Printtyp.type_expr) typ (Style.as_inline_code Jkind.Sort.Const.format) sort_const struct_desc | Illegal_mixed_product error -> begin match error with | Runtime_support_not_enabled mixed_product_kind -> - fprintf ppf - "@[This OCaml runtime doesn't support mixed %s.@]" + Location.errorf ~loc + "This OCaml runtime doesn't support mixed %s." (Mixed_product_kind.to_plural_string mixed_product_kind) | Extension_constructor -> - fprintf ppf - "@[Extensible types can't have fields of unboxed type.@ Consider \ - wrapping the unboxed fields in a record.@]" + Location.errorf ~loc + "Extensible types can't have fields of unboxed type.@ Consider \ + wrapping the unboxed fields in a record." | Value_prefix_too_long { value_prefix_len; max_value_prefix_len; mixed_product_kind } -> - fprintf ppf - "@[Mixed %s may contain at most %d value fields prior to the\ - \ flat suffix, but this one contains %d.@]" + Location.errorf ~loc + "Mixed %s may contain at most %d value fields prior to the\ + \ flat suffix, but this one contains %d." (Mixed_product_kind.to_plural_string mixed_product_kind) max_value_prefix_len value_prefix_len | Insufficient_level { required_layouts_level; mixed_product_kind } -> ( - let hint ppf = - fprintf ppf "You must enable -extension %s to use this feature." - (Language_extension.to_command_line_string Layouts - required_layouts_level) + let hint = + [Location.msg + "You must enable -extension %s to use this feature." + (Language_extension.to_command_line_string Layouts + required_layouts_level)] in match Language_extension.is_enabled Layouts with | false -> - fprintf ppf - "@[The appropriate layouts extension is not enabled.@;%t@]" hint + Location.errorf ~loc + "@[The appropriate layouts extension is not enabled.@]" + ~sub:hint | true -> - fprintf ppf - "@[The enabled layouts extension does not allow for mixed %s.@;\ - %t@]" + Location.errorf ~loc + "@[The enabled layouts extension does not allow for mixed %s.@]" (Mixed_product_kind.to_plural_string mixed_product_kind) - hint) + ~sub:hint) end | Bad_unboxed_attribute msg -> - fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg + Location.errorf ~loc "This type cannot be unboxed because@ %s." msg | Poly_not_yet_implemented -> - fprintf ppf "@[The %a annotation is not yet implemented.@]" + Location.errorf ~loc "The %a annotation is not yet implemented." Style.inline_code "val poly_" | Separability (Typedecl_separability.Non_separable_evar evar) -> let pp_evar ppf = function @@ -5305,122 +5428,125 @@ let report_error_doc ppf = function | 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.@]" + Location.errorf ~loc + "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.@]" + Location.errorf ~loc + "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.@]" + Location.errorf ~loc + "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@]" + let sub = [ + Location.msg + "@[@[@{Hint@}: If you intended to define a private \ + type abbreviation,@ \ + write explicitly@]@;<1 2>%a@]" + (Style.as_inline_code pp_private) ty + ] + in + Location.errorf ~sub ~loc + "This private row type declaration is invalid.@\n\ + @[The type expression on the right-hand side reduces to@;<1 2>%a@ \ + which does not have a free row type variable.@]" (Style.as_inline_code Printtyp.type_expr) ty - (Style.as_inline_code pp_private) ty | Local_not_enabled -> - fprintf ppf "@[The local extension is disabled@ \ - To enable it, pass the '-extension local' flag@]" + Location.errorf ~loc + "The local extension is disabled@ \ + To enable it, pass the '-extension local' flag" | Unexpected_layout_any_in_primitive name -> - fprintf ppf - "@[The primitive %a doesn't work well with type variables of@ \ - layout any. Consider using %a.@]" + Location.errorf ~loc + "The primitive %a doesn't work well with type variables of@ \ + layout any. Consider using %a." Style.inline_code name Style.inline_code "[@layout_poly]" | Useless_layout_poly -> - fprintf ppf - "@[%a on this external declaration has no@ \ - effect. Consider removing it or adding a type@ \ - variable for it to operate on.@]" + Location.errorf ~loc + "%a on this external declaration has no@ \ + effect. Consider removing it or adding a type@ \ + variable for it to operate on." Style.inline_code "[@layout_poly]" | Bad_or_null_attribute msg -> - fprintf ppf "@[Invalid [@@or_null] declaration:@ %s.@]" msg + Location.errorf ~loc "Invalid [@@or_null] declaration:@ %s." msg | Zero_alloc_attr_unsupported ca -> let variety = match ca with | Default_zero_alloc | Check _ -> assert false | Assume _ -> "assume" | Ignore_assert_all -> "ignore" in - fprintf ppf - "@[zero_alloc %a attributes are not supported in signatures@]" + Location.errorf ~loc + "zero_alloc %a attributes are not supported in signatures" Style.inline_code variety | Zero_alloc_attr_non_function -> - fprintf ppf - "@[In signatures, zero_alloc is only supported on function declarations.\ - @ Found no arrows in this declaration's type.\ - @ Hint: You can write %a to specify the arity\ - @ of an alias (for n > 0).@]" + Location.errorf ~loc + "In signatures, zero_alloc is only supported on function declarations.\ + @ Found no arrows in this declaration's type.\ + @ Hint: You can write %a to specify the arity\ + @ of an alias (for n > 0).@]" Style.inline_code "[@zero_alloc arity n]" | Zero_alloc_attr_bad_user_arity -> - fprintf ppf - "@[Invalid zero_alloc attribute: arity must be greater than 0.@]" + Location.errorf ~loc + "Invalid zero_alloc attribute: arity must be greater than 0." | Invalid_reexport {definition; expected} -> - fprintf ppf - "@[Invalid reexport declaration.\ - @ Type %s must be defined equal to the primitive type %a.@]" + Location.errorf ~loc + "Invalid reexport declaration.\ + @ Type %s must be defined equal to the primitive type %a." (Path.name definition) Printtyp.path expected | Non_abstract_reexport definition -> - fprintf ppf - "@[Invalid reexport declaration.\ - @ Type %s must not define an explicit representation.@]" + Location.errorf ~loc + "Invalid reexport declaration.\ + @ Type %s must not define an explicit representation." (Path.name definition) | Unsafe_mode_crossing_on_invalid_type_kind -> - fprintf ppf - "@[[%@%@unsafe_allow_any_mode_crossing] is not allowed on this kind of \ + Location.errorf ~loc + "[%@%@unsafe_allow_any_mode_crossing] is not allowed on this kind of \ type declaration.@ Only records, unboxed products, and variants are \ - supported.@]" + supported." | Illegal_baggage (env, jkind) -> - fprintf ppf - "@[Illegal %a in kind annotation of an abbreviation:@ %a@]" + Location.errorf ~loc + "Illegal %a in kind annotation of an abbreviation:@ %a" Style.inline_code "with" (Jkind.format env) jkind | No_unboxed_version p -> - fprintf ppf "@[The type %a@ has no unboxed version.@]" + Location.errorf ~loc "The type %a@ has no unboxed version." (Style.as_inline_code Printtyp.path) p | Atomic_field_must_be_mutable name -> - fprintf ppf - "@[The label %a must be mutable to be declared atomic.@]" + Location.errorf ~loc + "The label %a must be mutable to be declared atomic." Style.inline_code name | Constructor_submode_failed e -> let Mode.Value.Error (ax, {left; right}) = Mode.Value.to_simple_error e in - fprintf ppf "@[This constructor is at mode %a, \ + Location.errorf ~loc "This constructor is at mode %a, \ but expected to be at mode %a.@]" (Style.as_inline_code (Mode.Value.Const.print_axis ax)) left - (Style.as_inline_code (Mode.Value.Const.print_axis ax)) right; - fprintf ppf "@[@[@{Hint@}: all argument types must \ - mode-cross for rebinding to succeed.@]" + (Style.as_inline_code (Mode.Value.Const.print_axis ax)) right + ~sub:[Location.msg "@[@[@{Hint@}: all argument types must \ + mode-cross for rebinding to succeed."] | Atomic_field_in_mixed_block -> - fprintf ppf - "@[Atomic record fields are not permitted in mixed blocks.@]" + Location.errorf ~loc + "Atomic record fields are not permitted in mixed blocks." | Non_value_atomic_field -> - fprintf ppf - "@[Atomic record fields must have layout value.@]" + Location.errorf ~loc + "Atomic record fields must have layout value." | Layout_poly_unsupported -> - fprintf ppf - "@[Layout polymorphism is unsupported in this context.@]" + Location.errorf ~loc + "Layout polymorphism is unsupported in this context." | Recursive_jkind_definition (path, env, reaching_path) -> Printtyp.wrap_printing_env ~error:true env @@ fun () -> - fprintf ppf "@[The kind %a is cyclic%a@]" + Location.errorf ~loc "@[The kind %a is cyclic%a@]" (Style.as_inline_code Printtyp.path) path Reaching_path.pp_kind_colon reaching_path - let () = Location.register_error_of_exn (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error_doc err) + | Error (loc, err) -> Some (report_error ~loc err) | _ -> None ) - -let report_error = Format_doc.compat report_error_doc diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index 9d26877e9..f4e526fe5 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -89,6 +89,7 @@ type error = | Invalid_type_subst_rhs | Non_packable_local_modtype_subst of Path.t | With_cannot_remove_packed_modtype of Path.t * module_type + | Cannot_alias of Path.t | Strengthening_mismatch of Longident.t * Includemod.explanation | Cannot_pack_parameter | Compiling_as_parameterised_parameter @@ -984,6 +985,7 @@ module Merge = struct | Covariant -> true, false | Contravariant -> false, true | NoVariance -> false, false + | Bivariant -> true, true in make_variance (not n) (not c) (i = Injective) ) @@ -995,7 +997,7 @@ module Merge = struct type_expansion_scope = Btype.lowest_level; type_attributes = []; type_unboxed_default = false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + type_uid = Uid.mk ~current_unit:(Env.get_current_unit ()); type_unboxed_version = None; } and id_row = Ident.create_local (s^"#row") in @@ -1173,7 +1175,7 @@ module Merge = struct if destructive then None else 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; mtd_attributes = []; mtd_loc = loc; } @@ -1667,7 +1669,7 @@ and approx_modtype_info env sinfo = mtd_attributes = sinfo.pmtd_attributes; mtd_loc = sinfo.pmtd_loc; mtd_uid = Uid.internal_not_actually_unique; - } + } and approx_constraint env body constr = (* constraints are first approximated then merged, disabling all equivalence @@ -2077,7 +2079,7 @@ and transl_modtype_aux env smty = md_modalities = Mode.Modality.undefined; 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 @@ -2355,7 +2357,10 @@ and transl_signature ?(keep_warnings = false) env sig_acc {psg_items; psg_modali let tmty = {tmty with mty_type} 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 = { @@ -2363,7 +2368,7 @@ and transl_signature ?(keep_warnings = false) env sig_acc {psg_items; psg_modali md_modalities = Modality.of_const md_modalities.moda_modalities; 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 = @@ -2407,7 +2412,7 @@ and transl_signature ?(keep_warnings = false) env sig_acc {psg_items; psg_modali md_modalities = Mode.Modality.(Const.id |> of_const); 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 = @@ -2603,7 +2608,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 @@ -2676,7 +2681,7 @@ and transl_recmodule_modtypes env ~sig_modalities sdecls = let init = List.map2 (fun id (pmd, smmode) -> - 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_type, md_modalities = approx_modtype (approx_env pmd.pmd_name.txt) pmd.pmd_type |> apply_pmd_modalities env ~default_modalities:sig_modalities @@ -3043,30 +3048,38 @@ and package_constraints env loc mty constrs = raise(Error(loc, env, Cannot_scrape_package_type (ident mty))) end -let modtype_of_package env loc p fl = - (* We call Ctype.correct_levels to ensure that the types being added to the +let modtype_of_package env loc pack = + (* 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) + package_constraints env loc (Mty_ident pack.pack_path) + (List.map (fun (n, t) -> n, Ctype.duplicate_type t) pack.pack_cstrs) in Subst.modtype Keep Subst.identity mty (* CR zqian: [package_subtype] should take [modes], but piping this through [ctype] is too much. Instead, we take the conservative approach. *) -let package_subtype env p1 fl1 p2 fl2 = - let mkmty p fl = +let package_subtype env pack1 pack2 = + let mkmty pack = let fl = - List.filter (fun (_n,t) -> Ctype.closed_type_expr t) fl in - modtype_of_package env Location.none p fl + List.filter (fun (_n,t) -> Ctype.closed_type_expr t) pack.pack_cstrs in + modtype_of_package env Location.none {pack with pack_cstrs = fl} in - match mkmty p1 fl1, mkmty p2 fl2 with - | exception Error(_, _, Cannot_scrape_package_type _) -> false + match mkmty pack1, mkmty pack2 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:true env ~modes:All 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 @@ -3135,17 +3148,47 @@ let simplify_app_summary app_view = match app_view.arg with | false, Some p -> Includemod.Error.Named p, mty, mode | false, None -> Includemod.Error.Anonymous, mty, mode +let check_package_closed ~loc ~env ~typ fl = + if List.exists (fun (_n, t) -> not (Ctype.closed_type_expr t)) fl + then + raise (Error (loc, env, Incomplete_packed_module typ)) + let not_principal msg = Warnings.Not_principal (Format_doc.Doc.msg msg) -let rec type_module ?alias sttn funct_body anchor env smod = +let rec type_module ?alias ~strengthen ~funct_body anchor env smod = let md, shape = - type_module_maybe_hold_locks ?alias ~hold_locks:false sttn funct_body anchor - env smod + type_module_maybe_hold_locks ?alias ~hold_locks:false ~strengthen + ~funct_body anchor env smod in md, shape +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 and type_module_maybe_hold_locks ?(alias=false) ~hold_locks sttn funct_body anchor env smod = +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +and type_module_maybe_hold_locks ?(alias=false) ~hold_locks sttn funct_body + anchor env smod = + Builtin_attributes.warning_scope smod.pmod_attributes + (fun () -> type_module_aux ~alias ~hold_locks sttn funct_body anchor env + smod) + +and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = + (* If the module is an identifier, there might be locks between the + declaration site and the use site. + - If [hold_locks] is [true], the locks are held and stored in [mod_mode]. +======= +and type_module_maybe_hold_locks ?(alias=false) ~hold_locks ~strengthen + ~funct_body anchor env smod = + Builtin_attributes.warning_scope smod.pmod_attributes + (fun () -> type_module_aux ~alias ~hold_locks ~strengthen ~funct_body + anchor env smod) + +and type_module_aux ~alias ~hold_locks ~strengthen ~funct_body anchor env + smod = + (* If the module is an identifier, there might be locks between the + declaration site and the use site. + - If [hold_locks] is [true], the locks are held and stored in [mod_mode]. +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* 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 when finished. *) @@ -3175,12 +3218,18 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = let path, mode_with_locks = Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env in - type_module_path_aux ~alias ~hold_locks sttn env path mode_with_locks lid - smod + type_module_path_aux ~alias ~hold_locks ~strengthen env path + mode_with_locks lid smod | Pmod_structure sstr -> Env.check_no_open_quotations smod.pmod_loc env Env.Struct_qt; let (str, sg, mode, names, shape, _finalenv) = +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 type_structure funct_body anchor env [] sstr in +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + type_structure funct_body anchor env sstr in +======= + type_structure ~funct_body anchor env sstr in +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let md = { mod_desc = Tmod_structure str; mod_type = Mty_signature sg; @@ -3215,7 +3264,7 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = match param.txt with | None -> None, newenv, 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_modalities = Modality.undefined; @@ -3236,7 +3285,9 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = newenv, var, true in - let body, body_shape = type_module true funct_body None newenv sbody in + let body, body_shape = + type_module ~strengthen:true ~funct_body None newenv sbody + in let body_mode = mode_without_locks_exn body.mod_mode in let ret_mode = Alloc.newvar () in Value.submode_exn body_mode (ret_mode |> alloc_as_value); @@ -3258,7 +3309,7 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = 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 + type_application smod.pmod_loc ~strengthen ~funct_body env smod | Pmod_constraint(sarg, smty, smode) -> (* Only hold locks if coercion *) let hold_locks = Option.is_some smty in @@ -3267,8 +3318,8 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = { tmode with mode_modes = new_mode_var_from_annots tmode.mode_modes } in let arg, arg_shape = - type_module_maybe_hold_locks ~alias ~hold_locks true funct_body - anchor env sarg + type_module_maybe_hold_locks ~alias ~hold_locks ~strengthen:true + ~funct_body anchor env sarg in begin try let md, final_shape = @@ -3309,24 +3360,21 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = | Pmod_unpack sexp -> let mode = Value.newvar () in let exp = - Ctype.with_local_level_if_principal + Ctype.with_local_level_generalize_structure_if_principal (fun () -> Typecore.type_exp env sexp ~mode:(Value.disallow_left mode)) - ~post:Typecore.generalize_structure_exp in let mty = match get_desc (Ctype.expand_head env exp.exp_type) with - Tpackage (p, fl) -> - if List.exists (fun (_n, t) -> not (Ctype.closed_type_expr t)) fl - then - raise (Error (smod.pmod_loc, env, - Incomplete_packed_module exp.exp_type)); + Tpackage pack -> + check_package_closed ~loc:smod.pmod_loc ~env ~typ:exp.exp_type + pack.pack_cstrs; 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 + modtype_of_package env smod.pmod_loc pack | Tvar _ -> raise (Typecore.Error (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) @@ -3367,10 +3415,10 @@ and type_module_aux ~alias ~hold_locks sttn funct_body anchor env smod = in Location.(mkloc (Lident name) (ghostify smod.pmod_loc)) in - type_module_path_aux ~alias ~hold_locks sttn env path mode_with_locks lid - smod + type_module_path_aux ~alias ~hold_locks ~strengthen env path + mode_with_locks lid smod -and type_module_path_aux ~alias ~hold_locks sttn env path +and type_module_path_aux ~alias ~hold_locks ~strengthen env path (mode, locks) (lid : _ loc) smod = let mod_mode = if hold_locks then mode, Some (locks, lid.txt, lid.loc) @@ -3396,13 +3444,13 @@ and type_module_path_aux ~alias ~hold_locks sttn env path (Env.add_required_global path env; md) else begin let mty = Mtype.find_type_of_module - ~strengthen:sttn ~aliasable env path + ~strengthen ~aliasable env path 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 + ~strengthen env p1 in { md with mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit, @@ -3414,13 +3462,13 @@ and type_module_path_aux ~alias ~hold_locks sttn env path in md, shape -and type_application loc strengthen funct_body env smod = - let rec extract_application funct_body env sargs smod = +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) -> + | Pmod_apply (f, sarg) -> let arg, shape = - type_module_maybe_hold_locks ~hold_locks:true true funct_body None env - sarg + type_module_maybe_hold_locks ~hold_locks:true ~strengthen:true + ~funct_body None env sarg in let summary = { loc = smod.pmod_loc; @@ -3433,7 +3481,7 @@ and type_application loc strengthen funct_body env smod = shape; } } in - extract_application funct_body env (summary::sargs) f + extract_application ~funct_body env (summary::sargs) f | Pmod_apply_unit f -> let summary = { loc = smod.pmod_loc; @@ -3441,17 +3489,17 @@ and type_application loc strengthen funct_body env smod = f_loc = f.pmod_loc; arg = None } in - extract_application funct_body env (summary::sargs) f + extract_application ~funct_body env (summary::sargs) f | _ -> smod, sargs in - let sfunct, args = extract_application funct_body env [] smod 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 + type_module ~strengthen ~funct_body None env sfunct in List.fold_left (type_one_application ~ctx:(loc, sfunct, funct, args) funct_body env) @@ -3533,8 +3581,8 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) | { 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:true env arg.mod_type mty_param + try Includemod.modtypes ~loc:arg.mod_loc ~mark:true env + arg.mod_type mty_param ~modes:(Specific (arg.mod_mode, mm_param)) with Includemod.Error _ -> Msupport.raise_error (apply_error ()); @@ -3571,8 +3619,8 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) not sure it's worth the effort. *) (* begin match - Includemod.modtypes - ~loc:app_loc ~mark:false env mty_res nondep_mty + Includemod.modtypes ~loc:app_loc ~mark:false env + mty_res nondep_mty ~modes:(Specific ((mm_res, None), mm_res)) with | Tcoerce_none -> () @@ -3581,8 +3629,8 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) Format.eprintf "[nondep-supertype] unexpected coercion@;original=%a@;\ nondep=%a@." - (Format_doc.compat Printtyp.modtype) mty_res - (Format_doc.compat Printtyp.modtype) nondep_mty; + Printtyp.modtype mty_res + Printtyp.modtype nondep_mty; fatal_error "unexpected coercion from original module type to \ nondep_supertype one" @@ -3591,8 +3639,8 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) Format.eprintf "[nondep-supertype] inclusion failure@;original=%a@;\ nondep=%a@." - (Format_doc.compat Printtyp.modtype) mty_res - (Format_doc.compat Printtyp.modtype) nondep_mty; + Printtyp.modtype mty_res + Printtyp.modtype nondep_mty; fatal_error "nondep_supertype not included in original module type" end; @@ -3623,13 +3671,13 @@ and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) 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 = +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 + 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 = +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 -> @@ -3654,7 +3702,9 @@ and type_open_decl_aux ?used_slot ?toplevel funct_body names env od = } in open_descr, Mode.Value.(max |> disallow_right), [], newenv | _ -> - let md, mod_shape = type_module true funct_body None env od.popen_expr in + let md, mod_shape = + type_module ~strengthen:true ~funct_body None env od.popen_expr + in let mode = mode_without_locks_exn md.mod_mode in let scope = Ctype.create_scope () in let sg, newenv = @@ -3693,6 +3743,18 @@ and type_open_decl_aux ?used_slot ?toplevel funct_body names env od = } in open_descr, mode, sg, newenv +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +and type_structure ?(toplevel = None) funct_body anchor env sstr = + (* CR implicit-types: implement implicit variable jkinds in structures. *) + let env = Env.clear_implicit_jkinds env in + let names = Signature_names.create () in +======= +and type_structure ?(toplevel = None) ~funct_body anchor env sstr = + (* CR implicit-types: implement implicit variable jkinds in structures. *) + let env = Env.clear_implicit_jkinds env in + let names = Signature_names.create () in +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 (* In the real compiler, the `toplevel` argument is a `signature option` because it serves two purposes: To tweak typing if we're in the toplevel, and to pass in the signature for what's been typed so far in that case (needed by include functor). But in merlin @@ -3712,7 +3774,7 @@ and type_structure ?(toplevel = None) ?(keep_warnings = false) funct_body anchor 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) + (fun () -> type_module ~strengthen:true ~funct_body None env smodl) in let scope = Ctype.create_scope () in let incl_kind, sg, mode = @@ -3902,7 +3964,7 @@ and type_structure ?(toplevel = None) ?(keep_warnings = false) funct_body anchor let modl, md_shape = Builtin_attributes.warning_scope attrs (fun () -> - type_module ~alias:true true funct_body + type_module ~alias:true ~strengthen:true ~funct_body (anchor_submodule name.txt anchor) env smodl ) in @@ -3911,7 +3973,7 @@ and type_structure ?(toplevel = None) ?(keep_warnings = false) funct_body anchor | 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 mode = mode_without_locks_exn modl.mod_mode in let md = { md_type = enrich_module_type anchor name.txt modl.mod_type env; @@ -3992,13 +4054,15 @@ and type_structure ?(toplevel = None) ?(keep_warnings = false) funct_body anchor let modl, shape = Builtin_attributes.warning_scope attrs (fun () -> - type_module true funct_body (anchor_recmodule id) - newenv smodl + type_module ~strengthen: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', Option.get mode, attrs, loc, shape, uid)) decls sbind in @@ -4063,7 +4127,7 @@ and type_structure ?(toplevel = None) ?(keep_warnings = false) funct_body anchor | Pstr_open sod -> let toplevel = Option.is_some toplevel in let (od, mode, sg, newenv) = - type_open_decl ~toplevel funct_body names env sod + type_open_decl ~toplevel ~funct_body names env sod in let newenv = Env.update_short_paths newenv in let sg = @@ -4146,9 +4210,6 @@ and type_structure ?(toplevel = None) ?(keep_warnings = false) funct_body anchor raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pstr_attribute x -> Builtin_attributes.parse_standard_implementation_attributes x; - if Option.is_some toplevel - || not (Warnings.is_active (Misplaced_attribute "")) then - Builtin_attributes.mark_alert_used x; Tstr_attribute x, [], shape_map, env | Pstr_jkind x -> let id, env, decl = Typedecl.transl_jkind_decl env x in @@ -4209,8 +4270,16 @@ let type_toplevel_phrase env sig_acc s = Env.reset_required_globals (); Env.reset_probes (); Typecore.reset_allocations (); +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let (str, sg, mode, _to_remove_from_sg, shape, env) = type_structure ~toplevel:(Some sig_acc) false None env sig_acc s in +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let (str, sg, mode, to_remove_from_sg, shape, env) = + type_structure ~toplevel:(Some sig_acc) false None env s in +======= + let (str, sg, mode, to_remove_from_sg, shape, env) = + type_structure ~toplevel:(Some sig_acc) ~funct_body:false None env s in +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 Value.submode_err (Location.none, Structure) mode toplevel_mode; remove_mode_and_jkind_variables env sg; remove_mode_and_jkind_variables_for_toplevel str; @@ -4218,11 +4287,24 @@ let type_toplevel_phrase env sig_acc s = (str, sg, (* to_remove_from_sg, *) shape, env) let type_module_alias env smod = - type_module_maybe_hold_locks ~alias:true ~hold_locks:true true false - None env smod + type_module_maybe_hold_locks ~alias:true ~hold_locks:true ~strengthen:true + ~funct_body:false None env smod +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 +let type_module = type_module true false None +let type_module_maybe_hold_locks = type_module_maybe_hold_locks true false None +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d let type_module = type_module true false None let type_module_maybe_hold_locks = type_module_maybe_hold_locks true false None +let type_structure = type_structure false None +======= +let type_module = + type_module ~strengthen:true ~funct_body:false None +let type_module_maybe_hold_locks = + type_module_maybe_hold_locks ~strengthen:true ~funct_body:false None +let type_structure = + type_structure ~funct_body:false None +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let merlin_type_structure env sig_acc str = let (str, sg, _mode, _sg_names, _shape, env) = @@ -4286,7 +4368,7 @@ let rec extend_path path = fun lid -> match lid with | Lident name -> Pdot(path, name) - | Ldot(m, name) -> Pdot(extend_path path m, name) + | Ldot({ txt = m; _ }, { txt = name; _ }) -> Pdot(extend_path path m, name) | Lapply _ -> assert false (* Lookup a type's longident within a signature *) @@ -4308,16 +4390,16 @@ let lookup_type_in_sig sg = in let rec module_path = function | Lident name -> Pident (String.Map.find name modules) - | Ldot(m, name) -> Pdot(module_path m, name) + | Ldot({ txt = m; _ }, { txt = 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) + | Ldot({ txt = m; _ }, { txt = name; _ }) -> Pdot(module_path m, name) | Lapply _ -> assert false -let type_package env m p fl = +let type_package env m pack = (* Same as Pexp_letmodule *) (* remember original level *) let outer_scope = Ctype.get_current_level () in @@ -4335,7 +4417,7 @@ let type_package env m p fl = in Mtype.lower_nongen outer_scope modl.mod_type; let fl', env = - match fl with + match pack.pack_cstrs with | [] -> [], env | fl -> let type_path, env = @@ -4357,7 +4439,7 @@ let type_package env m p fl = let fl' = List.fold_right (fun (lid, _t) fl -> - match type_path lid with + match type_path (Longident.unflatten lid |> Option.get) with | exception Not_found -> fl | path -> begin match Env.find_type path env with @@ -4375,28 +4457,29 @@ let type_package env m p fl = fl', env in let mty = - if fl = [] then (Mty_ident p) - else modtype_of_package env modl.mod_loc p fl' + if pack.pack_cstrs = [] then (Mty_ident pack.pack_path) + else modtype_of_package env modl.mod_loc {pack with pack_cstrs = fl'} in List.iter (fun (n, ty) -> try Ctype.unify env ty (Ctype.newvar (Jkind.Builtin.any ~why:Dummy_jkind)) with Ctype.Unify _ -> - raise (Error(modl.mod_loc, env, Scoping_pack (n,ty)))) + let lid = Longident.unflatten n |> Option.get in + raise (Error(modl.mod_loc, env, Scoping_pack (lid,ty)))) fl'; let _, mode = register_allocation () in let modl = wrap_constraint_package env true modl mty mode Tmodtype_implicit in - modl, fl' + modl, {pack with pack_cstrs = fl'} (* Fill in the forward declarations *) let type_open_decl ?used_slot env od = let od, _, _, env = - type_open_decl ?used_slot ?toplevel:None false (Signature_names.create ()) - env od + type_open_decl ?used_slot ?toplevel:None ~funct_body:false + (Signature_names.create ()) env od in od, env @@ -4755,7 +4838,7 @@ let package_signatures units = md_modalities=Modality.(Const.id |> of_const); 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)) @@ -4852,9 +4935,7 @@ let package_units initial_env objfiles target_cmi modulename = (* Error report *) - - -open Printtyp +open Printtyp.Doc (* A heuristic used in nondep errors: the input describes a declaration that has made invalid, and this says what about it is now invalid. *) @@ -4871,12 +4952,13 @@ 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 ppf = Includemod_errorprinter.err_msgs ppf 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 | Not_included_functor errs -> - let main ppf = Includemod_errorprinter.err_msgs ppf errs in - Location.errorf ~loc - "@[Signature mismatch in included functor's parameter:@ %t@]" main + Location.errorf ~loc ~footnote:Out_type.Ident_conflicts.err_msg + "@[Signature mismatch in included functor's parameter:@ %a@]" + Includemod_errorprinter.err_msgs errs | Cannot_eliminate_dependency (dep_type, mty) -> let hint = match dep_type with @@ -4917,7 +4999,7 @@ let report_error ~loc _env = function Style.inline_code "with" (Style.as_inline_code longident) lid | With_mismatch(lid, explanation) -> - 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@ \ @@ -4927,7 +5009,7 @@ let report_error ~loc _env = function (Style.as_inline_code longident) lid Includemod_errorprinter.err_msgs explanation | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> - 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:@]@ \ @@ -4955,7 +5037,7 @@ let report_error ~loc _env = function [ 12; 7; 3 ] in let pp_constraint ppf (p,mty) = - 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" @@ -4967,7 +5049,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 @@ -4975,17 +5057,28 @@ let report_error ~loc _env = function Names must be unique in a given structure or signature.@]" (Sig_component_kind.to_string kind) Style.inline_code name | Non_generalizable { vars; expression } -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let manual_ref = [ 6; 1; 2 ] in prepare_for_printing vars; add_type_to_preparation expression; +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation 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; +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 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 } -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let manual_ref = [ 6; 1; 2 ] in prepare_for_printing vars; add_type_to_preparation item.val_type; @@ -5000,10 +5093,39 @@ let report_error ~loc _env = function ] in Location.errorf ~loc ~sub +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + 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) + item.val_type + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + @@ Style.as_inline_code prepared_type_scheme) vars + ] + in + Location.errorf ~loc ~sub +======= + 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; + Location.errorf ~loc +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 "@[The type of this module,@ %a,@ \ contains non-generalizable type variable(s).@ %a@]" modtype mty Misc.print_see_manual manual_ref + ~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 + ] | Implementation_is_required intf_name -> Location.errorf ~loc "@[The interface %a@ declares values, not just types.@ \ @@ -5047,14 +5169,22 @@ 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_doc err + let report = Typedecl.report_error ~loc err in + let txt = + Format_doc.doc_printf "In %s:@ %a" + context + Format_doc.pp_doc report.main.txt + in + { report with main = { report.main with txt} } | 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/types.ml b/src/ocaml/typing/types.ml index a061403ac..0cdd2d421 100644 --- a/src/ocaml/typing/types.ml +++ b/src/ocaml/typing/types.ml @@ -168,7 +168,7 @@ and type_desc = | Tunivar of { name : string option; jkind : jkind_lr } | Tpoly of type_expr * type_expr list | Trepr of type_expr * Jkind_types.Sort.univar list - | Tpackage of Path.t * (Longident.t * type_expr) list + | Tpackage of package | Tof_kind of jkind_lr and arg_label = @@ -180,6 +180,10 @@ and arg_label = and arrow_desc = arg_label * Mode.Alloc.lr * Mode.Alloc.lr +and package = + { pack_path : Path.t; + pack_cstrs : (string list * type_expr) list } + and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; @@ -193,13 +197,14 @@ and fixed_explanation = | Rigid | Fixed_existential 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 @@ -345,18 +350,25 @@ and method_privacy = 0 <= may_pos <= pos 0 <= may_weak <= may_neg <= neg 0 <= inj + may_pos/may_neg mean possible positive/negative occurrences; + thus, may_pos + may_neg = invariant Additionally, the following implications are valid pos => inj neg => inj Examples: - type 'a t : may_pos + may_neg + may_weak + type 'a t : may_pos + may_neg + type +'a t : may_pos + type -'a t : may_neg + type +-'a t : null (no occurrence of 'a assured) + type !'a t : may_pos + may_neg + inj + type +!'a t : may_pos + inj + type -!'a t : may_neg + inj + type +-!'a t : inj 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 *) @@ -382,6 +394,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 = @@ -823,6 +836,7 @@ end include Make_wrapped(struct type 'a t = 'a end) +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (* Constructor and record label descriptions inserted held in typing environments *) @@ -849,6 +863,41 @@ type constructor_description = cstr_uid: Uid.t; } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +(* 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: constructor_argument list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: tag; (* Tag for heap blocks *) + cstr_repr: variant_representation; (* Repr of the outer variant *) + cstr_shape: constructor_representation; (* Repr of the constructor itself *) + cstr_constant: bool; + (* True if it's the constructor of a non-[@@unboxed] variant with 0 bits of + payload. (Or equivalently, if it's represented as either a tagged int or + the null pointer) *) + 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; + } + +let equal_tag t1 t2 = + match (t1, t2) with + | Ordinary {src_index=i1}, Ordinary {src_index=i2} -> +======= +let equal_tag t1 t2 = + match (t1, t2) with + | Ordinary {src_index=i1}, Ordinary {src_index=i2} -> +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 let array_equal eq_elt l1 l2 = (* Basically inlines [Array.for_all2] to avoid the [raise] *) let n = Array.length l1 in @@ -987,48 +1036,6 @@ let equal_record_representation r1 r2 = match r1, r2 with let equal_record_unboxed_product_representation r1 r2 = match r1, r2 with | Record_unboxed_product, Record_unboxed_product -> true -let may_equal_constr c1 c2 = - c1.cstr_arity = c2.cstr_arity - && (match c1.cstr_tag,c2.cstr_tag with - | Extension _, Extension _ -> - (* extension constructors may be rebindings of each other *) - true - | tag1, tag2 -> - equal_tag tag1 tag2) - -type 'a gen_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: mutability; (* Is this a mutable field? *) - lbl_modalities: Mode.Modality.Const.t;(* Modalities on the field *) - lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) - lbl_pos: int; (* Position in type *) - lbl_all: 'a gen_label_description array; (* All the labels in this type *) - lbl_repres: 'a; (* Representation for outer record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - lbl_uid: Uid.t; - } - -type label_description = record_representation gen_label_description - -type unboxed_label_description = - record_unboxed_product_representation gen_label_description - -type _ record_form = - | Legacy : record_representation record_form - | Unboxed_product : record_unboxed_product_representation record_form - -type record_form_packed = - | P : _ record_form -> record_form_packed - -let record_form_to_string (type rep) (record_form : rep record_form) = - match record_form with - | Legacy -> "record" - | Unboxed_product -> "unboxed record" - let rec mixed_block_element_of_const_sort (sort : Jkind_types.Sort.Const.t) = match sort with | Base Scannable -> Scannable @@ -1376,7 +1383,7 @@ let best_effort_compare_type_expr te1 te2 = | Tfield (_, _, _, _) | Tnil | Tvariant _ - | Tpackage (_, _) + | Tpackage _ | Tarrow (_, _, _, _) | Tquote _ | Tsplice _ @@ -1647,8 +1654,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 ****) @@ -1656,13 +1662,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 *) (**********************************) diff --git a/src/ocaml/typing/typetexp.ml b/src/ocaml/typing/typetexp.ml index 93c5c06c0..5796522d2 100644 --- a/src/ocaml/typing/typetexp.ml +++ b/src/ocaml/typing/typetexp.ml @@ -89,6 +89,7 @@ type error = | Method_mismatch of string * type_expr * type_expr | Opened_object of Path.t option | Not_an_object of type_expr + | Repeated_tuple_label of string | Unsupported_extension : _ Language_extension.t -> error | Polymorphic_optional_param | Non_value of @@ -159,7 +160,7 @@ module TyVarEnv : sig (* see mli file *) val is_in_scope : string -> bool - val add : string -> type_expr -> jkind_lr -> Env.stage -> unit + val add : ?unused:bool ref -> string -> type_expr -> jkind_lr -> Env.stage -> unit (* add a global type variable to the environment, with the given jkind. Precondition: the [type_expr] must be a [Tvar] with the given jkind. *) @@ -233,7 +234,7 @@ module TyVarEnv : sig Note [Global type variables]. *) val remember_used : - rigid:jkind_lr option + ?check:Location.t -> rigid:jkind_lr option -> string -> type_expr -> Location.t -> Env.stage -> unit (* Remember that a given name is bound to a given type. @@ -261,7 +262,8 @@ end = struct we started processing the current type. See Note [Global type variables]. *) let type_variables = - ref (TyVarMap.empty : (type_expr * jkind_lr * Env.stage) TyVarMap.t) + ref (TyVarMap.empty : + (type_expr * bool ref * jkind_lr * Env.stage) TyVarMap.t) (* These are variables that have been used in the currently-being-checked type, possibly including the variables in [type_variables]. @@ -269,6 +271,7 @@ end = struct type used_info = { ty : type_expr; loc : Location.t; + unused : bool ref; (* Rigid variables are set at a given jkind. Note that a rigid variable can still be unified; if it's unified @@ -276,7 +279,7 @@ end = struct the final expression checks against the rigid jkind. *) rigid : jkind_lr option; - stage : Env.stage + stage : Env.stage; } let used_variables = @@ -295,9 +298,9 @@ end = struct let is_in_scope name = TyVarMap.mem name !type_variables - let add name v jkind stage = + let add ?(unused = ref false) name v jkind stage = assert (not_generic v); - type_variables := TyVarMap.add name (v, jkind, stage) !type_variables + type_variables := TyVarMap.add name (v, unused, jkind, stage) !type_variables let narrow () = (increase_global_level (), !type_variables) @@ -314,11 +317,12 @@ end = struct (* throws Not_found if the variable is not in scope *) let lookup_global name = - let (type_expr, _, stage) = TyVarMap.find name !type_variables in + let (type_expr, unused, _, stage) = TyVarMap.find name !type_variables in + unused := false; (type_expr, stage) let lookup_global_jkind name = - snd3 (TyVarMap.find name !type_variables) + thd4 (TyVarMap.find name !type_variables) let get_in_scope_names () = let add_name name _ l = @@ -505,19 +509,33 @@ end = struct p.univar, s with Not_found -> let info = TyVarMap.find name !used_variables in + info.unused := false; instance info.ty, info.stage (* This call to instance might be redundant; all variables inserted into [used_variables] are non-generic, but some might get generalized. *) - let remember_used ~rigid name v loc stage = + let remember_used ?check ~rigid name v loc stage = assert (not_generic v); let rigid = match TyVarMap.find name !used_variables with | info -> info.rigid | exception Not_found -> rigid in - let info = { ty = v; loc; rigid; stage } in + let unused = match check with + | Some check_loc + when Warnings.(is_active (Unused_type_declaration ("", Alias))) -> + let unused = ref true in + !Env.add_delayed_check_forward begin fun () -> + let warn = Warnings.(Unused_type_declaration ("'" ^ name, Alias)) + in + if !unused && Warnings.is_active warn + then Location.prerr_warning check_loc warn + end; + unused + | _ -> ref false + in + let info = { ty = v; unused; loc; rigid; stage } in used_variables := TyVarMap.add name info !used_variables @@ -580,7 +598,7 @@ end = struct { flavor; unbound_variable_policy; _ } env = let r = ref [] in TyVarMap.iter - (fun name { ty; rigid; loc; stage = s } -> + (fun name { ty; unused; rigid; loc; stage = s } -> (match rigid with | Some original_jkind -> check_jkind env loc name ty { original_jkind; defaulted = false } @@ -588,23 +606,28 @@ end = struct if flavor = Unification || is_in_scope name then let v = new_global_var (Jkind.Builtin.any ~why:Dummy_jkind) in let snap = Btype.snapshot () in - if try unify env v ty; true with _ -> Btype.backtrack snap; false - then try - let (type_expr, stage) = lookup_global name in + if try unify env v ty; true + with + Unify err when is_in_scope name -> + raise (Error(loc, env, Type_mismatch err)) + | _ -> Btype.backtrack snap; false + then match lookup_global name with + | type_expr, stage -> if s <> stage then raise (Error (loc, env, (Invalid_variable_stage {name = Pprintast.tyvar_of_name name; intro_stage = stage; usage_stage = s}))); - r := (loc, v, type_expr) :: !r - with Not_found -> + r := (loc, v, type_expr) :: !r; + unused := false + | exception Not_found -> match unbound_variable_policy, Btype.is_Tvar ty with | Open, _ | (Closed | Closed_for_upstream_compatibility), false -> let jkind = Jkind.Builtin.any ~why:Dummy_jkind in let v2 = new_global_var jkind in r := (loc, v, v2) :: !r; - add name v2 jkind s; + add ~unused name v2 jkind s; | Closed, true -> raise(Error(loc, env, Unbound_type_variable (Pprintast.tyvar_of_name name, @@ -634,7 +657,7 @@ 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 + if Longident.same s1.txt s2.txt then raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); compare s1.txt s2.txt) l @@ -658,6 +681,10 @@ let newvar ?name jkind = let valid_tyvar_name name = name <> "" && name.[0] <> '_' +let check_tyvar_name env loc name = + if not (valid_tyvar_name name) then + raise (Error (loc, env, Invalid_variable_name ("'" ^ name))) + let transl_type_param_var env loc attrs name_opt (jkind : jkind_lr) jkind_annot = let tvar = Ttyp_var (name_opt, jkind_annot) in @@ -665,8 +692,7 @@ let transl_type_param_var env loc attrs name_opt match name_opt with | None -> "_" | Some name -> - if not (valid_tyvar_name name) then - raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + check_tyvar_name Env.empty loc name; if TyVarEnv.is_in_scope name then raise Already_bound; name @@ -925,6 +951,9 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = ctyp desc typ | Ptyp_unboxed_tuple stl -> Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; + assert (List.length stl >= 2); + Option.iter (fun l -> raise (Error (loc, env, Repeated_tuple_label l))) + (Misc.repeated_label stl); let tl = List.map (fun (label, t) -> @@ -998,7 +1027,7 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = let unboxed_lid : Longident.t = match lid.txt with | Lident s -> Lident (s ^ "#") - | Ldot (l, s) -> Ldot (l, s ^ "#") + | Ldot (l, s) -> Ldot (l, { s with txt = s.txt ^ "#" }) | Lapply _ -> fatal_error "Typetexp.transl_type" in match Env.find_type_by_name unboxed_lid env with @@ -1184,40 +1213,18 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = Language_extension.Alpha; Env.check_no_open_quotations loc env Layout_polymorphism_qt; raise (Error (loc, env, Lpoly_unsupported)) - | Ptyp_package (p, l) -> - (* CR layouts: right now we're doing a real gross hack where we demand - everything in a package type with constraint be value. - - An alternative is to walk into the constrained module, using the - longidents, and find the actual things that need jkind checking. - See [Typemod.package_constraints_sig] for code that does a - similar traversal from a longident. - *) - (* CR layouts: and in the long term, rewrite all of this to eliminate - the [create_package_mty] hack that constructs fake source code. *) - 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 Alloc.Const.legacy 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)) + | Ptyp_package ptyp -> + let path, mty, ptys = transl_package env ~policy ~row_context ptyp in + let ty = newty (Tpackage { + pack_path = path; + pack_cstrs = List.map (fun (s, cty) -> + (Longident.flatten s.txt, cty.ctyp_type)) ptys}) in ctyp (Ttyp_package { - pack_path = path; - pack_type = mty; - pack_fields = ptys; - pack_txt = p; + tpt_path = path; + tpt_type = mty; + tpt_cstrs = ptys; + tpt_txt = ptyp.ppt_path; }) ty | Ptyp_open (mod_ident, t) -> let path, new_env = @@ -1249,8 +1256,7 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = and transl_type_var env ~policy ~row_context attrs loc name jkind_annot_opt = let print_name = "'" ^ name in - if not (valid_tyvar_name name) then - raise (Error (loc, env, Invalid_variable_name print_name)); + check_tyvar_name env loc name; let of_annot = jkind_of_annotation env (Type_variable print_name) attrs in let ty, stage = try TyVarEnv.lookup_local ~row_context name @@ -1287,7 +1293,7 @@ and transl_type_var env ~policy ~row_context attrs loc name jkind_annot_opt = and transl_type_poly env ~policy ~row_context mode loc vars st = let typed_vars, new_univars, cty = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let vars = List.map (fun (n, v) -> (n, v, Env.stage env)) vars in let new_univars = transl_bound_vars env vars in let typed_vars = TyVarEnv.ttyp_poly_arg new_univars in @@ -1296,7 +1302,7 @@ and transl_type_poly env ~policy ~row_context mode loc vars st = end in (typed_vars, new_univars, cty) end - ~post:(fun (_,_,cty) -> generalize_ctyp cty) + ~before_generalize:(fun (_,_,cty) -> generalize_ctyp cty) in let ty = cty.ctyp_type in let ty_list = TyVarEnv.check_poly_univars env loc new_univars in @@ -1307,7 +1313,7 @@ and transl_type_poly env ~policy ~row_context mode loc vars st = and transl_type_repr env ~policy ~row_context mode loc vars st = let sort_vars, new_univars, cty = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let vars_with_stage = List.map (fun var -> var, Env.stage env) vars in let sort_vars, new_univars = TyVarEnv.make_repr_univars vars_with_stage in let cty = TyVarEnv.with_univars new_univars begin fun () -> @@ -1315,7 +1321,7 @@ and transl_type_repr env ~policy ~row_context mode loc vars st = end in (sort_vars, new_univars, cty) end - ~post:(fun (_, _, cty) -> generalize_ctyp cty) + ~before_generalize:(fun (_, _, cty) -> generalize_ctyp cty) in let ty = cty.ctyp_type in let ty_list = TyVarEnv.check_poly_univars env loc new_univars in @@ -1347,6 +1353,7 @@ and transl_type_alias env ~row_context ~policy mode attrs styp_loc styp name_opt let cty, jkind_annot = match name_opt with | Some { txt = alias; loc = alias_loc } -> begin try + check_tyvar_name env alias_loc alias; let t, _ = TyVarEnv.lookup_local ~row_context alias in let cty = transl_type env ~policy ~aliased:true ~row_context mode styp @@ -1372,13 +1379,14 @@ and transl_type_alias env ~row_context ~policy mode attrs styp_loc styp name_opt cty, jkind_annot with Not_found -> let t, ty, jkind_annot = - with_local_level_if_principal begin fun () -> + with_local_level_generalize_structure_if_principal begin fun () -> let jkind, rigid = jkind_for_fresh_var env alias alias_loc attrs jkind_annot_opt in let t = newvar jkind in (* Use the whole location, which is used by [Type_mismatch]. *) - TyVarEnv.remember_used ~rigid alias t styp_loc (Env.stage env); + TyVarEnv.remember_used ~check:alias_loc ~rigid + alias t styp_loc (Env.stage env); let ty = transl_type env ~policy ~row_context mode styp in begin try unify_var env t ty.ctyp_type with Unify err -> let err = Errortrace.swap_unification_error err in @@ -1386,7 +1394,6 @@ and transl_type_alias env ~row_context ~policy mode attrs styp_loc styp name_opt end; (t, ty, jkind_annot_opt) end - ~post: (fun (t, _, _) -> generalize_structure t) in let t = instance t in let px = Btype.proxy t in @@ -1423,13 +1430,12 @@ and transl_type_alias env ~row_context ~policy mode attrs styp_loc styp name_opt and transl_type_aux_tuple env ~loc ~policy ~row_context stl = assert (List.length stl >= 2); + Option.iter (fun l -> raise (Error (loc, env, Repeated_tuple_label l))) + (Misc.repeated_label stl); let ctys = List.map - (fun (label, t) -> - Option.iter (fun _ -> - Language_extension.assert_enabled ~loc Labeled_tuples ()) - label; - label, transl_type env ~policy ~row_context Alloc.Const.legacy t) + (fun (l, t) -> + l, transl_type env ~policy ~row_context Alloc.Const.legacy t) stl in List.iter (fun (_, {ctyp_type; ctyp_loc}) -> @@ -1529,6 +1535,35 @@ and transl_fields env ~policy ~row_context o fields = newty (Tfield (s, field_public, ty', ty))) ty_init fields in ty, object_fields +and transl_package env ~policy ~row_context ptyp = + (* CR layouts: right now we're doing a real gross hack where we demand + everything in a package type with constraint be value. + + An alternative is to walk into the constrained module, using the + longidents, and find the actual things that need jkind checking. + See [Typemod.package_constraints_sig] for code that does a + similar traversal from a longident. + *) + (* CR layouts: and in the long term, rewrite all of this to eliminate + the [create_package_mty] hack that constructs fake source code. *) + let loc = ptyp.ppt_loc in + let l = sort_constraints_no_duplicates loc env ptyp.ppt_cstrs in + let mty = Ast_helper.Mty.mk ~loc (Pmty_ident ptyp.ppt_path) 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 Alloc.Const.legacy 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 ptyp.ppt_path.txt in + path, mty, ptys + (* 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 @@ -1575,12 +1610,13 @@ 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 Alloc.Const.legacy styp in TyVarEnv.globalize_used_variables policy env (); typ end + ~before_generalize:generalize_ctyp end in make_fixed_univars typ.ctyp_type; { typ with ctyp_type = @@ -1589,7 +1625,7 @@ let transl_simple_type_univars env styp = let transl_simple_type_delayed env mode styp = TyVarEnv.reset_locals (); let typ, force = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> let policy = TyVarEnv.make_policy Open Any in let typ = transl_type env policy mode styp in make_fixed_univars typ.ctyp_type; @@ -1599,18 +1635,32 @@ let transl_simple_type_delayed env mode styp = let force = TyVarEnv.globalize_used_variables policy env in (typ, force) end +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (* Generalize everything except the variables that were just globalized. *) ~post:(fun (typ,_) -> generalize_ctyp typ) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + (* Generalize everything except the variables that were just globalized. *) + ~post:(fun (typ,_) -> generalize_ctyp typ) +======= + (* Generalize everything except the variables that were just globalized. *) + ~before_generalize:(fun (typ,_) -> generalize_ctyp typ) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 in (typ, instance typ.ctyp_type, force) let transl_type_scheme_mono env styp = let typ = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> TyVarEnv.reset (); transl_simple_type ~new_var_jkind:Sort env ~closed:false Alloc.Const.legacy styp end +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 ~post:generalize_ctyp +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + ~post:generalize_ctyp +======= + ~before_generalize:generalize_ctyp +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 in (* This next line is very important: it stops [val] and [external] declarations from having undefaulted jkind variables. Without @@ -1621,7 +1671,7 @@ let transl_type_scheme_mono env styp = let transl_type_scheme_poly env attrs loc vars inner_type = let typed_vars, univars, typ = - with_local_level begin fun () -> + with_local_level_generalize begin fun () -> TyVarEnv.reset (); let vars = List.map (fun (n, jkind) -> (n, jkind, Env.stage env)) vars in let univars = transl_bound_vars env vars in @@ -1637,7 +1687,13 @@ let transl_type_scheme_poly env attrs loc vars inner_type = in (typed_vars, univars, typ) end +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 ~post:(fun (_,_,typ) -> generalize_ctyp typ) +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + ~post:(fun (_,_,typ) -> generalize_ctyp typ) +======= + ~before_generalize:(fun (_,_,typ) -> generalize_ctyp typ) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 in let _ : _ list = TyVarEnv.instance_poly_univars env loc univars in remove_mode_and_jkind_variables typ.ctyp_type; @@ -1725,110 +1781,120 @@ let transl_type_scheme env styp = (* Error report *) open Format_doc -open Printtyp +open Printtyp.Doc module Style = Misc.Style let pp_tag ppf t = fprintf ppf "`%s" t -let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty +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_unbound_variable_reason ppf = function +let report_unbound_variable_reason = function | Some Upstream_compatibility -> - fprintf ppf "@.Hint: Explicit quantification requires quantifying all \ + [Location.msg "Hint: Explicit quantification requires quantifying all \ type variables for compatibility with upstream OCaml.\n\ - Enable non-erasable extensions to disable this check." - | None -> () + Enable non-erasable extensions to disable this check."] + | None -> [] -let report_error_doc env ppf = - function +let report_error_doc loc env = function | Unbound_type_variable (name, in_scope_names, reason) -> - 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 ); - report_unbound_variable_reason ppf reason + Location.aligned_error_hint ~loc + "@{The type variable @}%a is unbound in this type declaration." + Style.inline_code name + (Misc.did_you_mean (Misc.spellcheck in_scope_names name)) + ~sub:(report_unbound_variable_reason reason) | No_type_wildcards reason -> - fprintf ppf "A type wildcard %a is not allowed in this type declaration." - Style.inline_code "_"; - report_unbound_variable_reason ppf reason + Location.errorf ~loc + "A type wildcard %a is not allowed in this type declaration." + Style.inline_code "_" + ~sub:(report_unbound_variable_reason reason) | Undefined_type_constructor p -> - fprintf ppf "The type constructor@ %a@ is not yet completely defined" - (Style.as_inline_code path) p + Location.errorf ~loc + "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 + Location.errorf ~loc + "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" + Location.errorf ~loc "Already bound type parameter %a" (Style.as_inline_code Pprintast.Doc.tyvar) name | Recursive_type -> - fprintf ppf "This type is recursive" + Location.errorf ~loc "This type is recursive" | Type_mismatch trace -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf env trace - (msg "This type") - (msg "should be an instance of type") + Location.errorf ~loc "%t" @@ fun ppf -> + Errortrace_report.unification ppf env trace + (msg "This type") + (msg "should be an instance of type") | Alias_type_mismatch trace -> let msg = Format_doc.Doc.msg in - Printtyp.report_unification_error ppf Env.empty trace - (msg "This alias is bound to type") - (msg "but is used as an instance of type") + Location.errorf ~loc "%t" @@ fun ppf -> + 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" + Location.errorf ~loc "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@ \ + Location.errorf ~loc + "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.@]@]" + but is present in@ its lower bound (after %a)." (Style.as_inline_code pp_tag) l Style.inline_code "<" Style.inline_code ">" Style.inline_code ">" - (Style.as_inline_code pp_tag) l + ~sub:[ + Location.msg + "@{Hint@}: Either add %a in the upper bound,@ \ + or@ remove@ it@ from the lower bound." + (Style.as_inline_code pp_tag) l + ] | Constructor_mismatch (ty, ty') -> wrap_printing_env ~error:true env (fun () -> - Printtyp.prepare_for_printing [ty; ty']; - fprintf ppf "@[%s %a@ %s@ %a@]" - "This variant type contains a constructor" - pp_type (tree_of_typexp Type ty) - "which should be" - pp_type (tree_of_typexp Type ty')) + Out_type.prepare_for_printing [ty; ty']; + Location.errorf ~loc + "This variant type contains a constructor %a@ \ + which should be@ %a" + pp_out_type (Out_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; - begin match get_desc ty with + Location.aligned_error_hint ~loc + "@{The type @}%a@ does not expand to a polymorphic variant type" + pp_type ty + begin match get_desc ty with | Tvar { name = Some s } -> (* PR#7012: help the user that wrote 'Foo instead of `Foo *) - Misc.did_you_mean ppf (fun () -> ["`" ^ s]) - | _ -> () - end + Misc.did_you_mean ["`" ^ s] + | _ -> None + end | Variant_tags (lab1, lab2) -> - fprintf ppf - "@[Variant tags %a@ and %a have the same hash value.@ %s@]" + Location.errorf ~loc + "Variant tags %a@ and %a have the same hash value.@ \ + Change one of them." (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" + Location.errorf ~loc + "The type variable name %a is not allowed in programs" Style.inline_code name | Cannot_quantify (name, reason) -> - fprintf ppf - "@[The universal type variable %a cannot be generalized:@ " - (Style.as_inline_code Pprintast.Doc.tyvar) name; - begin match reason with - | Unified v -> - fprintf ppf "it is bound to@ %a" - (Style.as_inline_code Printtyp.type_expr) v; - | Univar -> - fprintf ppf "it is already bound to another variable" - | Scope_escape -> - fprintf ppf "it escapes its scope" - end; - fprintf ppf ".@]"; + let explanation ppf reason = + match reason with + | Scope_escape -> + fprintf ppf "it escapes its scope." + | Univar -> + fprintf ppf "it is already bound to another variable." + | Unified v -> + fprintf ppf "it is bound to@ %a." pp_type v + in + Location.errorf ~loc + "The universal type variable %a cannot be generalized:@ %a" + (Style.as_inline_code Pprintast.Doc.tyvar) name + explanation reason | Bad_univar_jkind { name; jkind_info; inferred_jkind } -> - fprintf ppf + Location.errorf ~loc "@[The universal type variable %a was %s to have kind %a.@;%a@]" Pprintast.Doc.tyvar name (if jkind_info.defaulted then "defaulted" else "declared") @@ -1849,7 +1915,7 @@ let report_error_doc env ppf = inferred_jkind))) inferred_jkind | Mismatched_jkind_annotation { name; explicit_jkind; implicit_jkind } -> - fprintf ppf + Location.errorf ~loc "@[The type variable %a has conflicting kind annotations.@;\ It has an explicit annotation %a@ \ but was already implicitly annotated with %a@]" @@ -1857,29 +1923,33 @@ let report_error_doc env ppf = (Jkind.format env) explicit_jkind (Jkind.format env) implicit_jkind | Multiple_constraints_on_type s -> - fprintf ppf "Multiple constraints for type %a" + Location.errorf ~loc "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@]" + Location.errorf ~loc "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 + Location.errorf ~loc "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@]" - (Style.as_inline_code Printtyp.type_expr) ty + Location.errorf ~loc "@[The type %a@ is not an object type@]" + pp_type ty + | Repeated_tuple_label l -> + Location.errorf ~loc "@[This tuple type has two labels named %a@]" + Style.inline_code l | Unsupported_extension ext -> let ext = Language_extension.to_string ext in - fprintf ppf "@[The %s extension is disabled@ \ - To enable it, pass the '-extension %s' flag@]" ext ext + Location.errorf ~loc + "The %s extension is disabled@ \ + To enable it, pass the '-extension %s' flag@]" ext ext | Polymorphic_optional_param -> - fprintf ppf "@[Optional parameters cannot be polymorphic@]" + Location.errorf ~loc "@[Optional parameters cannot be polymorphic@]" | Non_value {vloc; typ; err} -> let s = match vloc with @@ -1887,10 +1957,9 @@ let report_error_doc env ppf = | Poly_variant -> "Polymorphic variant constructor argument" | Object_field -> "Object field" in - fprintf ppf "@[%s types must have layout value.@ %a@]" + Location.errorf ~loc "%s types must have layout value.@ %a" s (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> - Style.as_inline_code Printtyp.type_expr ppf typ) + ~offender:(fun ppf -> pp_type ppf typ) env) err | Non_sort {vloc; typ; err} -> let s = @@ -1898,30 +1967,28 @@ let report_error_doc env ppf = | Fun_arg -> "Function argument" | Fun_ret -> "Function return" in - fprintf ppf "@[%s types must have a representable layout.@ %a@]" + Location.errorf ~loc "%s types must have a representable layout.@ %a" s (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> - Style.as_inline_code Printtyp.type_expr ppf typ) + ~offender:(fun ppf -> pp_type ppf typ) env) err | Bad_jkind_annot(ty, violation) -> - fprintf ppf "@[Bad layout annotation:@ %a@]" + Location.errorf ~loc "@[Bad layout annotation:@ %a@]" (Jkind.Violation.report_with_offender - ~offender:(fun ppf -> - Style.as_inline_code Printtyp.type_expr ppf ty) + ~offender:(fun ppf -> pp_type ppf ty) env) violation | Did_you_mean_unboxed lid -> - fprintf ppf "@[%a isn't a class type.@ \ - Did you mean the unboxed type %a?@]" + Location.errorf ~loc + "%a isn't a class type.@ Did you mean the unboxed type %a?" (Style.as_inline_code longident) lid (Style.as_inline_code (fun ppf lid -> fprintf ppf "%a#" longident lid)) lid | Invalid_label_for_call_pos arg_label -> - fprintf ppf "A position argument must not be %s." + Location.errorf ~loc "A position argument must not be %s." (match arg_label with | Nolabel -> "unlabelled" | Optional _ -> "optional" | Labelled _ -> assert false ) | Invalid_variable_stage {name; intro_stage; usage_stage} -> - fprintf ppf + Location.errorf ~loc "@[@[Type variable %a is used %a,@ \ it already occurs %a.@]@,\ @[@{Hint@}: Consider using %a.@]@]" @@ -1930,7 +1997,7 @@ let report_error_doc env ppf = Env.print_stage intro_stage Env.print_with_quote_promote (name, intro_stage, usage_stage) | Lpoly_unsupported -> - fprintf ppf + Location.errorf ~loc "@[Layout polymorphism is not supported in term-level type \ annotations@]" @@ -1938,11 +2005,9 @@ let () = Location.register_error_of_exn (function | Error (loc, env, err) -> - Some (Location.error_of_printer ~loc (report_error_doc env) err) + Some (report_error_doc loc env err) | Error_forward err -> Some err | _ -> None ) - -let report_error = Format_doc.compat1 report_error_doc diff --git a/src/ocaml/typing/unit_info.ml b/src/ocaml/typing/unit_info.ml index 68a8c296e..052c8e65a 100644 --- a/src/ocaml/typing/unit_info.ml +++ b/src/ocaml/typing/unit_info.ml @@ -18,6 +18,9 @@ type modname = string type filename = string type file_prefix = string +type error = Invalid_encoding of string +exception Error of error + type t = { original_source_file: filename; raw_source_file: filename; @@ -42,34 +45,40 @@ let basename_chop_extensions basename = String.sub basename 0 pos with 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 compilation_unit_from_source ~for_pack_prefix source_file = +let lax_modname_from_source source_file = + source_file |> stem |> modulize + +let compilation_unit_from_source ~strict ~for_pack_prefix source_file = + let modname_from_source = + if strict then strict_modname_from_source + else lax_modname_from_source + in let modname = modname_from_source source_file |> Compilation_unit.Name.of_string in Compilation_unit.create for_pack_prefix modname -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 - (* 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 = let name = modname file |> Compilation_unit.name_as_string in @@ -78,7 +87,9 @@ let check_unit_name file = (Warnings.Bad_module_name name) let make ?(check_modname=true) ~source_file ~for_pack_prefix kind prefix = - let modname = compilation_unit_from_source ~for_pack_prefix prefix in + let modname = + compilation_unit_from_source ~strict:true ~for_pack_prefix prefix + in let p = { modname; @@ -124,9 +135,13 @@ module Artifact = struct let prefix x = Filename.remove_extension (filename x) let from_filename ~for_pack_prefix filename = - let modname = compilation_unit_from_source ~for_pack_prefix filename in - - { modname; filename; original_source_file = None; raw_source_file = None } + let modname = + compilation_unit_from_source ~strict:false ~for_pack_prefix filename + in + { modname; + filename; + original_source_file = None; + raw_source_file = None } end @@ -190,7 +205,22 @@ let find_normalized_cmi f = original_source_file = Some f.original_source_file; raw_source_file = Some f.raw_source_file; } +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 (* Merlin-only *) let modify_kind t ~f = { t with kind = f t.kind } +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d +======= + +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 + ) +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 diff --git a/src/ocaml/utils/linkdeps.ml b/src/ocaml/utils/linkdeps.ml new file mode 100644 index 000000000..de1adf63a --- /dev/null +++ b/src/ocaml/utils/linkdeps.ml @@ -0,0 +1,143 @@ +(**************************************************************************) +(* *) +(* 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 = Compilation_unit.t + +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 : compunit) = + 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)" + Compilation_unit.print_as_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@]" + Compilation_unit.print_as_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@]" + Compilation_unit.print_as_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..97013b8cb --- /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 = Compilation_unit.t + +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/warnings.ml b/src/ocaml/utils/warnings.ml index 2ed7f6c0d..7a55d34f1 100644 --- a/src/ocaml/utils/warnings.ml +++ b/src/ocaml/utils/warnings.ml @@ -51,6 +51,10 @@ type name_out_of_scope_warning = | Name of string | Fields of { record_form : string ; fields : string list } +type type_declaration_usage_warning = + | Declaration + | Alias + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -59,7 +63,7 @@ type t = | Ignored_partial_application (* 5 *) | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) - | Partial_match of string (* 8 *) + | Partial_match of Format_doc.t (* 8 *) | Missing_record_field_pattern of { form : string ; unbound : string } (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) @@ -86,7 +90,7 @@ type t = was turned into a hard error *) | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) - | Unused_type_declaration of string (* 34 *) + | Unused_type_declaration of string * type_declaration_usage_warning (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * constructor_usage_warning (* 37 *) @@ -129,6 +133,8 @@ type t = | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) + | Unnecessarily_partial_tuple_pattern (* 75 *) (* Oxcaml specific warnings: numbers should go down from 199 *) | Redundant_kind_modifier of string (* 183 *) | Ignored_kind_modifier of string * string list (* 184 *) @@ -136,7 +142,7 @@ type t = | Unmutated_mutable of string (* 186 *) | Incompatible_with_upstream of upstream_compat_warning (* 187 *) | Unerasable_position_argument (* 188 *) - | Unnecessarily_partial_tuple_pattern (* 189 *) + (* 189 was [Unnecessarily_partial_tuple_pattern], now upstream as 75 *) | Probe_name_too_long of string (* 190 *) | Unused_kind_declaration of string (* 191 *) | Zero_alloc_all_hidden_arrow of string (* 198 *) @@ -147,7 +153,7 @@ type t = | Modal_axis_specified_twice of { axis : string; overriden_by : string; - } (* 213 *) + } (* 213 *) | Atomic_float_record_boxed (* 214 *) | Implied_attribute of { implying: string; implied : string} (* 215 *) | Use_during_borrowing (* 216 *) @@ -239,8 +245,9 @@ let number = function | Overridden_kind_modifier _ -> 185 | Unmutated_mutable _ -> 186 | Incompatible_with_upstream _ -> 187 - | Unerasable_position_argument -> 188 - | Unnecessarily_partial_tuple_pattern -> 189 + | Degraded_to_partial_match -> 74 + | Unnecessarily_partial_tuple_pattern -> 75 + | Unerasable_position_argument -> 188 (* 189 is now upstream as 75 *) | Probe_name_too_long _ -> 190 | Unused_kind_declaration _ -> 191 | Zero_alloc_all_hidden_arrow _ -> 198 @@ -598,6 +605,16 @@ 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 }; + { number = 75; + names = ["unnecessarily-partial-tuple-pattern"]; + description = "A tuple pattern ends in .. but fully matches its expected \ + type."; + since = since 5 4 }; { number = 183; names = ["redundant-kind-modifier"]; (* CR layouts-scannable: As more axes are added, this description (and @@ -630,11 +647,7 @@ let descriptions = [ names = ["unerasable-position-argument"]; description = "Unerasable position argument."; since = since 5 1 }; - { number = 189; - names = ["unnecessarily-partial-tuple-pattern"]; - description = "A tuple pattern ends in .. but fully matches its expected \ - type."; - since = since 5 1 }; + (* 189 was [unnecessarily-partial-tuple-pattern], now upstream as 75 *) { number = 190; names = ["probe-name-too-long"]; description = "Probe name must be at most 100 characters long."; @@ -1015,7 +1028,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-183..185" +let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70-74-183..185" let defaults_warn_error = "-a" let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] @@ -1025,374 +1038,488 @@ let () = ignore @@ parse_options true defaults_warn_error let () = List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts +module Fmt = Format_doc +module Style = Misc.Style +let msg = Fmt.doc_printf +let comma_inline_list = Fmt.(pp_print_list ~pp_sep:comma Style.inline_code) +let space_inline_list ppf l = + let pp_sep = Fmt.pp_print_space in + Fmt.fprintf ppf "@[%a@]" (Fmt.pp_print_list ~pp_sep Style.inline_code) l +let expand ppf s = if s = "" then () else Fmt.fprintf ppf "@ %s" s + 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." + msg + "this %a is the start of a comment.@ \ + %t: Did you forget spaces when writing the infix operator %a?" + Style.inline_code "(*" + Style.hint + Style.inline_code "( * )" + | Comment_not_end -> msg "this is not the end of a comment." | Fragile_match "" -> - "this pattern-matching is fragile." + msg "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 ^ "." + msg "this pattern-matching is fragile.@ \ + It will remain exhaustive when constructors are added to type %a." + Style.inline_code s | Ignored_partial_application -> - "this function application is partial,\n\ - maybe some arguments are missing." + msg "this function application is partial,@ \ + maybe@ some@ arguments@ are@ missing." | Labels_omitted [] -> assert false | Labels_omitted [l] -> - "label " ^ l ^ " was omitted in the application of this function." + msg "label %a@ was omitted@ in@ the@ application@ of@ this@ function." + Style.inline_code l | Labels_omitted ls -> - "labels " ^ String.concat ", " ls ^ - " were omitted in the application of this function." + msg "labels %a@ were omitted@ in@ the@ application@ of@ this@ function." + comma_inline_list ls | Method_override [lab] -> - "the method " ^ lab ^ " is overridden." + msg "the method %a is overridden." + Style.inline_code lab | Method_override (cname :: slist) -> - String.concat " " - ("the following methods are overridden by the class" - :: cname :: ":\n " :: slist) + msg "the following methods are overridden@ by@ the@ class@ %a:@;<1 2>%a" + Style.inline_code cname + space_inline_list 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 + | Partial_match doc -> + if doc = Format_doc.Doc.empty then + msg "this pattern-matching is not exhaustive." + else + msg "this pattern-matching is not exhaustive.@ \ + @[Here is an example of a case that is not matched:@;<1 2>%a@]" + Format_doc.pp_doc doc | Missing_record_field_pattern { form ; unbound } -> - "the following labels are not bound in this " ^ form ^ " pattern:\n" ^ - unbound ^ - "\nEither bind these labels explicitly or add '; _' to the pattern." + msg "the following labels are not bound@ in@ this@ \ + %s@ pattern:@;<1 2>%a.@ \ + @[Either bind these labels explicitly or add %a to the pattern.@]" + form + Style.inline_code unbound + Style.inline_code "; _" | Non_unit_statement -> - "this expression should have type unit." - | Redundant_case -> "this match case is unused." - | Redundant_subpat -> "this sub-pattern is unused." + msg "this expression should have type unit." + | Redundant_case -> msg "this match case is unused." + | Redundant_subpat -> msg "this sub-pattern is unused." | Instance_variable_override [lab] -> - "the instance variable " ^ lab ^ " is overridden." + msg "the instance variable %a is overridden." + Style.inline_code lab | Instance_variable_override (cname :: slist) -> - String.concat " " - ("the following instance variables are overridden by the class" - :: cname :: ":\n " :: slist) + msg + "the following instance variables@ are overridden@ \ + by the class %a:@;<1 2>%a" + Style.inline_code cname + space_inline_list 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: \\\\." + msg "illegal backslash escape in string.@ \ + %t: Single backslashes %a are reserved for escape sequences@ \ + (%a, %a, ...).@ Did you check the list of OCaml escape sequences?@ \ + To get a backslash character, escape it with a second backslash: %a." + Style.hint + Style.inline_code {|\|} + Style.inline_code {|\n|} + Style.inline_code {|\r|} + Style.inline_code {|\\|} | 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." + msg + "the following private methods@ were@ made@ public@ \ + implicitly:@;<1 2>%a." + space_inline_list l + | Unerasable_optional_argument -> + msg "this optional argument cannot be erased." + | Undeclared_virtual_method m -> + msg "the virtual method %a is not declared." + Style.inline_code m + | Not_principal emsg -> + msg "%a@ is@ not@ principal." Fmt.pp_doc emsg + | Non_principal_labels s -> msg "%s without principality." s + | Ignored_extra_argument -> + msg "this argument will not be used by the function." | Nonreturning_statement -> - "this statement never returns (or has an unsound type.)" - | Preprocessor s -> s + msg "this statement never returns (or has an unsound type.)" + | Preprocessor s -> msg "%s" s | Useless_record_with s -> - "all the fields are explicitly listed in this " ^ s ^ ":\n\ - the 'with' clause is useless." + msg "all the fields are explicitly listed in this %s:@ \ + the %a clause is useless." + s + Style.inline_code "with" | Bad_module_name (modname) -> - "bad source file name: \"" ^ modname ^ "\" is not a valid module name." + msg "bad source file name: %a is not a valid module name." + Style.inline_code modname | All_clauses_guarded -> - "this pattern-matching is not exhaustive.\n\ - All clauses in this pattern-matching are guarded." + msg "this pattern-matching is not exhaustive.@ \ + All clauses in this pattern-matching are guarded." | Unused_var { name = v; mutated = false } | Unused_var_strict { name = v; mutated = false } -> - "unused variable " ^ v ^ "." + msg "unused variable %a." + Style.inline_code v | Unused_var { name = v; mutated = true } | Unused_var_strict { name = v; mutated = true } -> - "variable " ^ v ^ " was mutated but never used." + msg "variable %a was mutated but never used." + Style.inline_code v | Wildcard_arg_to_constant_constr -> - "wildcard pattern given as argument to a constant constructor" + msg "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)" + msg "unescaped end-of-line in a string constant@ \ + (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 ^ "." + msg "the %s %a is defined in both types %a and %a." + kind + Style.inline_code cname + Style.inline_code tc1 + Style.inline_code tc2 + | Unused_value_declaration v -> + msg "unused value %a." Style.inline_code v + | Unused_open s -> msg "unused open %a." Style.inline_code s + | Unused_open_bang s -> msg "unused open! %a." Style.inline_code s + | Unused_type_declaration (s, Declaration) -> + msg "unused type %a." Style.inline_code s + | Unused_type_declaration (s, Alias) -> + msg "unused type alias %a." Style.inline_code s + | Unused_for_index s -> msg "unused for-loop index %a." Style.inline_code s + | Unused_ancestor s -> msg "unused ancestor variable %a." Style.inline_code s + | Unused_constructor (s, Unused) -> + msg "unused constructor %a." Style.inline_code s | Unused_constructor (s, Not_constructed) -> - "constructor " ^ s ^ - " is never used to build values.\n\ - (However, this constructor appears in patterns.)" + msg "constructor %a is never used to build values.@ \ + (However, this constructor appears in patterns.)" + Style.inline_code s | Unused_constructor (s, Only_exported_private) -> - "constructor " ^ s ^ - " is never used to build values.\n\ - Its type is exported as a private type." + msg "constructor %a is never used to build values.@ \ + Its type is exported as a private type." + Style.inline_code s | 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 + let kind = + if is_exception then "exception" else "extension constructor" in + begin match complaint with + | Unused -> msg "unused %s %a" kind Style.inline_code s + | Not_constructed -> + msg + "%s %a is never used@ to@ build@ values.@ \ + (However, this constructor appears in patterns.)" + kind Style.inline_code s + | Only_exported_private -> + msg + "%s %a is never used@ to@ build@ values.@ \ + It is exported or rebound as a private extension." + kind Style.inline_code s + end | Unused_rec_flag -> - "unused rec flag." + msg "unused rec flag." | Name_out_of_scope (ty, Name nm) -> - 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." + msg "%a was selected from type %a.@ \ + @[It is not visible in the current scope,@ and@ will@ not@ \ + be@ selected@ if the type becomes unknown@]." + Style.inline_code nm + Style.inline_code ty | Name_out_of_scope (ty, Fields { record_form ; fields }) -> - "this " ^ record_form ^ " of type "^ ty ^" contains fields that are \n\ - not visible in the current scope: " - ^ String.concat " " fields ^ ".\n\ - They will not be selected if the type becomes unknown." + msg "this %s of type %a@ contains@ fields@ that@ are@ \ + not@ visible in the current scope:@;<1 2>%a.@ \ + @[They will not be selected@ if the type@ becomes@ unknown.@]" + record_form + Style.inline_code ty + space_inline_list fields | 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 + msg "%a belongs to several types:@;<1 2>%a.@ \ + The first one was selected.@ \ + @[Please disambiguate@ if@ this@ is wrong.%a@]" + Style.inline_code s + space_inline_list tl + expand 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 + msg "these field labels belong to several types:@;<1 2>%a.@ \ + @[The first one was selected.@ \ + Please disambiguate@ if@ this@ is@ wrong.%a@]" + space_inline_list tl + expand expansion | Disambiguated_name s -> - "this use of " ^ s ^ " relies on type-directed disambiguation,\n\ - it will not compile with OCaml 4.00 or earlier." + msg "this use of %a@ relies@ on@ type-directed@ disambiguation,@ \ + @[it@ will@ not@ compile@ with@ OCaml@ 4.00@ or@ earlier.@]" + Style.inline_code s | Nonoptional_label s -> - "the label " ^ s ^ " is not optional." + msg "the label %a is not optional." + Style.inline_code s | Open_shadow_identifier (kind, s) -> - Printf.sprintf - "this open statement shadows the %s identifier %s (which is later used)" - kind s + msg + "this open statement shadows@ the@ %s identifier@ %a@ \ + (which is later used)" + kind Style.inline_code s | Open_shadow_label_constructor (kind, s) -> - Printf.sprintf - "this open statement shadows the %s %s (which is later used)" - kind s + msg + "this open statement shadows@ the@ %s %a@ (which is later used)" + kind Style.inline_code s | Bad_env_variable (var, s) -> - Printf.sprintf "illegal environment variable %s : %s" var s + msg "illegal environment variable %a : %s" + Style.inline_code var + s | Attribute_payload (a, s) -> - Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s + msg "illegal payload for attribute %a.@ %s" + Style.inline_code a + s | Eliminated_optional_arguments sl -> - Printf.sprintf "implicit elimination of optional argument%s %s" + msg "implicit elimination@ of optional argument%s@ %a" (if List.length sl = 1 then "" else "s") - (String.concat ", " sl) + comma_inline_list 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 + msg "no cmi file was found@ in path for module %a" + Style.inline_code name + | No_cmi_file(name, Some wmsg) -> + msg + "no valid cmi file was found@ in path for module %a.@ %s" + Style.inline_code name + wmsg | Unexpected_docstring unattached -> - if unattached then "unattached documentation comment (ignored)" - else "ambiguous documentation comment" + if unattached then msg "unattached documentation comment (ignored)" + else msg "ambiguous documentation comment" | Wrong_tailcall_expectation b -> - Printf.sprintf "expected %s" + msg "expected %s" (if b then "tailcall" else "non-tailcall") | Fragile_literal_pattern -> +<<<<<<< janestreet/merlin-jst:merge-5.4-minus37 let 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 +||||||| oxcaml/oxcaml.git:eb63e0e41869ede83ad3001e4facdff54383861d + 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 +======= + let[@manual.ref "ss:warn52"] ref_manual = [ 13; 5; 3 ] in + msg + "Code should not depend@ on@ the@ actual@ values of@ \ + this@ constructor's arguments.@ @[They are only for@ information@ \ + and@ may@ change@ in@ future versions.@ %a@]" + Misc.print_see_manual ref_manual +>>>>>>> oxcaml/oxcaml.git:02fe39378b978707317bd53e622d9ab6d6ba9751 | Unreachable_case -> - "this match case is unreachable.\n\ - Consider replacing it with a refutation case ' -> .'" + msg "this match case is unreachable.@ \ + Consider replacing it with a refutation case %a" + Style.inline_code " -> ." | Misplaced_attribute attr_name -> - Printf.sprintf "the %S attribute cannot appear in this context" attr_name + msg "the %a attribute cannot appear in this context" + Style.inline_code attr_name | Duplicated_attribute attr_name -> - Printf.sprintf "the %S attribute is used more than once on this \ - expression" - attr_name + msg "the %a attribute is used more than once@ on@ this@ \ + expression" + Style.inline_code attr_name | Inlining_impossible reason -> - Printf.sprintf "Cannot inline: %s" reason + msg "Cannot inline:@ %s" reason | Ambiguous_var_in_pattern_guard vars -> let 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 + | [x] -> + Fmt.dprintf + "variable %a appears in@ different@ places@ in@ \ + different@ or-pattern@ alternatives." + Style.inline_code x | _::_ -> - let vars = String.concat ", " vars in - "variables " ^ vars ^ " appear " ^ in_different_places + Fmt.dprintf + "variables %a appears in@ different@ places@ in@ \ + different@ or-pattern@ alternatives." + comma_inline_list vars 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 + msg + "Ambiguous or-pattern variables under@ guard;@ \ + %t@ \ + @[Only the first match will be used to evaluate@ \ + the@ guard@ expression.@ %a@]" + vars_explanation + Misc.print_see_manual ref_manual | No_cmx_file { missing_extension; module_name } -> - Printf.sprintf - "no %s file was found in path for module %s, \ - and its interface was not compiled with -opaque" - missing_extension module_name + msg + "no %s file was found@ in@ path@ for@ module@ %a,@ \ + and@ its@ interface@ was@ not@ compiled@ with %a" + missing_extension + Style.inline_code module_name + Style.inline_code "-opaque" | 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 ^ "." + msg + "A potential@ assignment@ to@ a@ non-mutable@ value@ was@ detected@ \ + in@ this@ source@ file.@ \ + Such@ assignments@ may@ generate@ incorrect@ code@ \ + when@ using@ Flambda." + | Unused_module s -> msg "unused module %a." Style.inline_code 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 + msg + "This primitive declaration uses type %a,@ whose@ representation@ \ + may be either boxed or unboxed.@ Without@ an@ annotation@ to@ \ + indicate@ which@ representation@ is@ intended,@ the@ boxed@ \ + representation@ has@ been@ selected@ by@ default.@ This@ default@ \ + choice@ may@ change@ in@ future@ versions@ of@ the@ compiler,@ \ + breaking@ the@ primitive@ implementation.@ You@ should@ explicitly@ \ + annotate@ the@ declaration@ of@ %a@ with@ %a@ or@ %a,@ so@ that@ its@ \ + external@ interface@ remains@ stable@ in@ the future." + Style.inline_code t + Style.inline_code t + Style.inline_code "[@@boxed]" + Style.inline_code "[@@unboxed]" | Constraint_on_gadt -> - "Type constraints do not apply to GADT cases of variant types." + msg "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." - ^ s - ^ "\nBeware that this warning is purely informational and will not catch\n\ - all instances of erroneous printed interface." + msg + "The printed@ interface@ differs@ from@ the@ inferred@ interface.@ \ + The@ inferred@ interface@ contained@ items@ which@ could@ not@ be@ \ + printed@ properly@ due@ to@ name@ collisions@ between@ identifiers.@ \ + %s@ \ + Beware@ that@ this@ warning@ is@ purely@ informational@ and@ will@ \ + not@ catch@ all@ instances@ of@ erroneous@ printed@ interface." + s | Unsafe_array_syntax_without_parsing -> - "option -unsafe used with a preprocessor returning a syntax tree" + msg "option@ %a@ used with a preprocessor returning@ a@ syntax tree" + Style.inline_code "-unsafe" | 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 ^ "." + let def ppf name = Fmt.fprintf ppf "type %s = unit" name in + msg + "This type declaration is@ defining@ a new %a constructor@ \ + which@ shadows@ the@ existing@ one.@ \ + %t: Did you mean %a?" + Style.inline_code "()" + Style.hint + (Style.as_inline_code def) name + | Unused_functor_parameter s -> + msg "unused functor parameter %a." Style.inline_code 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." + msg + "This pattern depends on@ mutable@ state.@ It prevents@ the@ \ + remaining@ arguments@ from@ being@ uncurried,@ which will@ cause@ \ + additional@ closure@ allocations." | Unused_field { form; field; complaint = Unused } -> - "unused " ^ form ^ " field " ^ field ^ "." + msg "unused %s field %a." form Style.inline_code field | Unused_field { form; field; complaint = Not_read } -> - form ^ " field " ^ field ^ - " is never read.\n\ - (However, this field is used to build or mutate values.)" + msg "%s field %a is never read.@ \ + (However, this field is used to build or mutate values.)" + form Style.inline_code field | Unused_field { form; field; complaint = Not_mutated } -> - "mutable " ^ form ^ " field " ^ field ^ - " is never mutated." + msg "mutable %s field %a is never mutated." + form Style.inline_code field | Missing_mli -> - "Cannot find interface file." + msg "Cannot find interface file." | Unused_tmc_attribute -> - "This function is marked @tail_mod_cons\n\ - but is never applied in TMC position." + msg "This function is marked %a@ \ + but is never applied in TMC position." + Style.inline_code "@tail_mod_cons" | 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." + msg "This call@ is@ in@ tail-modulo-cons@ position@ in@ a@ TMC@ \ + function,@ but@ the@ function@ called@ is@ not@ itself@ \ + specialized@ for@ TMC,@ so@ the@ call@ will@ not@ be@ transformed@ \ + into@ a@ tail@ call.@ \ + @[Please@ either@ mark@ the@ called@ function@ with@ the %a@ \ + attribute,@ or@ mark@ this@ call@ with@ the@ %a@ attribute@ to@ \ + make@ its@ non-tailness@ explicit.@]" + Style.inline_code "[@tail_mod_cons]" + Style.inline_code "[@tailcall false]" | Generative_application_expects_unit -> - "A generative functor\n\ - should be applied to '()'; using '(struct end)' is deprecated." + msg "A generative functor@ \ + should be applied@ to@ %a;@ using@ %a@ is deprecated." + Style.inline_code "()" + Style.inline_code "(struct end)" + | Degraded_to_partial_match -> + let[@manual.ref "ss:warn74"] ref_manual = [ 13; 5; 5 ] in + msg + "This pattern-matching@ is@ compiled@ as@ partial,@ even@ if@ it@ \ + appears@ to@ be@ total.@ It@ may@ generate@ a@ %a@ exception.@ This@ \ + typically@ occurs@ due@ to@ complex@ matches@ on@ mutable@ fields.@ %a" + Style.inline_code "Match_failure" + Misc.print_see_manual ref_manual | Redundant_kind_modifier abbrev -> - "This kind modifier is already implied by the kind \"" ^ abbrev ^ "\"." + msg "This kind modifier is already implied by the kind %a." + Style.inline_code abbrev | Ignored_kind_modifier (abbrev, modifiers) -> - Printf.sprintf - "The kind modifier(s) \"%s\" have no effect on the kind \"%s\"." - (String.concat " " modifiers) abbrev + msg "The kind modifier(s) %a have no effect on the kind %a." + Style.inline_code (String.concat " " modifiers) Style.inline_code abbrev | Overridden_kind_modifier overridden_by -> - "This kind modifier is overridden by \"" ^ overridden_by ^ "\" later." - | Unmutated_mutable v -> "mutable variable " ^ v ^ " was never mutated." + msg "This kind modifier is overridden by %a later." + Style.inline_code overridden_by + | Incompatible_with_upstream Unpacked_attribute -> + msg "[@@unpacked] is not supported by upstream OCaml." + | Unnecessarily_partial_tuple_pattern -> + msg + "This tuple pattern@ unnecessarily@ ends in %a,@ as@ it@ explicitly@ \ + matches@ all@ components@ of@ its@ expected@ type." + Style.inline_code ".." + | Unmutated_mutable v -> + msg "mutable variable %a was never mutated." Style.inline_code v | Incompatible_with_upstream (Non_value_sort layout) -> - Printf.sprintf - "External declaration here is not upstream compatible. \n\ - The only types with non-value layouts allowed are float#, \n\ - int32#, int64#, and nativeint#. Unknown type with layout \n\ - %s encountered." - layout + msg "External declaration here is not upstream compatible.@ \ + @[The only types with non-value layouts allowed are@ \ + float#, int32#, int64#, and nativeint#.@ \ + Unknown type with layout@ %s encountered.@]" layout | Incompatible_with_upstream (Unboxed_attribute layout) -> - Printf.sprintf - "[@unboxed] attribute must be added to external declaration \n\ - argument type with layout %s for upstream compatibility." - layout + msg "%a attribute must be added@ to@ external@ declaration@ \ + argument type with layout %s for upstream compatibility." + Style.inline_code "[@unboxed]" layout | Incompatible_with_upstream Immediate_void_variant -> - "This variant is immediate \n\ - because all its constructors have all-void arguments, but after \n\ - erasure for upstream compatibility, void is no longer zero-width, \n\ - so it won't be immediate." + msg "This variant is immediate@ \ + because all its constructors have all-void arguments,@ \ + @[but after erasure for upstream compatibility,@ \ + void is no longer zero-width,@ so it won't be immediate.@]" | Incompatible_with_upstream Separability_check -> - "This type relies on OxCaml's extended separability checking \n\ - and would not be accepted by upstream OCaml." - | Incompatible_with_upstream Unpacked_attribute -> - "[@unpacked] is not supported by upstream OCaml." - | Unerasable_position_argument -> "this position argument cannot be erased." - | Unnecessarily_partial_tuple_pattern -> - "This tuple pattern\n\ - unnecessarily ends in '..', as it explicitly matches all components\n\ - of its expected type." + msg "This type relies on OxCaml's extended separability checking@ \ + and would not be accepted by upstream OCaml." + | Unerasable_position_argument -> + msg "this position argument cannot be erased." | Probe_name_too_long name -> - Printf.sprintf - "This probe name is too long: `%s'. \ - Probe names must be at most 100 characters long." name + msg "This probe name is too long: %a.@ \ + Probe names must be at most 100 characters long." + Style.inline_code name | Unused_kind_declaration s -> - "unused kind " ^ s ^ "." + msg "unused kind %a." Style.inline_code s | Zero_alloc_all_hidden_arrow s -> - Printf.sprintf - "The type of this item is an\n\ - alias of a function type, but the [@@@zero_alloc %s] attribute for\n\ - this signature does not apply to it because its type is not\n\ - syntactically a function type. If it should be checked, use an\n\ - explicit zero_alloc attribute with an arity. If not, use an explicit\n\ - zero_alloc ignore attribute." s + msg "The type of this item is an@ alias of a function type,@ \ + but the %a attribute for@ this signature does not apply to it@ \ + because its type is not syntactically a function type.@ \ + @[If it should be checked, use an explicit zero_alloc attribute@ \ + with an arity.@ If not, use an explicit zero_alloc ignore attribute.@]" + Style.inline_code (Printf.sprintf "[@@@zero_alloc %s]" s) | Unchecked_zero_alloc_attribute -> - Printf.sprintf "the zero_alloc attribute cannot be checked.\n\ - The function it is attached to was optimized away. \n\ - You can try to mark this function as [@inline never] \n\ - or move the attribute to the relevant callers of this function." + msg "the zero_alloc attribute cannot be checked.@ \ + @[The function it is attached to was optimized away.@ \ + You can try to mark this function as %a@ \ + or move the attribute to the relevant callers of this function.@]" + Style.inline_code "[@inline never]" | Unboxing_impossible -> - Printf.sprintf - "This [@unboxed] attribute cannot be used.\n\ - The type of this value does not allow unboxing." + msg "This %a attribute cannot be used.@ \ + The type of this value does not allow unboxing." + Style.inline_code "[@unboxed]" | Mod_by_top modifier -> - Printf.sprintf - "%s is the top-most modifier.\n\ - Modifying by a top element is a no-op." - modifier + msg "%s is the top-most modifier.@ \ + Modifying by a top element is a no-op." modifier | Modal_axis_specified_twice {axis; overriden_by} -> - Printf.sprintf - "This %s is overriden by %s later." - axis overriden_by + msg "This %s is overridden by %s later." axis overriden_by | Atomic_float_record_boxed -> - Printf.sprintf - "This record contains atomic\n\ - float fields, which prevents the float record optimization. The\n\ - fields of this record will be boxed instead of being\n\ - represented as a flat float array." + msg "This record contains atomic float fields,@ \ + which prevents the float record optimization.@ \ + @[The fields of this record will be boxed instead of being@ \ + represented as a flat float array.@]" | Implied_attribute { implying; implied } -> - Printf.sprintf - "attribute [@%s] is unused because it is implied by [@%s]" - implied implying + msg "attribute %a is unused because it is implied by %a" + Style.inline_code (Printf.sprintf "[@%s]" implied) + Style.inline_code (Printf.sprintf "[@%s]" implying) | Use_during_borrowing -> - "This value is used while being borrowed." + msg "This value is used while being borrowed." | Useless_lpoly -> - "This binding has no layout variables, so \"poly_\" has no effect. \ - Consider using a regular \"let\" instead." + msg "This binding has no layout variables, so poly_ has no effect. \ + Consider using a regular let instead." | Lpoly_in_letrec -> - "\"poly_\" has no effect in recursive bindings, which do not support \ - layout polymorphism. Consider using a regular \"let rec\" instead." + msg "poly_ has no effect in recursive bindings, which do not support \ + layout polymorphism. Consider using a regular let rec instead." ;; let nerrors = ref 0 type reporting_information = { id : string - ; message : string + ; message : Fmt.doc ; is_error : bool - ; sub_locs : (loc * string) list; + ; sub_locs : (loc * Fmt.doc) list; } let id_name w = @@ -1424,7 +1551,7 @@ let report_alert (alert : alert) = | true -> let is_error = alert_is_error alert in if is_error then incr nerrors; - let message = Misc.normalise_eol alert.message in + let message = msg "%s" (Misc.normalise_eol alert.message) in (* Reduce \r\n to \n: - Prevents any \r characters being printed on Unix when processing Windows sources @@ -1434,8 +1561,8 @@ let report_alert (alert : alert) = let sub_locs = if not alert.def.loc_ghost && not alert.use.loc_ghost then [ - alert.def, "Definition"; - alert.use, "Expected signature"; + alert.def, msg "Definition"; + alert.use, msg "Expected signature"; ] else []