OCaml 5.00 support

dune-project

@@ -1,4 +1,4 @@
-(lang dune 1.4)
+(lang dune 2.3)
 
 (name reason)
 

src/menhir-recover/emitter.ml

@@ -150,8 +150,7 @@ end = struct
 
   let emit_default_value ppf =
     fprintf ppf "open %s\n\n"
-      (String.capitalize (Filename.basename Grammar.basename))
-      [@ocaml.warning "-3"];
+      (String.capitalize_ascii (Filename.basename Grammar.basename));
     fprintf ppf "module Default = struct\n";
     A.default_prelude ppf;
 

src/reason-parser/dune

@@ -7,6 +7,8 @@
  (targets ocaml_util.ml)
  (deps
   ../generate/select.exe
+  ocaml_util.ml-5.0
+  ocaml_util.ml-5.00
   ocaml_util.ml-4.14
   ocaml_util.ml-4.13
   ocaml_util.ml-4.12
@@ -22,6 +24,8 @@
    %{targets}
    (run
     ../generate/select.exe
+    ocaml_util.ml-5.0
+    ocaml_util.ml-5.00
     ocaml_util.ml-4.14
     ocaml_util.ml-4.13
     ocaml_util.ml-4.12

src/reason-parser/menhir_error_processor.ml

@@ -62,6 +62,6 @@ let () =
   List.iter
     (fun term ->
        let symbol = T (terminal_find term) in
-       let name = (String.lowercase term) [@ocaml.warning "-3"] in
+       let name = (String.lowercase_ascii term) [@ocaml.warning "-3"] in
        print_transitions_on name ((=) symbol))
     [ "LIDENT"; "UIDENT"; "SEMI"; "RBRACKET"; "RPAREN"; "RBRACE" ]

src/reason-parser/ocaml_util.ml-5.0

@@ -0,0 +1,11 @@
+let warn_latin1 lexbuf =
+  Location.deprecated (Location.curr lexbuf) "ISO-Latin1 characters in identifiers"
+;;
+
+let print_loc ppf loc =
+  Location.print_loc ppf loc
+
+
+let print_error loc f ppf x =
+  let error = Location.error_of_printer ~loc f x in
+  Location.print_report ppf error

src/reason-parser/ocaml_util.ml-5.00

@@ -0,0 +1,11 @@
+let warn_latin1 lexbuf =
+  Location.deprecated (Location.curr lexbuf) "ISO-Latin1 characters in identifiers"
+;;
+
+let print_loc ppf loc =
+  Location.print_loc ppf loc
+
+
+let print_error loc f ppf x =
+  let error = Location.error_of_printer ~loc f x in
+  Location.print_report ppf error

src/reason-parser/vendor/cmdliner/vendored_cmdliner.ml

@@ -424,8 +424,8 @@ module Help = struct
   | `M_choice -> str "%s%c%s" (fst ei.main).name sep (fst ei.term).name
 
   let title ei =
-    let prog = String.capitalize (fst ei.main).name in
-    let name = String.uppercase (invocation ~sep:'-' ei) in
+    let prog = String.capitalize_ascii (fst ei.main).name in
+    let name = String.uppercase_ascii (invocation ~sep:'-' ei) in
     let left_footer = prog ^ match (fst ei.main).version with
       | None -> "" | Some v -> str " %s" v
     in
@@ -504,7 +504,7 @@ module Help = struct
     let subst = function
     | "docv" -> str "$(i,%s)" a.docv
     | "opt" when is_opt a ->
-        let k = String.lowercase (List.hd (List.sort compare a.o_names)) in
+        let k = String.lowercase_ascii (List.hd (List.sort compare a.o_names)) in
         str "$(b,%s)" k
     | "env" when a.env_info <> None ->
         begin match a.env_info with
@@ -526,12 +526,12 @@ module Help = struct
       match is_opt a, is_opt a' with
       | true, true ->
           let key names =
-            let k = String.lowercase (List.hd (List.sort rev_compare names)) in
+            let k = String.lowercase_ascii (List.hd (List.sort rev_compare names)) in
             if k.[1] = '-' then String.sub k 1 (String.length k - 1) else k
           in
           compare (key a.o_names) (key a'.o_names)
       | false, false ->
-          compare (String.lowercase a.docv) (String.lowercase a'.docv)
+          compare (String.lowercase_ascii a.docv) (String.lowercase_ascii a'.docv)
       | true, false -> -1
       | false, true -> 1
     in
@@ -914,7 +914,7 @@ module Arg = struct
       p_kind = All; o_kind = Flag; o_names = List.rev_map dash names;
       o_all = false; }
 
-  let env_bool_parse s = match String.lowercase s with
+  let env_bool_parse s = match String.lowercase_ascii s with
   | "" | "false" | "no" | "n" | "0" -> `Ok false
   | "true" | "yes" | "y" | "1" -> `Ok true
   | s -> `Error (Err.invalid_val s (alts_str ["true"; "yes"; "false"; "no" ]))

src/reason-parser/vendor/easy_format/dune

@@ -1,5 +1,6 @@
 (library
  (name ReasonEasyFormat)
  (public_name reason.easy_format)
+ (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file})))
   (wrapped false)
   (flags (:standard -w -9-27-32-50)))

src/reason-parser/vendor/easy_format/vendored_easy_format.ml

@@ -211,18 +211,32 @@ struct
   *)
   let set_escape fmt escape =
     let print0, flush0 = pp_get_formatter_output_functions fmt () in
-    let tagf0 = (pp_get_formatter_tag_functions [@warning "-3"]) fmt () in
+    let tagf0 =
+#if OCAML_VERSION >= (5, 0, 0)
+      pp_get_formatter_stag_functions
+#else
+      (pp_get_formatter_tag_functions [@warning "-3"])
+#endif
+      fmt () in
 
     let is_tag = ref false in
 
     let mot tag =
       is_tag := true;
+#if OCAML_VERSION >= (5, 0, 0)
+      tagf0.mark_open_stag tag
+#else
       tagf0.mark_open_tag tag
+#endif
     in
 
     let mct tag =
       is_tag := true;
+#if OCAML_VERSION >= (5, 0, 0)
+      tagf0.mark_close_stag tag
+#else
       tagf0.mark_close_tag tag
+#endif
     in
 
     let print s p n =
@@ -235,12 +249,22 @@ struct
 
     let tagf = {
       tagf0 with
+#if OCAML_VERSION >= (5, 0, 0)
+        mark_open_stag = mot;
+        mark_close_stag = mct
+#else
         mark_open_tag = mot;
         mark_close_tag = mct
+#endif
     }
     in
     pp_set_formatter_output_functions fmt print flush0;
-    (pp_set_formatter_tag_functions [@warning "-3"]) fmt tagf
+#if OCAML_VERSION >= (5, 0, 0)
+    pp_set_formatter_stag_functions
+#else
+    (pp_set_formatter_tag_functions [@warning "-3"])
+#endif
+    fmt tagf
 
 
   let set_escape_string fmt esc =
@@ -262,22 +286,55 @@ struct
           Hashtbl.add tbl1 style_name style.tag_open;
           Hashtbl.add tbl2 style_name style.tag_close
       ) l;
+#if OCAML_VERSION >= (5, 0, 0)
+      let mark_open_tag = function
+        | Format.String_tag style_name ->
+            (try Hashtbl.find tbl1 style_name
+             with Not_found -> "")
+        | _ -> ""
+      in
+      let mark_close_tag = function
+        | Format.String_tag style_name ->
+            (try Hashtbl.find tbl2 style_name
+             with Not_found -> "")
+        | _ ->
+            ""
+#else
       let mark_open_tag style_name =
         try Hashtbl.find tbl1 style_name
         with Not_found -> ""
       in
       let mark_close_tag style_name =
         try Hashtbl.find tbl2 style_name
         with Not_found -> ""
+#endif
+
       in
 
       let tagf = {
-        ((pp_get_formatter_tag_functions [@warning "-3"]) fmt ()) with
+        (
+#if OCAML_VERSION >= (5, 0, 0)
+          pp_get_formatter_stag_functions
+#else
+          (pp_get_formatter_tag_functions [@warning "-3"])
+#endif
+          fmt ()
+        ) with
+#if OCAML_VERSION >= (5, 0, 0)
+          mark_open_stag = mark_open_tag;
+          mark_close_stag = mark_close_tag;
+#else
           mark_open_tag = mark_open_tag;
-          mark_close_tag = mark_close_tag
+          mark_close_tag = mark_close_tag;
+#endif
       }
       in
-      (pp_set_formatter_tag_functions [@warning "-3"]) fmt tagf
+#if OCAML_VERSION >= (5, 0, 0)
+      pp_set_formatter_stag_functions
+#else
+      (pp_set_formatter_tag_functions [@warning "-3"])
+#endif
+      fmt tagf
     );
 
     (match escape with
@@ -330,26 +387,50 @@ struct
 
   let open_tag fmt = function
       None -> ()
-    | Some s -> (pp_open_tag [@warning "-3"]) fmt s
+    | Some s ->
+#if OCAML_VERSION >= (5, 0, 0)
+        pp_open_stag
+#else
+        (pp_open_tag [@warning "-3"])
+#endif
+        fmt s
 
   let close_tag fmt = function
       None -> ()
-    | Some _ -> (pp_close_tag [@warning "-3"]) fmt ()
+    | Some _ ->
+#if OCAML_VERSION >= (5, 0, 0)
+        pp_close_stag
+#else
+        (pp_close_tag [@warning "-3"])
+#endif
+        fmt ()
 
   let tag_string fmt o s =
     match o with
         None -> pp_print_string fmt s
       | Some tag ->
+#if OCAML_VERSION >= (5, 0, 0)
+          pp_open_stag fmt (Format.String_tag tag);
+#else
           (pp_open_tag [@warning "-3"]) fmt tag;
+#endif
           pp_print_string fmt s;
+#if OCAML_VERSION >= (5, 0, 0)
+          pp_close_stag fmt ()
+#else
           (pp_close_tag [@warning "-3"]) fmt ()
+#endif
 
   let rec fprint_t fmt = function
       Atom (s, p) ->
         tag_string fmt p.atom_style s;
 
     | List ((_, _, _, p) as param, l) ->
+#if OCAML_VERSION >= (5, 0, 0)
+        open_tag fmt (match p.list_style with Some ls -> Some (Format.String_tag ls) | None -> None);
+#else
         open_tag fmt p.list_style;
+#endif
         if p.align_closing then
           fprint_list fmt None param l
         else
@@ -360,7 +441,11 @@ struct
     | Custom f -> f fmt
 
   and fprint_list_body_stick_left fmt p sep hd tl =
+#if OCAML_VERSION >= (5, 0, 0)
+    open_tag fmt (match p.body_style with Some bs -> Some (Format.String_tag bs) | None -> None);
+#else
     open_tag fmt p.body_style;
+#endif
     fprint_t fmt hd;
     List.iter (
       fun x ->
@@ -376,7 +461,11 @@ struct
     close_tag fmt p.body_style
 
   and fprint_list_body_stick_right fmt p sep hd tl =
+#if OCAML_VERSION >= (5, 0, 0)
+    open_tag fmt (match p.body_style with Some bs -> Some (Format.String_tag bs) | None -> None);
+#else
     open_tag fmt p.body_style;
+#endif
     fprint_t fmt hd;
     List.iter (
       fun x ->
@@ -394,7 +483,11 @@ struct
   and fprint_opt_label fmt = function
       None -> ()
     | Some (lab, lp) ->
+#if OCAML_VERSION >= (5, 0, 0)
+        open_tag fmt (match lp.label_style with Some ls -> Some (Format.String_tag ls) | None -> None);
+#else
         open_tag fmt lp.label_style;
+#endif
         fprint_t fmt lab;
         close_tag fmt lp.label_style;
         if lp.space_after_label then
@@ -525,7 +618,11 @@ struct
           let indent = lp.indent_after_label in
           pp_open_hvbox fmt 0;
 
+#if OCAML_VERSION >= (5, 0, 0)
+          open_tag fmt (match lp.label_style with Some ls -> Some (Format.String_tag ls) | None -> None);
+#else
           open_tag fmt lp.label_style;
+#endif
           fprint_t fmt lab;
           close_tag fmt lp.label_style;
 

src/vendored-omp/src/ast_408.ml

@@ -3674,7 +3674,6 @@ end = struct
           lid "principal", make_bool !Clflags.principal;
           lid "transparent_modules", make_bool !Clflags.transparent_modules;
           lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ());
-          lid "unsafe_string", make_bool !Clflags.unsafe_string;
           get_cookies ()
         ]
       in
@@ -3751,8 +3750,6 @@ end = struct
           Clflags.transparent_modules := get_bool payload
         | "unboxed_types" ->
           Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload)
-        | "unsafe_string" ->
-          Clflags.unsafe_string := get_bool payload
         | "cookies" ->
           let l = get_list (get_pair get_string (fun x -> x)) payload in
           cookies :=

src/vendored-omp/src/ast_409.ml

@@ -3663,7 +3663,6 @@ end = struct
           lid "principal", make_bool !Clflags.principal;
           lid "transparent_modules", make_bool !Clflags.transparent_modules;
           lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ());
-          lid "unsafe_string", make_bool !Clflags.unsafe_string;
           get_cookies ()
         ]
       in
@@ -3740,8 +3739,6 @@ end = struct
           Clflags.transparent_modules := get_bool payload
         | "unboxed_types" ->
           Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload)
-        | "unsafe_string" ->
-          Clflags.unsafe_string := get_bool payload
         | "cookies" ->
           let l = get_list (get_pair get_string (fun x -> x)) payload in
           cookies :=

src/vendored-omp/src/ast_410.ml

@@ -3674,7 +3674,6 @@ end = struct
           lid "principal", make_bool !Clflags.principal;
           lid "transparent_modules", make_bool !Clflags.transparent_modules;
           lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ());
-          lid "unsafe_string", make_bool !Clflags.unsafe_string;
           get_cookies ()
         ]
       in
@@ -3754,8 +3753,6 @@ end = struct
             Clflags.transparent_modules := get_bool payload
         | "unboxed_types" ->
             Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload)
-        | "unsafe_string" ->
-            Clflags.unsafe_string := get_bool payload
         | "cookies" ->
             let l = get_list (get_pair get_string (fun x -> x)) payload in
             cookies :=