Backport dead code in vendored parsers (ocaml-ppx#2424)

* vendored parsers: Backport dead-code as comments

Dead code in parser-extended have been removed in the past. I reverted that
and commented it out instead. This makes the code more similar with
parser-standard and helps recognize new code from previously removed
code.

* Backport 5.1 error printing code

This slightly change some error messages.

Author: Julow

test/failing/tests/unit_lex.ml.broken-ref

@@ -3,6 +3,7 @@ File "tests/unit_lex.ml", line 18, characters 4-10:
          ^^^^^^
 Alert deprecated: ISO-Latin1 characters in identifiers
 ocamlformat: ignoring "tests/unit_lex.ml" (syntax error)
+
 File "tests/unit_lex.ml", line 55, characters 2-8:
 55 |   '\999'; (* wrong, but yet... *)
        ^^^^^^

test/failing/tests/unit_values.ml.broken-ref

@@ -3,6 +3,7 @@ File "tests/unit_values.ml", line 6, characters 10-11:
               ^
 Alert deprecated: ISO-Latin1 characters in identifiers
 ocamlformat: ignoring "tests/unit_values.ml" (syntax error)
+
 File "tests/unit_values.ml", line 6, characters 11-12:
 6 | let i32 = −1073741824, 1073741823
                ^

test/passing/tests/error3.ml.err

@@ -3,6 +3,7 @@ File "tests/error3.ml", line 2, characters 0-13:
 2 | (** a or b *)
     ^^^^^^^^^^^^^
 Warning 50 [unexpected-docstring]: ambiguous documentation comment
+
 File "tests/error3.ml", line 3, characters 8-16:
 3 | let b = (** ? *) ()          
             ^^^^^^^^

test/passing/tests/error4.ml.err

@@ -2,6 +2,7 @@ File "tests/error4.ml", line 2, characters 0-13:
 2 | (** a or b *)
     ^^^^^^^^^^^^^
 Warning 50 [unexpected-docstring]: ambiguous documentation comment
+
 File "tests/error4.ml", line 3, characters 8-16:
 3 | let b = (** ? *) ()          
             ^^^^^^^^

test/passing/tests/option.ml.err

@@ -3,21 +3,25 @@ File "tests/option.ml", line 63, characters 17-28:
                       ^^^^^^^^^^^
 Warning 47 [attribute-payload]: illegal payload for attribute 'ocamlformat'.
 margin not allowed here
+
 File "tests/option.ml", line 13, characters 3-19:
 13 | [@@ocamlformat.typo "if-then-else=keyword-first"]
         ^^^^^^^^^^^^^^^^
 Warning 47 [attribute-payload]: illegal payload for attribute 'ocamlformat.typo'.
 Invalid format: Unknown suffix "typo"
+
 File "tests/option.ml", line 21, characters 3-14:
 21 | [@@ocamlformat 1, "if-then-else=keyword-first"]
         ^^^^^^^^^^^
 Warning 47 [attribute-payload]: illegal payload for attribute 'ocamlformat'.
 Invalid format: String expected
+
 File "tests/option.ml", line 28, characters 3-14:
 28 | [@@ocamlformat "if-then-else=bad"]
         ^^^^^^^^^^^
 Warning 47 [attribute-payload]: illegal payload for attribute 'ocamlformat'.
 For option "if-then-else": invalid value 'bad', expected one of 'compact', 'fit-or-vertical', 'vertical', 'keyword-first' or 'k-r'
+
 File "tests/option.ml", line 39, characters 14-25:
 39 |            [@@ocamlformat "if-then-else=bad"]
                    ^^^^^^^^^^^

test/unit/test_translation_unit.ml

@@ -65,6 +65,7 @@ let test_parse_and_format_module_type =
       ~expected:
         (Error
            {|test_unit: ignoring "<test>" (syntax error)
+
 File "<test>", line 1, characters 3-3:
 Error: Syntax error: 'end' expected
 File "<test>", line 1, characters 0-3:

vendor/ocaml-common/location.ml

@@ -95,9 +95,20 @@ let setup_terminal () =
    input in the terminal. This would not be possible without this information,
    since printing several warnings/errors adds text between the user input and
    the bottom of the terminal.
+
+   We also use for {!is_first_report}, see below.
 *)
 let num_loc_lines = ref 0
 
+(* We use [num_loc_lines] to determine if the report about to be
+   printed is the first or a follow-up report of the current
+   "batch" -- contiguous reports without user input in between, for
+   example for the current toplevel phrase. We use this to print
+   a blank line between messages of the same batch.
+*)
+let is_first_message () =
+  !num_loc_lines = 0
+
 (* This is used by the toplevel to reset [num_loc_lines] before each phrase *)
 let reset () =
   num_loc_lines := 0
@@ -107,6 +118,13 @@ let echo_eof () =
   print_newline ();
   incr num_loc_lines
 
+(* This is used by the toplevel and the report printers below. *)
+let separate_new_message ppf =
+  if not (is_first_message ()) then begin
+    Format.pp_print_newline ppf ();
+    incr num_loc_lines
+  end
+
 (* Code printing errors and warnings must be wrapped using this function, in
    order to update [num_loc_lines].
 
@@ -459,20 +477,28 @@ let highlight_quote ppf
         (* Single-line error *)
         Format.fprintf ppf "%s | %s@," line_nb line;
         Format.fprintf ppf "%*s   " (String.length line_nb) "";
-        String.iteri (fun i c ->
+        (* Iterate up to [rightmost], which can be larger than the length of
+           the line because we may point to a location after the end of the
+           last token on the line, for instance:
+           {[
+             token
+                       ^
+             Did you forget ...
+           ]} *)
+        for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do
           let pos = line_start_cnum + i in
           if ISet.is_start iset ~pos <> None then
             Format.fprintf ppf "@{<%s>" highlight_tag;
           if ISet.mem iset ~pos then Format.pp_print_char ppf '^'
-          else if pos < rightmost.pos_cnum then begin
+          else if i < String.length line then begin
             (* For alignment purposes, align using a tab for each tab in the
                source code *)
-            if c = '\t' then Format.pp_print_char ppf '\t'
+            if line.[i] = '\t' then Format.pp_print_char ppf '\t'
             else Format.pp_print_char ppf ' '
           end;
           if ISet.is_end iset ~pos <> None then
             Format.fprintf ppf "@}"
-        ) line;
+        done;
         Format.fprintf ppf "@}@,"
     | _ ->
         (* Multi-line error *)
@@ -722,6 +748,7 @@ let batch_mode_printer : report_printer =
   let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in
   let pp self ppf report =
     setup_colors ();
+    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
@@ -895,6 +922,32 @@ let alert ?(def = none) ?(use = none) ~kind loc message =
 let deprecated ?def ?use loc message =
   alert ?def ?use ~kind:"deprecated" loc message
 
+let auto_include_alert lib =
+  let message = Printf.sprintf "\
+    OCaml's lib directory layout changed in 5.0. The %s subdirectory has been \
+    automatically added to the search path, but you should add -I +%s to the \
+    command-line to silence this alert (e.g. by adding %s to the list of \
+    libraries in your dune file, or adding use_%s to your _tags file for \
+    ocamlbuild, or using -package %s for ocamlfind)." lib lib lib lib lib in
+  let alert =
+    {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none;
+     message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message}
+  in
+  prerr_alert none alert
+
+let deprecated_script_alert program =
+  let message = Printf.sprintf "\
+    Running %s where the first argument is an implicit basename with no \
+    extension (e.g. %s script-file) is deprecated. Either rename the script \
+    (%s script-file.ml) or qualify the basename (%s ./script-file)"
+    program program program program
+  in
+  let alert =
+    {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none;
+     message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message}
+  in
+  prerr_alert none alert
+
 (******************************************************************************)
 (* Reporting errors on exceptions *)
 

vendor/ocaml-common/location.mli

@@ -88,17 +88,25 @@ val input_phrase_buffer: Buffer.t option ref
 (** {1 Toplevel-specific functions} *)
 
 val echo_eof: unit -> unit
+val separate_new_message: formatter -> unit
 val reset: unit -> unit
 
 
-(** {1 Printing locations} *)
+(** {1 Rewriting path } *)
 
 val rewrite_absolute_path: string -> string
     (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP
         variable (https://reproducible-builds.org/specs/build-path-prefix-map/)
         if it is set. *)
 
 val absolute_path: string -> string
+ (** [absolute_path path] first makes an absolute path, [s] from [path],
+     prepending the current working directory if [path] was relative.
+     Then [s] is rewritten using [rewrite_absolute_path].
+     Finally the result is normalized by eliminating instances of
+     ['.'] or ['..']. *)
+
+(** {1 Printing locations} *)
 
 val show_filename: string -> string
     (** In -absname mode, return the absolute path for this filename.
@@ -243,6 +251,13 @@ val deprecated: ?def:t -> ?use:t -> t -> string -> unit
 val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit
 (** Prints an arbitrary alert. *)
 
+val auto_include_alert: string -> unit
+(** Prints an alert that -I +lib has been automatically added to the load
+    path *)
+
+val deprecated_script_alert: string -> unit
+(** [deprecated_script_alert command] prints an alert that [command foo] has
+    been deprecated in favour of [command ./foo] *)
 
 (** {1 Reporting errors} *)
 

vendor/parser-extended/parser.mly

@@ -102,6 +102,9 @@ let mkcf ~loc ?attrs ?docs d =
   Cf.mk ~loc:(make_loc loc) ?attrs ?docs d
 
 let mkrhs rhs loc = mkloc rhs (make_loc loc)
+(*
+let ghrhs rhs loc = mkloc rhs (ghost_loc loc)
+*)
 
 let mk_optional lbl loc = Optional (mkrhs lbl loc)
 let mk_labelled lbl loc = Labelled (mkrhs lbl loc)
@@ -150,6 +153,9 @@ let mkpatvar ~loc name =
 let ghexp ~loc d = Exp.mk ~loc:(ghost_loc loc) d
 let ghpat ~loc d = Pat.mk ~loc:(ghost_loc loc) d
 let ghtyp ~loc d = Typ.mk ~loc:(ghost_loc loc) d
+(*
+let ghloc ~loc d = { txt = d; loc = ghost_loc loc }
+*)
 let ghstr ~loc d = Str.mk ~loc:(ghost_loc loc) d
 let ghsig ~loc d = Sig.mk ~loc:(ghost_loc loc) d
 
@@ -182,6 +188,43 @@ let mkuplus ~oploc name arg =
    and locations-as-Location.t; it should be clear when we move from
    one world to the other *)
 
+(*
+let mkexp_cons_desc consloc args =
+  Pexp_construct(mkrhs (Lident "::") consloc, Some args)
+let mkexp_cons ~loc consloc args =
+  mkexp ~loc (mkexp_cons_desc consloc args)
+
+let mkpat_cons_desc consloc args =
+  Ppat_construct(mkrhs (Lident "::") consloc, Some ([], args))
+let mkpat_cons ~loc consloc args =
+  mkpat ~loc (mkpat_cons_desc consloc args)
+
+let ghexp_cons_desc consloc args =
+  Pexp_construct(ghrhs (Lident "::") consloc, Some args)
+let ghpat_cons_desc consloc args =
+  Ppat_construct(ghrhs (Lident "::") consloc, Some ([], args))
+
+let rec mktailexp nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Pexp_construct (nil, None), nilloc
+  | e1 :: el ->
+      let exp_el, el_loc = mktailexp nilloc el in
+      let loc = (e1.pexp_loc.loc_start, snd el_loc) in
+      let arg = ghexp ~loc (Pexp_tuple [e1; ghexp ~loc:el_loc exp_el]) in
+      ghexp_cons_desc loc arg, loc
+
+let rec mktailpat nilloc = let open Location in function
+    [] ->
+      let nil = ghloc ~loc:nilloc (Lident "[]") in
+      Ppat_construct (nil, None), nilloc
+  | p1 :: pl ->
+      let pat_pl, el_loc = mktailpat nilloc pl in
+      let loc = (p1.ppat_loc.loc_start, snd el_loc) in
+      let arg = ghpat ~loc (Ppat_tuple [p1; ghpat ~loc:el_loc pat_pl]) in
+      ghpat_cons_desc loc arg, loc
+*)
+
 let mkstrexp e attrs =
   { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
 
@@ -191,6 +234,16 @@ let mkexp_constraint ~loc e (t1, t2) =
   | _, Some t -> mkexp ~loc (Pexp_coerce(e, t1, t))
   | None, None -> assert false
 
+(*
+let mkexp_opt_constraint ~loc e = function
+  | None -> e
+  | Some constraint_ -> mkexp_constraint ~loc e constraint_
+
+let mkpat_opt_constraint ~loc p = function
+  | None -> p
+  | Some typ -> mkpat ~loc (Ppat_constraint(p, typ))
+*)
+
 let syntax_error () =
   raise Syntaxerr.Escape_error
 
@@ -201,6 +254,11 @@ let unclosed opening_name opening_loc closing_name closing_loc =
 let expecting loc nonterm =
     raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm)))
 
+(* Continues to parse removed syntax
+let removed_string_set loc =
+  raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc)))
+*)
+
 (* Using the function [not_expecting] in a semantic action means that this
    syntactic form is recognized by the parser but is in fact incorrect. This
    idiom is used in a few places to produce ad hoc syntax error messages. *)
@@ -254,9 +312,20 @@ let loc_last (id : Longident.t Location.loc) : string Location.loc =
 let loc_lident (id : string Location.loc) : Longident.t Location.loc =
   loc_map (fun x -> Lident x) id
 
+(*
+let exp_of_longident lid =
+  let lid = loc_map (fun id -> Lident (Longident.last id)) lid in
+  Exp.mk ~loc:lid.loc (Pexp_ident lid)
+*)
+
 let exp_of_label lbl =
   Exp.mk ~loc:lbl.loc (Pexp_ident (loc_lident lbl))
 
+(*
+let pat_of_label lbl =
+  Pat.mk ~loc:lbl.loc  (Ppat_var (loc_last lbl))
+*)
+
 let mk_newtypes ~loc newtypes exp =
   let mkexp = mkexp ~loc in
   List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
@@ -299,6 +368,12 @@ let mkpat_attrs ~loc d attrs =
 
 let wrap_class_attrs ~loc:_ body attrs =
   {body with pcl_attributes = attrs @ body.pcl_attributes}
+(*
+let wrap_mod_attrs ~loc:_ attrs body =
+  {body with pmod_attributes = attrs @ body.pmod_attributes}
+let wrap_mty_attrs ~loc:_ attrs body =
+  {body with pmty_attributes = attrs @ body.pmty_attributes}
+*)
 
 let wrap_str_ext ~loc body ext =
   match ext with
@@ -1079,6 +1154,8 @@ parse_any_longident:
 
 (* Functor arguments appear in module expressions and module types. *)
 
+(* Compared to upstream, [functor_args] can be empty and is not in reverse
+   order. *)
 %inline functor_args:
   llist(functor_arg)
     { $1 }
@@ -1292,6 +1369,11 @@ module_binding_body:
   | mkmod(
       COLON mty = module_type EQUAL me = module_expr
         { Pmod_constraint(me, mty) }
+(*
+    | arg_and_pos = functor_arg body = module_binding_body
+        { let (_, arg) = arg_and_pos in
+          Pmod_functor(arg, body) }
+*)
   ) { $1 }
 ;
 
@@ -2124,7 +2206,7 @@ expr:
   | expr attribute
       { Exp.attr $1 $2 }
 /* BEGIN AVOID */
-  (*
+  (* Allowed in exprs. Commented-out to reduce diffs with upstream.
   | UNDERSCORE
      { not_expecting $loc($1) "wildcard \"_\"" }
   *)
@@ -3486,6 +3568,7 @@ label_longident:
 ;
 type_longident:
     mk_longident(mod_ext_longident, LIDENT)  { $1 }
+  (* Allow identifiers like [t/42]. *)
   | LIDENT SLASH TYPE_DISAMBIGUATOR          { Lident ($1 ^ "/" ^ $3) }
 ;
 mod_longident:

vendor/parser-shims/parser_shims.ml

@@ -49,4 +49,14 @@ module Clflags = struct
   let color = ref None                    (* -color *)
   let error_style = ref None              (* -error-style *)
   let unboxed_types = ref false
+  let no_std_include = ref false
+end
+
+module Load_path = struct
+  type dir
+  type auto_include_callback =
+    (dir -> string -> string option) -> string -> string
+  let init ~auto_include:_ _ = ()
+  let get_paths () = []
+  let auto_include_otherlibs _ _ s = s
 end