diff --git a/CHANGES.md b/CHANGES.md index 0128c27a1d..06b4205eb7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,7 +8,8 @@ profile. This started with version 0.26.0. ### Highlight -- \* Support OCaml 5.5 syntax (#2772, #2774, #2775, #2777, #2780, #2781, @Julow) +- \* Support OCaml 5.5 syntax + (#2772, #2774, #2775, #2777, #2780, #2781, #2782, @Julow) The update brings several tiny changes, they are listed below. - \* Update Odoc's parser to 3.0 (#2757, @Julow) diff --git a/lib/Ast.ml b/lib/Ast.ml index 517c60f38a..81a6099d77 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -966,7 +966,9 @@ end = struct | Pconstraint t -> f t | Pcoerce (t1, t2) -> Option.exists t1 ~f || f t2 in - let check_package_type ptyp = List.exists ptyp.ppt_cstrs ~f:snd_f in + let check_package_type ptyp = + List.exists ptyp.ppt_constraints ~f:snd_f + in match ctx with | Pld (PTyp t1) -> assert (typ == t1) | Pld _ -> assert false @@ -995,10 +997,10 @@ end = struct | Ptyp_class (_, l) -> assert (List.exists l ~f) | Ptyp_functor (_, _, ptyp, rhs) -> assert (rhs == typ || check_package_type ptyp) ) - | Td {ptype_params; ptype_cstrs; ptype_kind; ptype_manifest; _} -> + | Td {ptype_params; ptype_constraints; ptype_kind; ptype_manifest; _} -> assert ( List.exists ptype_params ~f:fst_f - || List.exists ptype_cstrs ~f:(fun (t1, t2, _) -> + || List.exists ptype_constraints ~f:(fun (t1, t2, _) -> typ == t1 || typ == t2 ) || ( match ptype_kind with | Ptype_variant cd1N -> diff --git a/lib/Exposed.ml b/lib/Exposed.ml index 5dc37d40b9..dcd43172e8 100644 --- a/lib/Exposed.ml +++ b/lib/Exposed.ml @@ -60,7 +60,7 @@ module Right = struct let type_declaration = function | {ptype_attributes= {attrs_after= _ :: _; _}; _} -> false - | {ptype_cstrs= _ :: _ as cstrs; _} -> + | {ptype_constraints= _ :: _ as cstrs; _} -> (* type a = ... constraint left = < ... > *) list ~elt:(fun (_left, right, _loc) -> core_type right) cstrs | {ptype_kind= Ptype_open | Ptype_record _ | Ptype_external _; _} -> diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f76acf0981..2d7bbc31a0 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1099,12 +1099,12 @@ and fmt_package_type_cnstrs c ctx cnstrs = list_fl cnstrs fmt_cstr and fmt_package_type c ctx ~parens ~pro ptyp = - let {ppt_path; ppt_cstrs; ppt_attrs; ppt_loc} = ptyp in + let {ppt_path; ppt_constraints; ppt_attrs; ppt_loc} = ptyp in Cmts.fmt c ppt_loc (hvbox 2 (Params.parens_if parens c.conf ( hovbox 0 (pro $ fmt_longident_loc c ppt_path) - $ fmt_package_type_cnstrs c ctx ppt_cstrs + $ fmt_package_type_cnstrs c ctx ppt_constraints $ fmt_attributes c ppt_attrs ) ) ) and fmt_row_field c ctx {prf_desc; prf_attributes; prf_loc} = @@ -3478,7 +3478,7 @@ and fmt_type_declaration c ?(kw = "") ?(nonrec_kw = "") ?name ?(eq = "=") @@ let { ptype_name= {txt; loc} ; ptype_params - ; ptype_cstrs + ; ptype_constraints ; ptype_kind ; ptype_private= priv ; ptype_manifest= m @@ -3574,7 +3574,7 @@ and fmt_type_declaration c ?(kw = "") ?(nonrec_kw = "") ?name ?(eq = "=") ( doc_before $ hvbox 0 ( hvbox c.conf.fmt_opts.type_decl_indent.v - (fmt_manifest_kind $ fmt_cstrs ptype_cstrs) + (fmt_manifest_kind $ fmt_cstrs ptype_constraints) $ fmt_item_attributes c ~pre:(Break (1, 0)) attrs_after ) $ doc_after ) @@ -4549,7 +4549,8 @@ and fmt_module_expr ?(dock_struct = true) c ({ast= m; ctx= ctx0} as xmod) = $ after ) } | Pmod_unpack (e, ty1, ty2) -> let package_type sep - {ppt_path= lid; ppt_cstrs= cstrs; ppt_attrs= attrs; ppt_loc} = + {ppt_path= lid; ppt_constraints= cstrs; ppt_attrs= attrs; ppt_loc} + = (* TODO: Use [fmt_package_type]. *) break 1 (Params.Indent.mod_unpack_annot c.conf) $ hovbox 0 diff --git a/vendor/ocaml-common/location.ml b/vendor/ocaml-common/location.ml index 75cd680b11..f6c508cdfe 100644 --- a/vendor/ocaml-common/location.ml +++ b/vendor/ocaml-common/location.ml @@ -73,6 +73,8 @@ type 'a loc = { let mkloc txt loc = { txt ; loc } let mknoloc txt = mkloc txt none +let map f x = { x with txt = f x.txt } + (******************************************************************************) (* Input info *) @@ -749,22 +751,15 @@ 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_txt ppf txt = Format.fprintf ppf "%a" Fmt.Doc.format txt in let pp_footnote ppf f = Option.iter (Format.fprintf ppf "@,%a" pp_txt) f in - let pp self ppf report = - setup_tags (); - separate_new_message ppf; - (* Make sure we keep [num_loc_lines] updated. - The tabulation box is here to give submessage the option - to be aligned with the main message box - *) - print_updating_num_loc_lines ppf (fun ppf () -> - Format.fprintf ppf "@[%a%a%a: %a%a%a%a%a@]@." + 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 @@ -773,7 +768,30 @@ let batch_mode_printer : report_printer = (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@}" @@ -796,9 +814,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 @@ -864,6 +885,18 @@ let mkerror loc sub footnote txt = let errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) = Fmt.kdoc_printf (mkerror loc sub footnote) +(* Removed because it's unused and pulls more dependencies. +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) @@ -881,11 +914,10 @@ 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; footnote=None } @@ -953,7 +985,7 @@ let auto_include_alert lib = {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} in - prerr_alert none alert + prerr_alert (in_file !input_name) alert let deprecated_script_alert program = let message = Fmt.asprintf "\ diff --git a/vendor/ocaml-common/location.mli b/vendor/ocaml-common/location.mli index 31d2203521..15d8be6e4d 100644 --- a/vendor/ocaml-common/location.mli +++ b/vendor/ocaml-common/location.mli @@ -26,7 +26,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. @@ -71,6 +95,7 @@ type 'a loc = { val mknoloc : 'a -> 'a loc val mkloc : 'a -> t -> 'a loc +val map : ('a -> 'b) -> 'a loc -> 'b loc (** {1 Input info} *) @@ -233,7 +258,7 @@ type report_printer = { Format.formatter -> Format_doc.t -> unit; } (** A printer for [report]s, defined using open-recursion. - The goal is to make it easy to define new printers by re-using code from + The goal is to make it easy to define new printers by reusing code from existing ones. *) @@ -338,6 +363,15 @@ val error: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> string -> error val errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> ('a, Format_doc.formatter, unit, error) format4 -> 'a +(* +val 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 diff --git a/vendor/ocaml-common/warnings.ml b/vendor/ocaml-common/warnings.ml index dd8e744395..fa58cb3fc0 100644 --- a/vendor/ocaml-common/warnings.ml +++ b/vendor/ocaml-common/warnings.ml @@ -34,6 +34,10 @@ type constructor_usage_warning = | Not_constructed | Only_exported_private +type type_declaration_usage_warning = + | Declaration + | Alias + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -42,7 +46,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 string (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) @@ -52,7 +56,7 @@ type t = | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) | Undeclared_virtual_method of string (* 17 *) - | Not_principal of string (* 18 *) + | Not_principal of Format_doc.t (* 18 *) | Non_principal_labels of string (* 19 *) | Ignored_extra_argument (* 20 *) | Nonreturning_statement (* 21 *) @@ -65,10 +69,11 @@ type t = | Wildcard_arg_to_constant_constr (* 28 *) | Eol_in_string (* 29 *) | Duplicate_definitions of string * string * string * string (*30 *) - | Module_linked_twice of string * string * string (* 31 *) + (* [Module_linked_twice of string * string * string] (* 31 *) + was turned into a hard error *) | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) - | Unused_type_declaration of string (* 34 *) + | Unused_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 *) @@ -105,7 +110,11 @@ type t = | Match_on_mutable_state_prevent_uncurry (* 68 *) | Unused_field of string * field_usage_warning (* 69 *) | Missing_mli (* 70 *) -;; + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) + | Unnecessarily_partial_tuple_pattern (* 75 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -145,7 +154,6 @@ let number = function | Wildcard_arg_to_constant_constr -> 28 | Eol_in_string -> 29 | Duplicate_definitions _ -> 30 - | Module_linked_twice _ -> 31 | Unused_value_declaration _ -> 32 | Unused_open _ -> 33 | Unused_type_declaration _ -> 34 @@ -185,181 +193,373 @@ let number = function | Match_on_mutable_state_prevent_uncurry -> 68 | Unused_field _ -> 69 | Missing_mli -> 70 + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 + | Generative_application_expects_unit -> 73 + | Degraded_to_partial_match -> 74 + | Unnecessarily_partial_tuple_pattern -> 75 ;; +(* DO NOT REMOVE the ;; above: it is used by + the testsuite/ests/warnings/mnemonics.mll test to determine where + the definition of the number function above ends *) -let last_warning_number = 70 -;; +let last_warning_number = 75 + +type description = + { number : int; + names : string list; + (* The first element of the list is the current name, any following ones are + deprecated. The current name should always be derived mechanically from + the constructor name. *) + description : string; + since : Sys.ocaml_release_info option; + (* The compiler version introducing this warning; only tagged for warnings + created after 3.12, which introduced the numbered syntax. *) + } -(* Third component of each tuple is the list of names for each warning. The - first element of the list is the current name, any following ones are - deprecated. The current name should always be derived mechanically from the - constructor name. *) +let since major minor = Some { Sys.major; minor; patchlevel=0; extra=None } -let descriptions = - [ - 1, "Suspicious-looking start-of-comment mark.", - ["comment-start"]; - 2, "Suspicious-looking end-of-comment mark.", - ["comment-not-end"]; - 3, "Deprecated synonym for the 'deprecated' alert.", - []; - 4, "Fragile pattern matching: matching that will remain complete even\n\ - \ if additional constructors are added to one of the variant types\n\ - \ matched.", - ["fragile-match"]; - 5, "Partially applied function: expression whose result has function\n\ - \ type and is ignored.", - ["ignored-partial-application"]; - 6, "Label omitted in function application.", - ["labels-omitted"]; - 7, "Method overridden.", - ["method-override"]; - 8, "Partial match: missing cases in pattern-matching.", - ["partial-match"]; - 9, "Missing fields in a record pattern.", - ["missing-record-field-pattern"]; - 10, - "Expression on the left-hand side of a sequence that doesn't have type\n\ - \ \"unit\" (and that is not a function, see warning number 5).", - ["non-unit-statement"]; - 11, "Redundant case in a pattern matching (unused match case).", - ["redundant-case"]; - 12, "Redundant sub-pattern in a pattern-matching.", - ["redundant-subpat"]; - 13, "Instance variable overridden.", - ["instance-variable-override"]; - 14, "Illegal backslash escape in a string constant.", - ["illegal-backslash"]; - 15, "Private method made public implicitly.", - ["implicit-public-methods"]; - 16, "Unerasable optional argument.", - ["unerasable-optional-argument"]; - 17, "Undeclared virtual method.", - ["undeclared-virtual-method"]; - 18, "Non-principal type.", - ["not-principal"]; - 19, "Type without principality.", - ["non-principal-labels"]; - 20, "Unused function argument.", - ["ignored-extra-argument"]; - 21, "Non-returning statement.", - ["nonreturning-statement"]; - 22, "Preprocessor warning.", - ["preprocessor"]; - 23, "Useless record \"with\" clause.", - ["useless-record-with"]; - 24, - "Bad module name: the source file name is not a valid OCaml module name.", - ["bad-module-name"]; - 25, "Ignored: now part of warning 8.", - []; - 26, +let descriptions = [ + { number = 1; + names = ["comment-start"]; + description = "Suspicious-looking start-of-comment mark."; + since = None }; + { number = 2; + names = ["comment-not-end"]; + description = "Suspicious-looking end-of-comment mark."; + since = None }; + { number = 3; + names = []; + description = "Deprecated synonym for the 'deprecated' alert."; + since = None }; + { number = 4; + names = ["fragile-match"]; + description = + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched."; + since = None }; + { number = 5; + names = ["ignored-partial-application"]; + description = + "Partially applied function: expression whose result has function\n\ + \ type and is ignored."; + since = None }; + { number = 6; + names = ["labels-omitted"]; + description = "Label omitted in function application."; + since = None }; + { number = 7; + names = ["method-override"]; + description = "Method overridden."; + since = None }; + { number = 8; + names = ["partial-match"]; + description = "Partial match: missing cases in pattern-matching."; + since = None }; + { number = 9; + names = ["missing-record-field-pattern"]; + description = "Missing fields in a record pattern."; + since = None }; + { number = 10; + names = ["non-unit-statement"]; + description = + "Expression on the left-hand side of a sequence that doesn't have type\n\ + \ \"unit\" (and that is not a function, see warning number 5)."; + since = None }; + { number = 11; + names = ["redundant-case"]; + description = + "Redundant case in a pattern matching (unused match case)."; + since = None }; + { number = 12; + names = ["redundant-subpat"]; + description = "Redundant sub-pattern in a pattern-matching." ; + since = None}; + { number = 13; + names = ["instance-variable-override"]; + description = "Instance variable overridden."; + since = None }; + { number = 14; + names = ["illegal-backslash"]; + description = "Illegal backslash escape in a string constant."; + since = None }; + { number = 15; + names = ["implicit-public-methods"]; + description = "Private method made public implicitly."; + since = None }; + { number = 16; + names = ["unerasable-optional-argument"]; + description = "Unerasable optional argument."; + since = None }; + { number = 17; + names = ["undeclared-virtual-method"]; + description = "Undeclared virtual method."; + since = None }; + { number = 18; + names = ["not-principal"]; + description = "Non-principal type."; + since = None }; + { number = 19; + names = ["non-principal-labels"]; + description = "Type without principality."; + since = None }; + { number = 20; + names = ["ignored-extra-argument"]; + description = "Unused function argument."; + since = None }; + { number = 21; + names = ["nonreturning-statement"]; + description = "Non-returning statement."; + since = None }; + { number = 22; + names = ["preprocessor"]; + description = "Preprocessor warning."; + since = None }; + { number = 23; + names = ["useless-record-with"]; + description = "Useless record \"with\" clause."; + since = None }; + { number = 24; + names = ["bad-module-name"]; + description = + "Bad module name: the source file name is not a valid OCaml module name."; + since = None }; + { number = 25; + names = []; + description = "Ignored: now part of warning 8."; + since = None }; + { number = 26; + names = ["unused-var"]; + description = "Suspicious unused variable: unused variable that is bound\n\ \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character.", - ["unused-var"]; - 27, "Innocuous unused variable: unused variable that is not bound with\n\ - \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character.", - ["unused-var-strict"]; - 28, "Wildcard pattern given as argument to a constant constructor.", - ["wildcard-arg-to-constant-constr"]; - 29, "Unescaped end-of-line in a string constant (non-portable code).", - ["eol-in-string"]; - 30, "Two labels or constructors of the same name are defined in two\n\ - \ mutually recursive types.", - ["duplicate-definitions"]; - 31, "A module is linked twice in the same executable.", - ["module-linked-twice"]; - 32, "Unused value declaration.", - ["unused-value-declaration"]; - 33, "Unused open statement.", - ["unused-open"]; - 34, "Unused type declaration.", - ["unused-type-declaration"]; - 35, "Unused for-loop index.", - ["unused-for-index"]; - 36, "Unused ancestor variable.", - ["unused-ancestor"]; - 37, "Unused constructor.", - ["unused-constructor"]; - 38, "Unused extension constructor.", - ["unused-extension"]; - 39, "Unused rec flag.", - ["unused-rec-flag"]; - 40, "Constructor or label name used out of scope.", - ["name-out-of-scope"]; - 41, "Ambiguous constructor or label name.", - ["ambiguous-name"]; - 42, "Disambiguated constructor or label name (compatibility warning).", - ["disambiguated-name"]; - 43, "Nonoptional label applied as optional.", - ["nonoptional-label"]; - 44, "Open statement shadows an already defined identifier.", - ["open-shadow-identifier"]; - 45, "Open statement shadows an already defined label or constructor.", - ["open-shadow-label-constructor"]; - 46, "Error in environment variable.", - ["bad-env-variable"]; - 47, "Illegal attribute payload.", - ["attribute-payload"]; - 48, "Implicit elimination of optional arguments.", - ["eliminated-optional-arguments"]; - 49, "Absent cmi file when looking up module alias.", - ["no-cmi-file"]; - 50, "Unexpected documentation comment.", - ["unexpected-docstring"]; - 51, "Function call annotated with an incorrect @tailcall attribute", - ["wrong-tailcall-expectation"]; - 52, "Fragile constant pattern.", - ["fragile-literal-pattern"]; - 53, "Attribute cannot appear in this context.", - ["misplaced-attribute"]; - 54, "Attribute used more than once on an expression.", - ["duplicated-attribute"]; - 55, "Inlining impossible.", - ["inlining-impossible"]; - 56, "Unreachable case in a pattern-matching (based on type information).", - ["unreachable-case"]; - 57, "Ambiguous or-pattern variables under guard.", - ["ambiguous-var-in-pattern-guard"]; - 58, "Missing cmx file.", - ["no-cmx-file"]; - 59, "Assignment to non-mutable value.", - ["flambda-assignment-to-non-mutable-value"]; - 60, "Unused module declaration.", - ["unused-module"]; - 61, "Unboxable type in primitive declaration.", - ["unboxable-type-in-prim-decl"]; - 62, "Type constraint on GADT type declaration.", - ["constraint-on-gadt"]; - 63, "Erroneous printed signature.", - ["erroneous-printed-signature"]; - 64, "-unsafe used with a preprocessor returning a syntax tree.", - ["unsafe-array-syntax-without-parsing"]; - 65, "Type declaration defining a new '()' constructor.", - ["redefining-unit"]; - 66, "Unused open! statement.", - ["unused-open-bang"]; - 67, "Unused functor parameter.", - ["unused-functor-parameter"]; - 68, "Pattern-matching depending on mutable state prevents the remaining \ - arguments from being uncurried.", - ["match-on-mutable-state-prevent-uncurry"]; - 69, "Unused record field.", - ["unused-field"]; - 70, "Missing interface file.", - ["missing-mli"] - ] -;; + \ character."; + since = None }; + { number = 27; + names = ["unused-var-strict"]; + description = + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 28; + names = ["wildcard-arg-to-constant-constr"]; + description = + "Wildcard pattern given as argument to a constant constructor."; + since = None }; + { number = 29; + names = ["eol-in-string"]; + description = + "Unescaped end-of-line in a string constant (non-portable code)."; + since = None }; + { number = 30; + names = ["duplicate-definitions"]; + description = + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types."; + since = None }; + { number = 31; + names = ["module-linked-twice"]; + description = + "A module is linked twice in the same executable.\n\ + \ Ignored: now a hard error (since 5.1)."; + since = None }; + { number = 32; + names = ["unused-value-declaration"]; + description = "Unused value declaration."; + since = since 4 0 }; + { number = 33; + names = ["unused-open"]; + description = "Unused open statement."; + since = since 4 0 }; + { number = 34; + names = ["unused-type-declaration"]; + description = "Unused type declaration."; + since = since 4 0 }; + { number = 35; + names = ["unused-for-index"]; + description = "Unused for-loop index."; + since = since 4 0 }; + { number = 36; + names = ["unused-ancestor"]; + description = "Unused ancestor variable."; + since = since 4 0 }; + { number = 37; + names = ["unused-constructor"]; + description = "Unused constructor."; + since = since 4 0 }; + { number = 38; + names = ["unused-extension"]; + description = "Unused extension constructor."; + since = since 4 0 }; + { number = 39; + names = ["unused-rec-flag"]; + description = "Unused rec flag."; + since = since 4 0 }; + { number = 40; + names = ["name-out-of-scope"]; + description = "Constructor or label name used out of scope."; + since = since 4 1 }; + { number = 41; + names = ["ambiguous-name"]; + description = "Ambiguous constructor or label name."; + since = since 4 1 }; + { number = 42; + names = ["disambiguated-name"]; + description = + "Disambiguated constructor or label name (compatibility warning)."; + since = since 4 1 }; + { number = 43; + names = ["nonoptional-label"]; + description = "Nonoptional label applied as optional."; + since = since 4 1 }; + { number = 44; + names = ["open-shadow-identifier"]; + description = "Open statement shadows an already defined identifier."; + since = since 4 1 }; + { number = 45; + names = ["open-shadow-label-constructor"]; + description = + "Open statement shadows an already defined label or constructor."; + since = since 4 1 }; + { number = 46; + names = ["bad-env-variable"]; + description = "Error in environment variable."; + since = since 4 1 }; + { number = 47; + names = ["attribute-payload"]; + description = "Illegal attribute payload."; + since = since 4 2 }; + { number = 48; + names = ["eliminated-optional-arguments"]; + description = "Implicit elimination of optional arguments."; + since = since 4 2 }; + { number = 49; + names = ["no-cmi-file"]; + description = "Absent cmi file when looking up module alias."; + since = since 4 2 }; + { number = 50; + names = ["unexpected-docstring"]; + description = "Unexpected documentation comment."; + since = since 4 3 }; + { number = 51; + names = ["wrong-tailcall-expectation"]; + description = + "Function call annotated with an incorrect @tailcall attribute."; + since = since 4 3 }; + { number = 52; + names = ["fragile-literal-pattern"]; + description = "Fragile constant pattern."; + since = since 4 3 }; + { number = 53; + names = ["misplaced-attribute"]; + description = "Attribute cannot appear in this context."; + since = since 4 3 }; + { number = 54; + names = ["duplicated-attribute"]; + description = "Attribute used more than once on an expression."; + since = since 4 3 }; + { number = 55; + names = ["inlining-impossible"]; + description = "Inlining impossible."; + since = since 4 3 }; + { number = 56; + names = ["unreachable-case"]; + description = + "Unreachable case in a pattern-matching (based on type information)."; + since = since 4 3 }; + { number = 57; + names = ["ambiguous-var-in-pattern-guard"]; + description = "Ambiguous or-pattern variables under guard."; + since = since 4 3 }; + { number = 58; + names = ["no-cmx-file"]; + description = "Missing cmx file."; + since = since 4 3 }; + { number = 59; + names = ["flambda-assignment-to-non-mutable-value"]; + description = "Assignment to non-mutable value."; + since = since 4 3 }; + { number = 60; + names = ["unused-module"]; + description = "Unused module declaration."; + since = since 4 4 }; + { number = 61; + names = ["unboxable-type-in-prim-decl"]; + description = "Unboxable type in primitive declaration."; + since = since 4 4 }; + { number = 62; + names = ["constraint-on-gadt"]; + description = "Type constraint on GADT type declaration."; + since = since 4 6 }; + { number = 63; + names = ["erroneous-printed-signature"]; + description = "Erroneous printed signature."; + since = since 4 8 }; + { number = 64; + names = ["unsafe-array-syntax-without-parsing"]; + description = + "-unsafe used with a preprocessor returning a syntax tree."; + since = since 4 8 }; + { number = 65; + names = ["redefining-unit"]; + description = "Type declaration defining a new '()' constructor."; + since = since 4 8 }; + { number = 66; + names = ["unused-open-bang"]; + description = "Unused open! statement."; + since = since 4 8 }; + { number = 67; + names = ["unused-functor-parameter"]; + description = "Unused functor parameter."; + since = since 4 10 }; + { number = 68; + names = ["match-on-mutable-state-prevent-uncurry"]; + description = + "Pattern-matching depending on mutable state prevents the remaining \n\ + \ arguments from being uncurried."; + since = since 4 12 }; + { number = 69; + names = ["unused-field"]; + description = "Unused record field."; + since = since 4 13 }; + { number = 70; + names = ["missing-mli"]; + description = "Missing interface file."; + since = since 4 13 }; + { number = 71; + names = ["unused-tmc-attribute"]; + description = "Unused @tail_mod_cons attribute."; + since = since 4 14 }; + { number = 72; + names = ["tmc-breaks-tailcall"]; + description = "A tail call is turned into a non-tail call \ + by the @tail_mod_cons transformation."; + since = since 4 14 }; + { number = 73; + names = ["generative-application-expects-unit"]; + description = "A generative functor is applied to an empty structure \ + (struct end) rather than to ()."; + since = since 5 1 }; + { number = 74; + names = ["degraded-to-partial-match"]; + description = "A pattern-matching is compiled as partial \ + even if it appears to be total."; + since = since 5 3 }; + { number = 75; + names = ["unnecessarily-partial-tuple-pattern"]; + description = "A tuple pattern ends in .. but fully matches its expected \ + type."; + since = since 5 4 }; +] let name_to_number = let h = Hashtbl.create last_warning_number in - List.iter (fun (num, _, names) -> - List.iter (fun name -> Hashtbl.add h name num) names + List.iter (fun {number; names; _} -> + List.iter (fun name -> Hashtbl.add h name number) names ) descriptions; fun s -> Hashtbl.find_opt h s -;; (* Must be the max number returned by the [number] function. *) @@ -393,7 +593,6 @@ let letter = function | 'y' -> [26] | 'z' -> [27] | _ -> assert false -;; type state = { @@ -408,7 +607,7 @@ let current = { active = Array.make (last_warning_number + 1) true; error = Array.make (last_warning_number + 1) false; - alerts = (Misc.Stdlib.String.Set.empty, false); (* all enabled *) + alerts = (Misc.Stdlib.String.Set.empty, false); alert_errors = (Misc.Stdlib.String.Set.empty, true); (* all soft *) } @@ -437,20 +636,20 @@ let alert_is_error {kind; _} = let (set, pos) = (!current).alert_errors in Misc.Stdlib.String.Set.mem kind set = pos +let with_state state f = + let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn + let mk_lazy f = let state = backup () in - lazy - ( - let prev = backup () in - restore state; - try - let r = f () in - restore prev; - r - with exn -> - restore prev; - raise exn - ) + lazy (with_state state f) let set_alert ~error ~enable s = let upd = @@ -673,7 +872,6 @@ let parse_opt error active errflag s = | '@', Some n -> action Set_all n; None | _ -> parse_and_eval s end -;; let parse_options errflag s = let error = Array.copy (!current).error in @@ -683,274 +881,402 @@ let parse_options errflag s = alerts (* If you change these, don't forget to change them in man/ocamlc.m *) -let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70";; -let defaults_warn_error = "-a+31";; +let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70-74" +let defaults_warn_error = "-a" +let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] -let () = ignore @@ parse_options false defaults_w;; -let () = ignore @@ parse_options true defaults_warn_error;; +let () = ignore @@ parse_options false defaults_w +let () = ignore @@ parse_options true defaults_warn_error +let () = + List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts -let ref_manual_explanation () = - (* manual references are checked a posteriori by the manual - cross-reference consistency check in manual/tests*) - let[@manual.ref "s:comp-warnings"] chapter, section = 9, 5 in - Printf.sprintf "(See manual section %d.%d)" chapter section +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 s -> - "the following labels are not bound in this record pattern:\n" ^ s ^ - "\nEither bind these labels explicitly or add '; _' to the pattern." + msg "the following labels are not bound@ in@ this@ \ + record@ pattern:@;<1 2>%a.@ \ + @[Either bind these labels explicitly or add %a to the pattern.@]" + Style.inline_code s + 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.\n" ^ - "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + 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) ^ - "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + 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." + | Illegal_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 s -> s^" is not principal." - | 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 -> - "all the fields are explicitly listed in this record:\n\ - the 'with' clause is useless." + msg "all the fields are explicitly listed in this record:@ \ + the %a clause is useless." + 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." - | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "." + msg "this pattern-matching is not exhaustive.@ \ + All clauses in this pattern-matching are guarded." + | Unused_var v | Unused_var_strict v -> + msg "unused variable %a." + 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 (non-portable code)" + 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 - | Module_linked_twice(modname, file1, file2) -> - Printf.sprintf - "files %s and %s both define a module named %s" - file1 file2 modname - | 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, [nm], false) -> - nm ^ " was selected from type " ^ ty ^ - ".\nIt is not visible in the current scope, and will not \n\ - be selected if the type becomes unknown." + 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 (_, _, false) -> assert false | Name_out_of_scope (ty, slist, true) -> - "this record of type "^ ty ^" contains fields that are \n\ - not visible in the current scope: " - ^ String.concat " " slist ^ ".\n\ - They will not be selected if the type becomes unknown." + msg "this record 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.@]" + Style.inline_code ty + space_inline_list slist | 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 -> - Printf.sprintf - "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. %t" ref_manual_explanation + 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 | 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 msg = - let vars = List.sort String.compare vars in + let[@manual.ref "ss:warn57"] ref_manual = [ 13; 5; 4 ] in + let vars = List.sort String.compare vars in + let vars_explanation = match vars with | [] -> assert false - | [x] -> "variable " ^ x + | [x] -> + Fmt.dprintf + "variable %a appears in@ different@ places@ in@ \ + different@ or-pattern@ alternatives." + Style.inline_code x | _::_ -> - "variables " ^ String.concat "," vars in - Printf.sprintf - "Ambiguous or-pattern variables under guard;\n\ - %s may match different arguments. %t" - msg ref_manual_explanation + Fmt.dprintf + "variables %a appears in@ different@ places@ in@ \ + different@ or-pattern@ alternatives." + comma_inline_list vars + in + 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 name -> - Printf.sprintf - "no cmx file was found in path for module %s, \ - and its interface was not compiled with -opaque" name + msg + "no cmx file was found@ in@ path@ for@ module@ %a,@ \ + and@ its@ interface@ was@ not@ compiled@ with %a" + Style.inline_code 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." - | Unused_field (s, Unused) -> "unused record field " ^ s ^ "." + msg + "This pattern depends on@ mutable@ state.@ It prevents@ the@ \ + remaining@ arguments@ from@ being@ uncurried,@ which will@ cause@ \ + additional@ closure@ allocations." + | Unused_field (s, Unused) -> + msg "unused record field %a." Style.inline_code s | Unused_field (s, Not_read) -> - "record field " ^ s ^ - " is never read.\n\ - (However, this field is used to build or mutate values.)" + msg "record field %a is never read.@ \ + (However, this field is used to build or mutate values.)" + Style.inline_code s | Unused_field (s, Not_mutated) -> - "mutable record field " ^ s ^ - " is never mutated." + msg "mutable record field %a is never mutated." + Style.inline_code s | Missing_mli -> - "Cannot find interface file." + msg "Cannot find interface file." + | Unused_tmc_attribute -> + msg "This function is marked %a@ \ + but is never applied in TMC position." + Style.inline_code "@tail_mod_cons" + | Tmc_breaks_tailcall -> + 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 -> + 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 + | 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 ".." ;; -let nerrors = ref 0;; +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 = let n = number w in - match List.find_opt (fun (m, _, _) -> m = n) descriptions with - | Some (_, _, s :: _) -> + match List.find_opt (fun {number; _} -> number = n) descriptions with + | Some {names = s :: _; _} -> Printf.sprintf "%d [%s]" n s | _ -> string_of_int n @@ -973,7 +1299,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 @@ -983,8 +1309,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 [] @@ -997,7 +1323,7 @@ let report_alert (alert : alert) = sub_locs; } -exception Errors;; +exception Errors let reset_fatal () = nerrors := 0 @@ -1006,18 +1332,24 @@ let check_fatal () = if !nerrors > 0 then begin nerrors := 0; raise Errors; - end; -;; + end + +let pp_since out release_info = + Printf.fprintf out " (since %d.%0*d)" + release_info.Sys.major + (if release_info.Sys.major >= 5 then 0 else 2) + release_info.Sys.minor let help_warnings () = List.iter - (fun (i, s, names) -> + (fun {number; description; names; since} -> let name = match names with | s :: _ -> " [" ^ s ^ "]" | [] -> "" in - Printf.printf "%3i%s %s\n" i name s) + Printf.printf "%3i%s %s%a\n" + number name description (fun out -> Option.iter (pp_since out)) since) descriptions; print_endline " A all warnings"; for i = Char.code 'b' to Char.code 'z' do @@ -1032,4 +1364,3 @@ let help_warnings () = (String.concat ", " (List.map Int.to_string l)) done; exit 0 -;; diff --git a/vendor/ocaml-common/warnings.mli b/vendor/ocaml-common/warnings.mli index 22f65571a8..5a19781703 100644 --- a/vendor/ocaml-common/warnings.mli +++ b/vendor/ocaml-common/warnings.mli @@ -39,6 +39,10 @@ type constructor_usage_warning = | Not_constructed | Only_exported_private +type type_declaration_usage_warning = + | Declaration + | Alias + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -47,7 +51,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 string (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) @@ -57,7 +61,7 @@ type t = | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) | Undeclared_virtual_method of string (* 17 *) - | Not_principal of string (* 18 *) + | Not_principal of Format_doc.t (* 18 *) | Non_principal_labels of string (* 19 *) | Ignored_extra_argument (* 20 *) | Nonreturning_statement (* 21 *) @@ -68,12 +72,15 @@ type t = | Unused_var of string (* 26 *) | Unused_var_strict of string (* 27 *) | Wildcard_arg_to_constant_constr (* 28 *) - | Eol_in_string (* 29 *) + | Eol_in_string (* 29 + Note: since OCaml 5.2, the lexer normalizes \r\n sequences in + the source file to a single \n character, so the behavior of + newlines in string literals is portable. This warning is + never emitted anymore. *) | Duplicate_definitions of string * string * string * string (* 30 *) - | Module_linked_twice of string * string * string (* 31 *) | 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 *) @@ -110,11 +117,15 @@ type t = | Match_on_mutable_state_prevent_uncurry (* 68 *) | Unused_field of string * field_usage_warning (* 69 *) | Missing_mli (* 70 *) -;; + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + | Degraded_to_partial_match (* 74 *) + | Unnecessarily_partial_tuple_pattern (* 75 *) type alert = {kind:string; message:string; def:loc; use:loc} -val parse_options : bool -> string -> alert option;; +val parse_options : bool -> string -> alert option val parse_alert_option: string -> unit (** Disable/enable alerts based on the parameter to the -alert @@ -125,25 +136,25 @@ val parse_alert_option: string -> unit val without_warnings : (unit -> 'a) -> 'a (** Run the thunk with all warnings and alerts disabled. *) -val is_active : t -> bool;; -val is_error : t -> bool;; +val is_active : t -> bool +val is_error : t -> bool -val defaults_w : string;; -val defaults_warn_error : string;; +val defaults_w : string +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 ] val report_alert : alert -> [ `Active of reporting_information | `Inactive ] -exception Errors;; +exception Errors -val check_fatal : unit -> unit;; +val check_fatal : unit -> unit val reset_fatal: unit -> unit val help_warnings: unit -> unit @@ -151,6 +162,15 @@ val help_warnings: unit -> unit type state val backup: unit -> state val restore: state -> unit +val with_state : state -> (unit -> 'a) -> 'a val mk_lazy: (unit -> 'a) -> 'a Lazy.t (** Like [Lazy.of_fun], but the function is applied with the warning/alert settings at the time [mk_lazy] is called. *) + +type description = + { number : int; + names : string list; + description : string; + since : Sys.ocaml_release_info option; } + +val descriptions : description list diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 05ef4ff631..e79f5cbf8f 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -158,14 +158,15 @@ module Typ = struct { field with pof_desc; } and loop_package_type ptyp = { ptyp with - ppt_cstrs = List.map (fun (n,typ) -> (n,loop typ) ) ptyp.ppt_cstrs } + ppt_constraints = + List.map (fun (n,typ) -> (n,loop typ) ) ptyp.ppt_constraints } in loop t *) let package_type ?(loc = !default_loc) ?(attrs = []) p c = {ppt_loc = loc; ppt_path = p; - ppt_cstrs = c; + ppt_constraints = c; ppt_attrs = attrs} end @@ -582,7 +583,7 @@ module Type = struct let mk ?(loc = !default_loc) ?(attrs = Attr.empty_ext_attrs) ?(docs = empty_docs) ?(text = []) ?(params = []) - ?(cstrs = []) + ?(constraints = []) ?(kind = Ptype_abstract) ?(priv = Public) ?manifest @@ -590,7 +591,7 @@ module Type = struct { ptype_name = name; ptype_params = params; - ptype_cstrs = cstrs; + ptype_constraints = constraints; ptype_kind = kind; ptype_private = priv; ptype_manifest = manifest; diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index ab670aae8d..6ade6d48cb 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -125,11 +125,11 @@ and map_loc_lid sub loc_lid = let map_variant_var sub v = map_loc map_string sub v -let map_package_type sub {ppt_loc; ppt_path; ppt_cstrs; ppt_attrs} = +let map_package_type sub {ppt_loc; ppt_path; ppt_constraints; 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) + (List.map (map_tuple (map_loc_lid sub) (sub.typ sub)) ppt_constraints) let map_arg_label sub = function | Asttypes.Nolabel -> Asttypes.Nolabel @@ -306,7 +306,7 @@ module T = struct (sub.package_type sub ptyp) (sub.typ sub t) let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; + {ptype_name; ptype_params; ptype_constraints; ptype_kind; ptype_private; ptype_manifest; @@ -317,9 +317,10 @@ module T = struct Type.mk ~loc ~attrs (map_loc map_string sub ptype_name) ~params:(List.map (map_fst (sub.typ sub)) ptype_params) ~priv:(Flag.map_private sub ptype_private) - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) + ~constraints: + (List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_constraints) ~kind:(sub.type_kind sub ptype_kind) ?manifest:(map_opt (sub.typ sub) ptype_manifest) @@ -378,11 +379,11 @@ module T = struct (map_loc map_string sub pext_name) (map_extension_constructor_kind sub pext_kind) - let map_package_type sub {ppt_loc; ppt_path; ppt_cstrs; ppt_attrs} = + let map_package_type sub {ppt_loc; ppt_path; ppt_constraints; 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) + (List.map (map_tuple (map_loc_lid sub) (sub.typ sub)) ppt_constraints) end diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 9da9baa9c4..458d96830c 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -101,6 +101,10 @@ let pstr_class l = let pstr_class_type l = Pstr_class_type l +let psig_extension body attrs = + (Psig_extension (body, attrs)) +let psig_attribute body = + (Psig_attribute body) let psig_typext te = Psig_typext te let psig_value vd = @@ -114,6 +118,22 @@ let psig_exception te = Psig_exception te let psig_include body = Psig_include body +let psig_module body = + (Psig_module body) +let psig_modsubst body = + (Psig_modsubst body) +let psig_recmodule l = + (Psig_recmodule l) +let psig_modtype body = + (Psig_modtype body) +let psig_modtypesubst body = + (Psig_modtypesubst body) +let psig_open body = + (Psig_open body) +let psig_class l = + (Psig_class l) +let psig_class_type l = + (Psig_class_type l) let mkctf ~loc ?attrs ?docs d = Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d @@ -312,11 +332,134 @@ let mk_dotop_indexop_expr ~loc (pia_lhs, (path, op), pia_paren, idx, pia_rhs) = (Pexp_indexop_access { pia_lhs; pia_kind= Dotop (path, op, idx); pia_paren; pia_rhs }) +(* +(* Helper functions for desugaring array indexing operators *) +type paren_kind = Paren | Brace | Bracket + +(* We classify the dimension of indices: Bigarray distinguishes + indices of dimension 1,2,3, or more. Similarly, user-defined + indexing operator behave differently for indices of dimension 1 + or more. +*) +type index_dim = + | One + | Two + | Three + | Many +type ('dot,'index) array_family = { + + name: + Lexing.position * Lexing.position -> 'dot -> assign:bool -> paren_kind + -> index_dim -> Longident.t Location.loc + (* + This functions computes the name of the explicit indexing operator + associated with a sugared array indexing expression. + + For instance, for builtin arrays, if Clflags.unsafe is set, + * [ a.[index] ] => [String.unsafe_get] + * [ a.{x,y} <- 1 ] => [ Bigarray.Array2.unsafe_set] + + User-defined indexing operator follows a more local convention: + * [ a .%(index)] => [ (.%()) ] + * [ a.![1;2] <- 0 ] => [(.![;..]<-)] + * [ a.My.Map.?(0) => [My.Map.(.?())] + *); + + index: + Lexing.position * Lexing.position -> paren_kind -> 'index + -> index_dim * (arg_label * expression) list + (* + [index (start,stop) paren index] computes the dimension of the + index argument and how it should be desugared when transformed + to a list of arguments for the indexing operator. + In particular, in both the Bigarray case and the user-defined case, + beyond a certain dimension, multiple indices are packed into a single + array argument: + * [ a.(x) ] => [ [One, [Nolabel, <>] ] + * [ a.{1,2} ] => [ [Two, [Nolabel, <<1>>; Nolabel, <<2>>] ] + * [ a.{1,2,3,4} ] => [ [Many, [Nolabel, <<[|1;2;3;4|]>>] ] ] + *); + +} + +let bigarray_untuplify exp = + match exp.pexp_desc with + | Pexp_tuple explist + when List.for_all (fun (l, _) -> Option.is_none l) explist -> + List.map snd explist + | _ -> [exp] + +let builtin_arraylike_name loc _ ~assign paren_kind n = + let opname = if assign then "set" else "get" in + let opname = if !Clflags.unsafe then "unsafe_" ^ opname else opname in + let prefix = match paren_kind with + | Paren -> Lident "Array" + | Bracket -> + (* Syntax removed in 5.1. if assign then removed_string_set loc + else *) + Lident "String" + | Brace -> + let submodule_name = match n with + | One -> "Array1" + | Two -> "Array2" + | Three -> "Array3" + | Many -> "Genarray" in + Ldot(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] + | Brace -> + (* Multi-indices for bigarray are comma-separated ([a.{1,2,3,4}]) *) + match bigarray_untuplify index with + | [x] -> One, [Nolabel, x] + | [x;y] -> Two, [Nolabel, x; Nolabel, y] + | [x;y;z] -> Three, [Nolabel, x; Nolabel, y; Nolabel, z] + | coords -> Many, [Nolabel, ghexp ~loc (Pexp_array coords)] + +let builtin_indexing_operators : (unit, expression) array_family = + { index = builtin_arraylike_index; name = builtin_arraylike_name } +*) let paren_to_strings = function | Paren -> "(", ")" | Bracket -> "[", "]" | Brace -> "{", "}" - +(* +let user_indexing_operator_name loc (prefix,ext) ~assign paren_kind n = + let name = + let assign = if assign then "<-" else "" in + let mid = match n with + | Many | Three | Two -> ";.." + | One -> "" in + let left, right = paren_to_strings paren_kind in + String.concat "" ["."; ext; left; mid; right; assign] in + let lid = match prefix with + | None -> Lident name + | Some p -> Ldot(mknoloc p,mknoloc name) in + ghloc ~loc lid + +let user_index loc _ index = + (* Multi-indices for user-defined operators are semicolon-separated + ([a.%[1;2;3;4]]) *) + match index with + | [a] -> One, [Nolabel, a] + | l -> Many, [Nolabel, mkexp ~loc (Pexp_array l)] + +let user_indexing_operators: + (Longident.t option * string, expression list) array_family + = { index = user_index; name = user_indexing_operator_name } + +let mk_indexop_expr array_indexing_operator ~loc + (array,dot,paren,index,set_expr) = + let assign = match set_expr with None -> false | Some _ -> true in + let n, index = array_indexing_operator.index loc paren index in + let fn = array_indexing_operator.name loc dot ~assign paren n in + let set_arg = match set_expr with + | None -> [] + | Some expr -> [Nolabel, expr] in + let args = (Nolabel,array) :: index @ set_arg in + mkexp ~loc (Pexp_apply(ghexp ~loc (Pexp_ident fn), args)) +*) let indexop_unclosed_error loc_s s loc_e = let left, right = paren_to_strings s in unclosed left loc_s right loc_e @@ -327,20 +470,17 @@ let lapply ~loc p1 loc_p1 p2 loc_p2 = else raise (Syntaxerr.Error( Syntaxerr.Applicative_path (make_loc loc))) -(* [loc_map] could be [Location.map]. *) -let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc = - { x with txt = f x.txt } let make_ghost x = { x with loc = { x.loc with loc_ghost = true }} let loc_last (id : Longident.t Location.loc) : string Location.loc = - loc_map Longident.last id + Location.map Longident.last id let loc_lident (id : string Location.loc) : Longident.t Location.loc = - loc_map (fun x -> Lident x) id + Location.map (fun x -> Lident x) id (* let exp_of_longident lid = - let lid = loc_map (fun id -> Lident (Longident.last id)) lid in + let lid = Location.map (fun id -> Lident (Longident.last id)) lid in Exp.mk ~loc:lid.loc (Pexp_ident lid) *) let exp_of_label lbl = @@ -395,6 +535,7 @@ let wrap_mksig_ext ~loc (item, ext) = | Some id -> mksig ~loc (Psig_extension ((id, PSig [ghsig ~loc item]), [])) *) let wrap_mkstr_ext = mkstr +let wrap_mksig_ext = mksig let mk_quotedext ~loc (id, idloc, str, strloc, delim) = let exp_id = mkloc id idloc in @@ -489,9 +630,9 @@ let expr_of_let_bindings ~loc ~loc_in lbs body = mkexp ~loc (Pexp_let (mk_let_bindings lbs, body, loc_in)) let class_of_let_bindings ~loc ~loc_in lbs body = - (* Our use of let_bindings(no_ext) guarantees the following: *) - assert (not lbs.lbs_has_ext); - mkclass ~loc (Pcl_let (mk_let_bindings lbs, body, loc_in)) + (* Our use of let_bindings(no_ext) guarantees the following: *) + assert (not lbs.lbs_has_ext); + mkclass ~loc (Pcl_let (mk_let_bindings lbs, body, loc_in)) (* This rewrite is not wanted in OCamlformat (* If all the parameters are [Pparam_newtype x], then return [Some xs] where @@ -567,7 +708,7 @@ let package_type_of_module_type pmty = let loc = ptyp.ptype_loc in if ptyp.ptype_params <> [] then err loc Syntaxerr.Parameterized_types; - if ptyp.ptype_cstrs <> [] then + if ptyp.ptype_constraints <> [] then err loc Syntaxerr.Constrained_types; if ptyp.ptype_private <> Public then err loc Syntaxerr.Private_types; @@ -911,10 +1052,6 @@ The precedences must be listed from low to high. { mkpat ~loc:$sloc $1 } %inline mktyp(symb): symb { mktyp ~loc:$sloc $1 } -%inline mkstr(symb): symb - { mkstr ~loc:$sloc $1 } -%inline mksig(symb): symb - { mksig ~loc:$sloc $1 } %inline mkmod(symb): symb { mkmod ~loc:$sloc $1 } %inline mkmty(symb): symb @@ -932,10 +1069,9 @@ The precedences must be listed from low to high. %inline wrap_mkstr_ext(symb): symb { wrap_mkstr_ext ~loc:$sloc $1 } -(* %inline wrap_mksig_ext(symb): symb { wrap_mksig_ext ~loc:$sloc $1 } -*) + %inline mk_directive_arg(symb): symb { mk_directive_arg ~loc:$sloc $1 } @@ -1629,6 +1765,11 @@ open_description: %inline open_dot_declaration: mkrhs(mod_longident) { $1 } +(* We have a dedicated AST node for "open dot". + { let loc = make_loc $loc($1) in + let me = Mod.ident ~loc $1 in + Opn.mk ~loc me } +*) ; (* -------------------------------------------------------------------------- *) @@ -1665,7 +1806,6 @@ module_type: ) { $1 } ; - (* A signature, which appears between SIG and END (among other places), is a list of signature elements. *) signature: @@ -1684,26 +1824,13 @@ signature: (* A signature item. *) signature_item: - | item_extension post_item_attributes - { let docs = symbol_docs $sloc in - mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) } - | mksig( - floating_attribute - { Psig_attribute $1 } - | module_declaration - { Psig_module $1 } - | module_alias - { Psig_module $1 } - | module_subst - { Psig_modsubst $1 } - | rec_module_declarations - { Psig_recmodule $1 } - | module_type_declaration - { Psig_modtype $1 } - | module_type_subst - { Psig_modtypesubst $1 } + | wrap_mksig_ext( + item_extension post_item_attributes + { psig_extension $1 (add_docs_attrs (symbol_docs $sloc) $2) } + | floating_attribute + { psig_attribute $1 } | value_description - { Psig_value $1 } + { psig_value $1 } | primitive_declaration { psig_value $1 } | type_declarations @@ -1714,14 +1841,26 @@ signature_item: { psig_typext $1 } | sig_exception_declaration { psig_exception $1 } + | module_declaration + { psig_module $1 } + | module_alias + { psig_module $1 } + | module_subst + { psig_modsubst $1 } + | rec_module_declarations + { psig_recmodule $1 } + | module_type_declaration + { psig_modtype $1 } + | module_type_subst + { psig_modtypesubst $1 } | open_description - { Psig_open $1 } + { psig_open $1 } | include_statement(module_type) { psig_include $1 } | class_descriptions - { Psig_class $1 } + { psig_class $1 } | class_type_declarations - { Psig_class_type $1 } + { psig_class_type $1 } ) { $1 } @@ -2222,7 +2361,6 @@ class_type_declarations: Pfunction_cases attributes for enabling/disabling warnings in typechecking. For standalone function cases, we want the compiler to respect, e.g., [@inline] attributes. - For printing, this is reverted. *) let desc = mkfunction [] None (Pfunction_cases (cases, loc, Attr.empty_infix_ext_attrs)) $2 in mkexp ~loc:$sloc desc @@ -2343,11 +2481,11 @@ fun_expr: { $1 } | let_bindings(ext) IN seq_expr { expr_of_let_bindings ~loc:$sloc ~loc_in:(make_loc $loc($2)) $1 $3 } - | pbop_op = mkrhs(LETOP) bindings = letop_bindings _in_kw=IN body = seq_expr + | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr { let (pbop_pat, pbop_args, pbop_typ, pbop_exp, pbop_is_pun, rev_ands) = bindings in let ands = List.rev rev_ands in let pbop_loc = make_loc $sloc in - let loc_in = make_loc $loc(_in_kw) in + let loc_in = make_loc $loc($3) in let let_ = {pbop_op; pbop_pat; pbop_args; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} in @@ -2425,7 +2563,7 @@ fun_expr: { Pexp_tuple($1) } | mkrhs(constr_longident) simple_expr %prec below_HASH { Pexp_construct($1, Some $2) } - | name_tag simple_expr %prec below_HASH + | mkrhs(name_tag) simple_expr %prec below_HASH { Pexp_variant($1, Some $2) } | e1 = fun_expr op = op(infix_operator) e2 = expr { mkinfix e1 op e2 } @@ -2503,7 +2641,7 @@ simple_expr: { Pexp_constant $1 } | mkrhs(constr_longident) %prec prec_constant_constructor { Pexp_construct($1, None) } - | name_tag %prec prec_constant_constructor + | mkrhs(name_tag) %prec prec_constant_constructor { Pexp_variant($1, None) } | op(PREFIXOP) simple_expr { Pexp_prefix($1, $2) } @@ -2971,7 +3109,7 @@ pattern_gen: | constr=mkrhs(constr_longident) LPAREN TYPE newtypes=lident_list RPAREN pat=simple_pattern { Ppat_construct(constr, Some (newtypes, pat)) } - | name_tag pattern %prec prec_constr_appl + | mkrhs(name_tag) pattern %prec prec_constr_appl { Ppat_variant($1, Some $2) } ) { $1 } | LAZY ext_attributes simple_pattern @@ -3007,7 +3145,7 @@ simple_pattern_not_ident: { Ppat_interval ($1, $3) } | mkrhs(constr_longident) { Ppat_construct($1, None) } - | name_tag + | mkrhs(name_tag) { Ppat_variant($1, None) } | HASH mkrhs(type_longident) { Ppat_type ($2) } @@ -3219,7 +3357,7 @@ generic_type_declaration(flag, kind): params = type_parameters id = mkrhs(LIDENT) kind_priv_manifest = kind - cstrs = constraints + constraints = constraints attrs2 = post_item_attributes { let (kind, priv, manifest) = kind_priv_manifest in @@ -3227,7 +3365,7 @@ generic_type_declaration(flag, kind): let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in flag, - Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs + Type.mk id ~params ~constraints ~kind ~priv ?manifest ~attrs ~loc ~docs } ; %inline generic_and_type_declaration(kind): @@ -3236,7 +3374,7 @@ generic_type_declaration(flag, kind): params = type_parameters id = mkrhs(LIDENT) kind_priv_manifest = kind - cstrs = constraints + constraints = constraints attrs2 = post_item_attributes { let (kind, priv, manifest) = kind_priv_manifest in @@ -3244,7 +3382,7 @@ generic_type_declaration(flag, kind): let attrs = Attr.ext_attrs ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let text = symbol_text $symbolstartpos in - Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text + Type.mk id ~params ~constraints ~kind ~priv ?manifest ~attrs ~loc ~docs ~text } ; %inline constraints: @@ -3490,7 +3628,7 @@ with_constraint: ($3, (Type.mk lident ~params:$2 - ~cstrs:$6 + ~constraints:$6 ~manifest:$5 ~priv:$4 ~loc:(make_loc $sloc))) } @@ -3522,8 +3660,8 @@ with_type_binder: /* Polymorphic types */ %inline typevar: - QUOTE mkrhs(ident) - { $2 } + QUOTE ident + { mkrhs $2 $sloc } ; %inline typevar_list: nonempty_llist(typevar) @@ -3617,7 +3755,7 @@ function_type: } ) { $1 } - (* The next two cases are for labled tuples - see comment on [tuple_type] + (* The next two cases are for labeled tuples - see comment on [tuple_type] below. The first case is present just to resolve a shift/reduce conflict in a @@ -3671,14 +3809,14 @@ function_type: { $1 } ; %inline arg_label: - | label = optlabel - { Optional (mkrhs label $sloc) } + | label = mkrhs(optlabel) + { Optional label } | arg_label_no_opt { $1 } %inline arg_label_no_opt: - | label = LIDENT COLON - { Labelled (mkrhs label $sloc) } + | label = mkrhs(LIDENT) COLON + { Labelled label } | /* empty */ { Nolabel } ; @@ -3698,7 +3836,7 @@ function_type: label is not parsed as a proper_tuple_type, but rather as a case of function_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. + the presence of labeled tuples. *) tuple_type: | ty = atomic_type @@ -3864,11 +4002,11 @@ row_field: { Rf.inherit_ ~loc:(make_loc $sloc) $1 } ; tag_field: - name_tag OF opt_ampersand amper_type_list attributes + mkrhs(name_tag) OF opt_ampersand amper_type_list attributes { let info = symbol_info $endpos in let attrs = add_info_attrs info $5 in Rf.tag ~loc:(make_loc $sloc) ~attrs $1 $3 $4 } - | name_tag attributes + | mkrhs(name_tag) attributes { let info = symbol_info $endpos in let attrs = add_info_attrs info $2 in Rf.tag ~loc:(make_loc $sloc) ~attrs $1 true [] } @@ -3882,7 +4020,7 @@ opt_ampersand: { $1 } ; %inline name_tag_list: - nonempty_llist(name_tag) + nonempty_llist(mkrhs(name_tag)) { $1 } ; (* A method list (in an object type). *) @@ -4109,8 +4247,7 @@ toplevel_directive: ; name_tag: - BACKQUOTE mkrhs(ident) - { mkloc $2 (make_loc $sloc) } + BACKQUOTE mkrhs(ident) { $2 } ; rec_flag: /* empty */ { Nonrecursive } diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 311eacd018..22e716a73f 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -206,13 +206,13 @@ and core_type_desc = and package_type = { ppt_path: Longident.t loc; - ppt_cstrs: (Longident.t loc * core_type) list; + ppt_constraints: (Longident.t loc * core_type) list; ppt_loc: Location.t; ppt_attrs: attributes; } (** As {!package_type} typed values: - - [{ppt_path: S; ppt_cstrs: []}] represents [(module S)], - - [{ppt_path: S; ppt_cstrs: [(t1, T1) ; ... ; (tn, Tn)]}] + - [{ppt_path: S; ppt_constraints: []}] represents [(module S)], + - [{ppt_path: S; ppt_constraints: [(t1, T1) ; ... ; (tn, Tn)]}] represents [(module S with type t1 = T1 and ... and tn = Tn)]. *) @@ -639,7 +639,7 @@ and type_declaration = ptype_name: string loc; ptype_params: (core_type * variance_and_injectivity) list; (** [('a1,...'an) t] *) - ptype_cstrs: (core_type * core_type * Location.t) list; + ptype_constraints: (core_type * core_type * Location.t) list; (** [... constraint T1=T1' ... constraint Tn=Tn'] *) ptype_kind: type_kind; ptype_private: private_flag; (** for [= private ...] *) diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 231ea34736..8a10a7befe 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -278,8 +278,8 @@ and object_field i ppf x = and package_type i ppf ptyp = let i = i + 1 in line i ppf "package_type %a\n" fmt_longident_loc ptyp.ppt_path; - attributes i ppf ptyp.ppt_attrs; - list i package_with ppf ptyp.ppt_cstrs; + list i package_with ppf ptyp.ppt_constraints; + attributes i ppf ptyp.ppt_attrs and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident_loc s; @@ -602,8 +602,8 @@ and type_declaration i ppf x = let i = i+1 in line i ppf "ptype_params =\n"; list (i+1) type_parameter ppf x.ptype_params; - line i ppf "ptype_cstrs =\n"; - list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + line i ppf "ptype_constraints =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.ptype_constraints; line i ppf "ptype_kind =\n"; type_kind (i+1) ppf x.ptype_kind; line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; diff --git a/vendor/parser-shims/misc_.ml b/vendor/parser-shims/misc_.ml index e8bf50687d..96b7587f73 100644 --- a/vendor/parser-shims/misc_.ml +++ b/vendor/parser-shims/misc_.ml @@ -116,6 +116,7 @@ module Style = struct pp_close_stag ppf () let inline_code ppf s = as_inline_code Format_doc.pp_print_string ppf s + let hint ppf = Format_doc.fprintf ppf "@{Hint@}" (* either prints the tag of [s] or delegates to [or_else] *) let mark_open_tag ~or_else s = @@ -391,3 +392,9 @@ module Utf8_lexeme = struct in is_lowercase_at (String.length s) s 0 end + +let print_see_manual ppf manual_section = + let open Format_doc in + fprintf ppf "(see manual section %a)" + (pp_print_list ~pp_sep:(fun f () -> pp_print_char f '.') pp_print_int) + manual_section diff --git a/vendor/parser-standard/ast_helper.ml b/vendor/parser-standard/ast_helper.ml index bdf604fc63..e70e179322 100644 --- a/vendor/parser-standard/ast_helper.ml +++ b/vendor/parser-standard/ast_helper.ml @@ -148,14 +148,15 @@ module Typ = struct { field with pof_desc; } and loop_package_type ptyp = { ptyp with - ppt_cstrs = List.map (fun (n,typ) -> (n,loop typ) ) ptyp.ppt_cstrs } + ppt_constraints = + List.map (fun (n,typ) -> (n,loop typ) ) ptyp.ppt_constraints } in loop t let package_type ?(loc = !default_loc) ?(attrs = []) p c = {ppt_loc = loc; ppt_path = p; - ppt_cstrs = c; + ppt_constraints = c; ppt_attrs = attrs} end @@ -537,7 +538,7 @@ module Type = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) ?(text = []) ?(params = []) - ?(cstrs = []) + ?(constraints = []) ?(kind = Ptype_abstract) ?(priv = Public) ?manifest @@ -545,7 +546,7 @@ module Type = struct { ptype_name = name; ptype_params = params; - ptype_cstrs = cstrs; + ptype_constraints = constraints; ptype_kind = kind; ptype_private = priv; ptype_manifest = manifest; diff --git a/vendor/parser-standard/ast_mapper.ml b/vendor/parser-standard/ast_mapper.ml index 27bb476faa..7810dccdf9 100644 --- a/vendor/parser-standard/ast_mapper.ml +++ b/vendor/parser-standard/ast_mapper.ml @@ -202,7 +202,7 @@ module T = struct (sub.package_type sub ptyp) (sub.typ sub t) let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; + {ptype_name; ptype_params; ptype_constraints; ptype_kind; ptype_private; ptype_manifest; @@ -213,9 +213,10 @@ module T = struct Type.mk ~loc ~attrs (map_loc map_string sub ptype_name) ~params:(List.map (map_fst (sub.typ sub)) ptype_params) ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) + ~constraints: + (List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_constraints) ~kind:(sub.type_kind sub ptype_kind) ?manifest:(map_opt (sub.typ sub) ptype_manifest) @@ -272,11 +273,11 @@ module T = struct (map_loc map_string sub pext_name) (map_extension_constructor_kind sub pext_kind) - let map_package_type sub {ppt_loc; ppt_path; ppt_cstrs; ppt_attrs} = + let map_package_type sub {ppt_loc; ppt_path; ppt_constraints; 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) + (List.map (map_tuple (map_loc_lid sub) (sub.typ sub)) ppt_constraints) end diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly index 9f66154c30..cdcd20f7a2 100644 --- a/vendor/parser-standard/parser.mly +++ b/vendor/parser-standard/parser.mly @@ -87,6 +87,10 @@ let pstr_class (ext, l) = let pstr_class_type (ext, l) = (Pstr_class_type l, ext) +let psig_extension body attrs = + (Psig_extension (body, attrs), None) +let psig_attribute body = + (Psig_attribute body, None) let psig_typext (te, ext) = (Psig_typext te, ext) let psig_value (vd, ext) = @@ -100,6 +104,22 @@ let psig_exception (te, ext) = (Psig_exception te, ext) let psig_include (body, ext) = (Psig_include body, ext) +let psig_module (body, ext) = + (Psig_module body, ext) +let psig_modsubst (body, ext) = + (Psig_modsubst body, ext) +let psig_recmodule (ext, l) = + (Psig_recmodule l, ext) +let psig_modtype (body, ext) = + (Psig_modtype body, ext) +let psig_modtypesubst (body, ext) = + (Psig_modtypesubst body, ext) +let psig_open (body, ext) = + (Psig_open body, ext) +let psig_class (ext, l) = + (Psig_class l, ext) +let psig_class_type (ext, l) = + (Psig_class_type l, ext) let mkctf ~loc ?attrs ?docs d = Ctf.mk ~loc:(make_loc loc) ?attrs ?docs d @@ -419,20 +439,17 @@ let lapply ~loc p1 loc_p1 p2 loc_p2 = else raise (Syntaxerr.Error( Syntaxerr.Applicative_path (make_loc loc))) -(* [loc_map] could be [Location.map]. *) -let loc_map (f : 'a -> 'b) (x : 'a Location.loc) : 'b Location.loc = - { x with txt = f x.txt } let make_ghost x = { x with loc = { x.loc with loc_ghost = true }} let loc_last (id : Longident.t Location.loc) : string Location.loc = - loc_map Longident.last id + Location.map Longident.last id let loc_lident (id : string Location.loc) : Longident.t Location.loc = - loc_map (fun x -> Lident x) id + Location.map (fun x -> Lident x) id let exp_of_longident lid = - let lid = loc_map (fun id -> Lident (Longident.last id)) lid in + let lid = Location.map (fun id -> Lident (Longident.last id)) lid in Exp.mk ~loc:lid.loc (Pexp_ident lid) let exp_of_label lbl = @@ -683,7 +700,7 @@ let package_type_of_module_type pmty = let loc = ptyp.ptype_loc in if ptyp.ptype_params <> [] then err loc Syntaxerr.Parameterized_types; - if ptyp.ptype_cstrs <> [] then + if ptyp.ptype_constraints <> [] then err loc Syntaxerr.Constrained_types; if ptyp.ptype_private <> Public then err loc Syntaxerr.Private_types; @@ -1027,10 +1044,6 @@ The precedences must be listed from low to high. { mkpat ~loc:$sloc $1 } %inline mktyp(symb): symb { mktyp ~loc:$sloc $1 } -%inline mkstr(symb): symb - { mkstr ~loc:$sloc $1 } -%inline mksig(symb): symb - { mksig ~loc:$sloc $1 } %inline mkmod(symb): symb { mkmod ~loc:$sloc $1 } %inline mkmty(symb): symb @@ -1487,15 +1500,15 @@ paren_module_expr: (* The various ways of annotating a core language expression that produces a first-class module that we wish to unpack. *) -%inline expr_colon_package_type: +expr_colon_package_type: e = expr { e } | e = expr COLON ty = package_type - { ghexp ~loc:$loc (Pexp_constraint (e, ty)) } + { mkexp ~loc:$loc (Pexp_constraint (e, ty)) } | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type - { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) } + { mkexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) } | e = expr COLONGREATER ty2 = package_type - { ghexp ~loc:$loc (Pexp_coerce (e, None, ty2)) } + { mkexp ~loc:$loc (Pexp_coerce (e, None, ty2)) } ; (* A structure, which appears between STRUCT and END (among other places), @@ -1785,16 +1798,12 @@ signature: (* A signature item. *) signature_item: - | item_extension post_item_attributes - { let docs = symbol_docs $sloc in - mksig ~loc:$sloc (Psig_extension ($1, (add_docs_attrs docs $2))) } - | mksig( - floating_attribute - { Psig_attribute $1 } - ) - { $1 } | wrap_mksig_ext( - value_description + item_extension post_item_attributes + { psig_extension $1 (add_docs_attrs (symbol_docs $sloc) $2) } + | floating_attribute + { psig_attribute $1 } + | value_description { psig_value $1 } | primitive_declaration { psig_value $1 } @@ -1807,25 +1816,25 @@ signature_item: | sig_exception_declaration { psig_exception $1 } | module_declaration - { let (body, ext) = $1 in (Psig_module body, ext) } + { psig_module $1 } | module_alias - { let (body, ext) = $1 in (Psig_module body, ext) } + { psig_module $1 } | module_subst - { let (body, ext) = $1 in (Psig_modsubst body, ext) } + { psig_modsubst $1 } | rec_module_declarations - { let (ext, l) = $1 in (Psig_recmodule l, ext) } + { psig_recmodule $1 } | module_type_declaration - { let (body, ext) = $1 in (Psig_modtype body, ext) } + { psig_modtype $1 } | module_type_subst - { let (body, ext) = $1 in (Psig_modtypesubst body, ext) } + { psig_modtypesubst $1 } | open_description - { let (body, ext) = $1 in (Psig_open body, ext) } + { psig_open $1 } | include_statement(module_type) { psig_include $1 } | class_descriptions - { let (ext, l) = $1 in (Psig_class l, ext) } + { psig_class $1 } | class_type_declarations - { let (ext, l) = $1 in (Psig_class_type l, ext) } + { psig_class_type $1 } ) { $1 } @@ -3313,7 +3322,7 @@ generic_type_declaration(flag, kind): params = type_parameters id = mkrhs(LIDENT) kind_priv_manifest = kind - cstrs = constraints + constraints = constraints attrs2 = post_item_attributes { let (kind, priv, manifest) = kind_priv_manifest in @@ -3321,7 +3330,7 @@ generic_type_declaration(flag, kind): let attrs = attrs1 @ attrs2 in let loc = make_loc $sloc in (flag, ext), - Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs + Type.mk id ~params ~constraints ~kind ~priv ?manifest ~attrs ~loc ~docs } ; %inline generic_and_type_declaration(kind): @@ -3330,7 +3339,7 @@ generic_type_declaration(flag, kind): params = type_parameters id = mkrhs(LIDENT) kind_priv_manifest = kind - cstrs = constraints + constraints = constraints attrs2 = post_item_attributes { let (kind, priv, manifest) = kind_priv_manifest in @@ -3338,7 +3347,8 @@ generic_type_declaration(flag, kind): let attrs = attrs1 @ attrs2 in let loc = make_loc $sloc in let text = symbol_text $symbolstartpos in - Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text + Type.mk + id ~params ~constraints ~kind ~priv ?manifest ~attrs ~loc ~docs ~text } ; %inline constraints: @@ -3591,7 +3601,7 @@ with_constraint: ($3, (Type.mk lident ~params:$2 - ~cstrs:$6 + ~constraints:$6 ~manifest:$5 ~priv:$4 ~loc:(make_loc $sloc))) } @@ -3706,7 +3716,7 @@ function_type: { Ptyp_arrow(label, domain, codomain) } ) { $1 } - (* The next two cases are for labled tuples - see comment on [tuple_type] + (* The next two cases are for labeled tuples - see comment on [tuple_type] below. The first case is present just to resolve a shift/reduce conflict in a @@ -3775,7 +3785,7 @@ function_type: label is not parsed as a proper_tuple_type, but rather as a case of function_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. + the presence of labeled tuples. *) tuple_type: | ty = atomic_type diff --git a/vendor/parser-standard/parsetree.mli b/vendor/parser-standard/parsetree.mli index e6b2f98c4f..4e2c8e0913 100644 --- a/vendor/parser-standard/parsetree.mli +++ b/vendor/parser-standard/parsetree.mli @@ -185,13 +185,13 @@ and core_type_desc = and package_type = { ppt_path: Longident.t loc; - ppt_cstrs: (Longident.t loc * core_type) list; + ppt_constraints: (Longident.t loc * core_type) list; ppt_loc: Location.t; ppt_attrs: attributes; } (** As {!package_type} typed values: - - [{ppt_path: S; ppt_cstrs: []}] represents [(module S)], - - [{ppt_path: S; ppt_cstrs: [(t1, T1) ; ... ; (tn, Tn)]}] + - [{ppt_path: S; ppt_constraints: []}] represents [(module S)], + - [{ppt_path: S; ppt_constraints: [(t1, T1) ; ... ; (tn, Tn)]}] represents [(module S with type t1 = T1 and ... and tn = Tn)]. *) @@ -545,7 +545,7 @@ and type_declaration = ptype_name: string loc; ptype_params: (core_type * (variance * injectivity)) list; (** [('a1,...'an) t] *) - ptype_cstrs: (core_type * core_type * Location.t) list; + ptype_constraints: (core_type * core_type * Location.t) list; (** [... constraint T1=T1' ... constraint Tn=Tn'] *) ptype_kind: type_kind; ptype_private: private_flag; (** for [= private ...] *) diff --git a/vendor/parser-standard/printast.ml b/vendor/parser-standard/printast.ml index 0943b239d6..2617c5be1a 100644 --- a/vendor/parser-standard/printast.ml +++ b/vendor/parser-standard/printast.ml @@ -202,7 +202,7 @@ let rec core_type i ppf x = 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; + list i package_with ppf ptyp.ppt_constraints; attributes i ppf ptyp.ppt_attrs and package_with i ppf (s, t) = @@ -452,8 +452,8 @@ and type_declaration i ppf x = let i = i+1 in line i ppf "ptype_params =\n"; list (i+1) type_parameter ppf x.ptype_params; - line i ppf "ptype_cstrs =\n"; - list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + line i ppf "ptype_constraints =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.ptype_constraints; line i ppf "ptype_kind =\n"; type_kind (i+1) ppf x.ptype_kind; line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private;