5.5 support: Backport parser code changes (#2782)

Backport refactors and other changes made upstream that do not change the language syntax. The goal is to reduce the diff with upstream to make future updates easier.

* Reduce diff in arg_label

The location is different but no comment moved in the tests.

Author: Julow

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)

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 ->

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 _; _} ->

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

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 "@[<v>%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 "@[<v>%a%a%a: %a%a%a%a%a@]@."
+  let error_format self ppf report =
+    Format.fprintf ppf "@[<v>%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 "@[<v>%a@[<b 2>%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>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 "\

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