Difference with upstream

atd.opam

@@ -27,7 +27,7 @@ license: "MIT"
 homepage: "https://github.com/ahrefs/atd"
 bug-reports: "https://github.com/ahrefs/atd/issues"
 depends: [
-  "ocaml" {>= "4.02"}
+  "ocaml" {>= "4.03"}
   "dune" {>= "1.11"}
   "menhir"
   "easy-format"

atd/src/import.ml

@@ -1,17 +1,3 @@
-module String = struct
-  [@@@ocaml.warning "-3-32"]
-  let lowercase_ascii = StringLabels.lowercase
-  let uppercase_ascii = StringLabels.uppercase
-  let capitalize_ascii = StringLabels.capitalize
-  include String
-end
-
-module Char = struct
-  [@@@ocaml.warning "-3-32"]
-  let uppercase_ascii = Char.uppercase
-  include Char
-end
-
 module List = struct
   include List
 

atdgen-codec-runtime.opam

@@ -26,7 +26,7 @@ homepage: "https://github.com/ahrefs/atd"
 bug-reports: "https://github.com/ahrefs/atd/issues"
 depends: [
   "dune" {>= "1.11"}
-  "ocaml" {>= "4.02"}
+  "ocaml" {>= "4.03"}
   "odoc" {with-doc}
 ]
 dev-repo: "git+https://github.com/ahrefs/atd.git"

atdgen-cppo/dune

@@ -1,4 +1,4 @@
 (install
  (section bin)
- (package atdgen)
+ (package atdgen-www)
  (files atdgen-cppo cppo-json))

atdgen-runtime/src/dune

@@ -1,4 +1,4 @@
 (library
- (name atdgen_runtime)
- (public_name atdgen-runtime)
+ (name atdgen_www_runtime)
+ (public_name atdgen-www-runtime)
  (libraries biniou yojson))

atdgen-runtime/src/json_adapter.mli

@@ -8,9 +8,9 @@
 (** Module signature required of any json adapter.
     For example, an ATD annotation
     [<json
-       adapter.ocaml="Atdgen_runtime.Json_adapter.Type_field"]
+       adapter.ocaml="Atdgen_www_runtime.Json_adapter.Type_field"]
     refers to the OCaml module
-    [Atdgen_runtime.Json_adapter.Type_field].
+    [Atdgen_www_runtime.Json_adapter.Type_field].
 *)
 module type S = sig
   (** Convert a real json tree into an atd-compliant form. *)
@@ -46,7 +46,7 @@ end
 type obj = [
   | User of user
   | ...
-] <json adapter.ocaml="Atdgen_runtime.Json_adapter.Type_field">
+] <json adapter.ocaml="Atdgen_www_runtime.Json_adapter.Type_field">
 
 type user = {
   id: string;
@@ -102,7 +102,7 @@ end
 type obj = [
   | User of user
   | ...
-] <json adapter.ocaml="Atdgen_runtime.Json_adapter.One_field">
+] <json adapter.ocaml="Atdgen_www_runtime.Json_adapter.One_field">
 
 type user = {
   id: string;
@@ -169,7 +169,7 @@ type payload = [
 ]}
     and the module [My_adapter] defined as follows:
 {[
-module My_adapter = Atdgen_runtime.Json_adapter.Type_and_value_fields.Make(
+module My_adapter = Atdgen_www_runtime.Json_adapter.Type_and_value_fields.Make(
   struct
     let type_field_name = "type"
     let value_field_name = "payload"

atdgen-runtime/src/oj_run.ml

@@ -4,7 +4,7 @@
 
 open Printf
 
-type 'a write = Bi_outbuf.t -> 'a -> unit
+type 'a write = Buffer.t -> 'a -> unit
 
 exception Error of string
 
@@ -47,65 +47,67 @@ let array_iter f sep x a =
   )
 
 let write_comma ob =
-  Bi_outbuf.add_char ob ','
+  Buffer.add_char ob ','
 
 let write_list write_item ob l =
-  Bi_outbuf.add_char ob '[';
+  Buffer.add_char ob '[';
   list_iter write_item write_comma ob l;
-  Bi_outbuf.add_char ob ']'
+  Buffer.add_char ob ']'
 
 let write_array write_item ob a =
-  Bi_outbuf.add_char ob '[';
+  Buffer.add_char ob '[';
   array_iter write_item write_comma ob a;
-  Bi_outbuf.add_char ob ']'
+  Buffer.add_char ob ']'
 
 let write_assoc_list write_key write_item ob l =
-  Bi_outbuf.add_char ob '{';
+  Buffer.add_char ob '{';
   list_iter (
     fun ob (k, v) ->
       write_key ob k;
-      Bi_outbuf.add_char ob ':';
+      Buffer.add_char ob ':';
       write_item ob v
   ) write_comma ob l;
-  Bi_outbuf.add_char ob '}'
+  Buffer.add_char ob '}'
 
 let write_assoc_array write_key write_item ob l =
-  Bi_outbuf.add_char ob '{';
+  Buffer.add_char ob '{';
   array_iter (
     fun ob (k, v) ->
       write_key ob k;
-      Bi_outbuf.add_char ob ':';
+      Buffer.add_char ob ':';
       write_item ob v
   ) write_comma ob l;
-  Bi_outbuf.add_char ob '}'
+  Buffer.add_char ob '}'
 
 
 let write_option write_item ob = function
-    None -> Bi_outbuf.add_string ob "<\"None\">"
+    None -> Buffer.add_string ob "<\"None\">"
   | Some x ->
-      Bi_outbuf.add_string ob "<\"Some\":";
+      Buffer.add_string ob "<\"Some\":";
       write_item ob x;
-      Bi_outbuf.add_string ob ">"
+      Buffer.add_string ob ">"
 
 let write_std_option write_item ob = function
-    None -> Bi_outbuf.add_string ob "\"None\""
+    None -> Buffer.add_string ob "\"None\""
   | Some x ->
-      Bi_outbuf.add_string ob "[\"Some\",";
+      Buffer.add_string ob "[\"Some\",";
       write_item ob x;
-      Bi_outbuf.add_string ob "]"
+      Buffer.add_string ob "]"
 
 let write_nullable write_item ob = function
-    None -> Bi_outbuf.add_string ob "null"
+    None -> Buffer.add_string ob "null"
   | Some x -> write_item ob x
 
 let write_int8 ob x =
   Yojson.Safe.write_int ob (int_of_char x)
 
 let write_int32 ob x =
-  Bi_outbuf.add_string ob (Int32.to_string x)
+  Buffer.add_string ob (Int32.to_string x)
 
 let write_int64 ob x =
-  Bi_outbuf.add_string ob (Int64.to_string x)
+  Buffer.add_char ob '"';
+  Buffer.add_string ob (Int64.to_string x);
+  Buffer.add_char ob '"'
 
 let min_float = float min_int
 let max_float = float max_int
@@ -118,7 +120,7 @@ let write_float_as_int ob x =
     match classify_float x with
         FP_normal
       | FP_subnormal
-      | FP_zero -> Bi_outbuf.add_string ob (Printf.sprintf "%.0f" x)
+      | FP_zero -> Buffer.add_string ob (Printf.sprintf "%.0f" x)
       | FP_infinite -> error "Cannot convert inf or -inf into a JSON int"
       | FP_nan -> error "Cannot convert NaN into a JSON int"
 
@@ -229,12 +231,12 @@ let read_with_adapter normalize reader p lb =
   reader p lb'
 
 let write_with_adapter restore writer ob x =
-  let ob_tmp = Bi_outbuf.create 1024 in
+  let ob_tmp = Buffer.create 1024 in
   writer ob_tmp x;
-  let s_tmp = Bi_outbuf.contents ob_tmp in
+  let s_tmp = Buffer.contents ob_tmp in
   let ast = Yojson.Safe.from_string s_tmp in
   let ast' = restore ast in
-  Yojson.Safe.to_outbuf ob ast'
+  Yojson.Safe.to_buffer ob ast'
 
 (* We want an identity function that is not inlined *)
 type identity_t = { mutable _identity : 'a. 'a -> 'a }

atdgen-runtime/src/oj_run.mli

@@ -2,7 +2,7 @@
 
 exception Error of string
 
-type 'a write = Bi_outbuf.t -> 'a -> unit
+type 'a write = Buffer.t -> 'a -> unit
 
 val error : string -> _
 

atdgen-runtime/src/ow_run.ml

@@ -0,0 +1,131 @@
+(* Runtime library for WWW-form *)
+
+open Printf
+
+type state = {
+  top : bool;
+  prefix : string list;
+  suffix : string list;
+}
+
+type acc = (string list * string) list
+
+type 'a write = state -> acc -> 'a -> acc
+
+exception Error of string
+
+let error s = raise (Error s)
+
+let make_item ?index ?(depth_first=false) { top = _; prefix; suffix; } =
+  match depth_first with
+  | false ->
+    let prefix = match index with Some index -> "]" :: string_of_int index :: "[" :: prefix | None -> "[]" :: prefix in
+    { top = false; prefix; suffix; }
+  | true ->
+    let suffix = match index with Some index -> "[" :: string_of_int index :: "]" :: suffix | None -> "[]" :: suffix in
+    { top = false; prefix; suffix; }
+
+let make_field = function
+  | { top = true; prefix; suffix; } -> (fun key -> { top = false; prefix = key :: prefix; suffix; })
+  | { top = false; prefix; suffix; } -> (fun key -> { top = false; prefix = "]" :: key :: "[" :: prefix; suffix; })
+
+let write_list_simple write_item acc l =
+  List.fold_left write_item acc l
+
+let rec write_list_indexed index write_item acc = function
+  | [] -> acc
+  | hd :: tl -> write_list_indexed (succ index) write_item (write_item index acc hd) tl
+
+let write_list ?start_index ?depth_first write_item state acc l =
+  match start_index with
+  | None ->
+    let write_item = write_item (make_item ?depth_first state) in
+    write_list_simple write_item acc l
+  | Some start_index ->
+    let write_item index = write_item (make_item ~index ?depth_first state) in
+    write_list_indexed start_index write_item acc l
+
+let write_array_simple write_item acc l =
+  Array.fold_left write_item acc l
+
+let write_array_indexed index write_item acc l =
+  let rec aux index acc i len =
+    match i >= len with
+    | true -> acc
+    | false -> aux (succ index) (write_item index acc (Array.unsafe_get l i)) (succ i) len
+  in
+  aux index acc 0 (Array.length l)
+
+let write_array ?start_index ?depth_first write_item state acc l =
+  match start_index with
+  | None ->
+    let write_item = write_item (make_item ?depth_first state) in
+    write_array_simple write_item acc l
+  | Some start_index ->
+    let write_item index = write_item (make_item ~index ?depth_first state) in
+    write_array_indexed start_index write_item acc l
+
+let write_string write s =
+  match write { top = true; prefix = []; suffix = []; } [] s with
+  | [ [], key ] -> key
+  | _ -> error "wrong write_string output"
+
+let write_assoc_list write_key write_item state acc l =
+  let field = make_field state in
+  List.fold_left begin fun acc (key, value) ->
+    let key = write_string write_key key in
+    write_item (field key) acc value
+  end acc l
+
+let write_assoc_array write_key write_item state acc l =
+  let field = make_field state in
+  Array.fold_left begin fun acc (key, value) ->
+    let key = write_string write_key key in
+    write_item (field key) acc value
+  end acc l
+
+let write_null _state acc () = acc
+
+let write_option write_item state acc x =
+  match x with
+  | Some x -> write_item state acc x
+  | None -> acc
+
+let write_nullable = write_option
+
+let write_string { top = _; prefix; suffix; } acc x = (List.rev_append suffix prefix, x) :: acc
+
+let write_bool state acc x = write_string state acc (string_of_bool x)
+
+let write_int state acc x = write_string state acc (string_of_int x)
+
+let write_int8 state acc x = write_int state acc (int_of_char x)
+
+let write_int32 state acc x = write_string state acc (Int32.to_string x)
+
+let write_int64 state acc x = write_string state acc (Int64.to_string x)
+
+let write_float state acc x = write_string state acc (string_of_float x)
+
+let write_float_as_int state acc x =
+  if x >= min_float && x <= max_float then
+    write_int state acc (int_of_float (if x < 0. then x -. 0.5 else x +. 0.5))
+  else
+    match classify_float x with
+    | FP_normal
+    | FP_subnormal
+    | FP_zero -> write_string state acc (sprintf "%.0f" x)
+    | FP_infinite -> error "Cannot convert inf or -inf into a WWW-form int"
+    | FP_nan -> error "Cannot convert NaN into a WWW-form int"
+
+let write_float_prec prec state acc x =
+  match classify_float x with
+  | FP_normal
+  | FP_subnormal
+  | FP_zero -> write_string state acc (sprintf "%.*f" prec x)
+  | FP_infinite -> error "Cannot convert inf or -inf into a WWW-form float"
+  | FP_nan -> error "Cannot convert NaN into a WWW-form float"
+
+let www_form_of_acc write x =
+  let acc = write { top = true; prefix = []; suffix = []; } [] x in
+  List.rev_map (fun (key, value) -> String.concat "" (List.rev key), value) acc

atdgen-runtime/src/ow_run.mli

@@ -0,0 +1,33 @@
+(** OCaml-WWW-form runtime library. *)
+
+exception Error of string
+
+type state
+
+type acc = (string list * string) list
+
+type 'a write = state -> acc -> 'a -> acc
+
+val error : string -> _
+
+val make_item : ?index:int -> ?depth_first:bool -> state -> state
+val make_field : state -> string -> state
+
+val write_bool : bool write
+val write_list : ?start_index:int -> ?depth_first:bool -> 'a write -> 'a list write
+val write_array : ?start_index:int -> ?depth_first:bool -> 'a write -> 'a array write
+val write_float : float write
+val write_float_as_int : float write
+val write_float_prec : int -> float write
+val write_assoc_list : 'a write -> 'b write -> ('a * 'b) list write
+val write_assoc_array : 'a write -> 'b write -> ('a * 'b) array write
+val write_null : unit write
+val write_option : 'a write -> 'a option write
+val write_nullable : 'a write -> 'a option write
+val write_int : int write
+val write_int8 : char write
+val write_int32 : int32 write
+val write_int64 : int64 write
+val write_string : string write
+
+val www_form_of_acc : 'a write -> 'a -> (string * string) list