From 8e06c07f9d7962db84078369d79ad2619dbe06dc Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 3 Jan 2025 10:45:48 -0500 Subject: [PATCH 1/4] Add `_j` test for inline-records --- atdgen/test/dune | 16 + atdgen/test/test_classic_inline_record.atd | 2 +- .../test_classic_inline_record_j.expected.ml | 302 ++++++++++++++++++ .../test_classic_inline_record_j.expected.mli | 25 ++ .../test_classic_inline_record_t.expected.ml | 2 +- .../test_classic_inline_record_t.expected.mli | 2 +- 6 files changed, 346 insertions(+), 3 deletions(-) create mode 100644 atdgen/test/test_classic_inline_record_j.expected.ml create mode 100644 atdgen/test/test_classic_inline_record_j.expected.mli diff --git a/atdgen/test/dune b/atdgen/test/dune index 87417b0c..787ff288 100644 --- a/atdgen/test/dune +++ b/atdgen/test/dune @@ -283,6 +283,11 @@ (deps test_classic_inline_record.atd) (action (run %{bin:atdgen} -t %{deps}))) +(rule + (targets test_classic_inline_record_j.ml test_classic_inline_record_j.mli) + (deps test_classic_inline_record.atd) + (action (run %{bin:atdgen} -j %{deps}))) + (rule (alias runtest) (package atdgen) @@ -293,6 +298,17 @@ (package atdgen) (action (diff test_classic_inline_record_t.expected.mli test_classic_inline_record_t.mli))) +(rule + (alias runtest) + (package atdgen) + (action (diff test_classic_inline_record_j.expected.ml test_classic_inline_record_j.ml))) + +(rule + (alias runtest) + (package atdgen) + (action (diff test_classic_inline_record_j.expected.mli test_classic_inline_record_j.mli))) + + ;; OCaml keywords cannot be used as type names or record field names (rule (targets test_ocaml_keyword_error1.stderr) diff --git a/atdgen/test/test_classic_inline_record.atd b/atdgen/test/test_classic_inline_record.atd index af3937a1..3cb958fd 100644 --- a/atdgen/test/test_classic_inline_record.atd +++ b/atdgen/test/test_classic_inline_record.atd @@ -1 +1 @@ -type foo = [ Foo of {x: int} ] +type foo = [ Foo of {x: int; y: float} ] diff --git a/atdgen/test/test_classic_inline_record_j.expected.ml b/atdgen/test/test_classic_inline_record_j.expected.ml new file mode 100644 index 00000000..455a4d76 --- /dev/null +++ b/atdgen/test/test_classic_inline_record_j.expected.ml @@ -0,0 +1,302 @@ +(* Auto-generated from "test_classic_inline_record.atd" *) +[@@@ocaml.warning "-27-32-33-35-39"] + +type foo = Test_classic_inline_record_t.foo = Foo of { x: int; y: float } + +let write_foo : _ -> foo -> _ = ( + fun ob (x : foo) -> + match x with + | Foo x -> + Buffer.add_string ob "<\"Foo\":"; + ( + fun ob x -> + Buffer.add_char ob '{'; + let is_first = ref true in + if !is_first then + is_first := false + else + Buffer.add_char ob ','; + Buffer.add_string ob "\"x\":"; + ( + Yojson.Safe.write_int + ) + ob x.x; + if !is_first then + is_first := false + else + Buffer.add_char ob ','; + Buffer.add_string ob "\"y\":"; + ( + Yojson.Safe.write_float + ) + ob x.y; + Buffer.add_char ob '}'; + ) ob x; + Buffer.add_char ob '>' +) +let string_of_foo ?(len = 1024) x = + let ob = Buffer.create len in + write_foo ob x; + Buffer.contents ob +let read_foo = ( + fun p lb -> + Yojson.Safe.read_space p lb; + match Yojson.Safe.start_any_variant p lb with + | `Edgy_bracket -> ( + match Yojson.Safe.read_ident p lb with + | "Foo" -> + Atdgen_runtime.Oj_run.read_until_field_value p lb; + let x = ( + fun p lb -> + Yojson.Safe.read_space p lb; + Yojson.Safe.read_lcurl p lb; + let field_x = ref (None) in + let field_y = ref (None) in + try + Yojson.Safe.read_space p lb; + Yojson.Safe.read_object_end lb; + Yojson.Safe.read_space p lb; + let f = + fun s pos len -> + if pos < 0 || len < 0 || pos + len > String.length s then + invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); + if len = 1 then ( + match String.unsafe_get s pos with + | 'x' -> ( + 0 + ) + | 'y' -> ( + 1 + ) + | _ -> ( + -1 + ) + ) + else ( + -1 + ) + in + let i = Yojson.Safe.map_ident p f lb in + Atdgen_runtime.Oj_run.read_until_field_value p lb; + ( + match i with + | 0 -> + field_x := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_int + ) p lb + ) + ); + | 1 -> + field_y := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_number + ) p lb + ) + ); + | _ -> ( + Yojson.Safe.skip_json p lb + ) + ); + while true do + Yojson.Safe.read_space p lb; + Yojson.Safe.read_object_sep p lb; + Yojson.Safe.read_space p lb; + let f = + fun s pos len -> + if pos < 0 || len < 0 || pos + len > String.length s then + invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); + if len = 1 then ( + match String.unsafe_get s pos with + | 'x' -> ( + 0 + ) + | 'y' -> ( + 1 + ) + | _ -> ( + -1 + ) + ) + else ( + -1 + ) + in + let i = Yojson.Safe.map_ident p f lb in + Atdgen_runtime.Oj_run.read_until_field_value p lb; + ( + match i with + | 0 -> + field_x := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_int + ) p lb + ) + ); + | 1 -> + field_y := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_number + ) p lb + ) + ); + | _ -> ( + Yojson.Safe.skip_json p lb + ) + ); + done; + assert false; + with Yojson.End_of_object -> ( + ( + { + x = (match !field_x with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "x"); + y = (match !field_y with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "y"); + } + ) + ) + ) p lb + in + Yojson.Safe.read_space p lb; + Yojson.Safe.read_gt p lb; + (Foo x : foo) + | x -> + Atdgen_runtime.Oj_run.invalid_variant_tag p x + ) + | `Double_quote -> ( + match Yojson.Safe.finish_string p lb with + | x -> + Atdgen_runtime.Oj_run.invalid_variant_tag p x + ) + | `Square_bracket -> ( + match Atdgen_runtime.Oj_run.read_string p lb with + | "Foo" -> + Yojson.Safe.read_space p lb; + Yojson.Safe.read_comma p lb; + Yojson.Safe.read_space p lb; + let x = ( + fun p lb -> + Yojson.Safe.read_space p lb; + Yojson.Safe.read_lcurl p lb; + let field_x = ref (None) in + let field_y = ref (None) in + try + Yojson.Safe.read_space p lb; + Yojson.Safe.read_object_end lb; + Yojson.Safe.read_space p lb; + let f = + fun s pos len -> + if pos < 0 || len < 0 || pos + len > String.length s then + invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); + if len = 1 then ( + match String.unsafe_get s pos with + | 'x' -> ( + 0 + ) + | 'y' -> ( + 1 + ) + | _ -> ( + -1 + ) + ) + else ( + -1 + ) + in + let i = Yojson.Safe.map_ident p f lb in + Atdgen_runtime.Oj_run.read_until_field_value p lb; + ( + match i with + | 0 -> + field_x := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_int + ) p lb + ) + ); + | 1 -> + field_y := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_number + ) p lb + ) + ); + | _ -> ( + Yojson.Safe.skip_json p lb + ) + ); + while true do + Yojson.Safe.read_space p lb; + Yojson.Safe.read_object_sep p lb; + Yojson.Safe.read_space p lb; + let f = + fun s pos len -> + if pos < 0 || len < 0 || pos + len > String.length s then + invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); + if len = 1 then ( + match String.unsafe_get s pos with + | 'x' -> ( + 0 + ) + | 'y' -> ( + 1 + ) + | _ -> ( + -1 + ) + ) + else ( + -1 + ) + in + let i = Yojson.Safe.map_ident p f lb in + Atdgen_runtime.Oj_run.read_until_field_value p lb; + ( + match i with + | 0 -> + field_x := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_int + ) p lb + ) + ); + | 1 -> + field_y := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_number + ) p lb + ) + ); + | _ -> ( + Yojson.Safe.skip_json p lb + ) + ); + done; + assert false; + with Yojson.End_of_object -> ( + ( + { + x = (match !field_x with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "x"); + y = (match !field_y with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "y"); + } + ) + ) + ) p lb + in + Yojson.Safe.read_space p lb; + Yojson.Safe.read_rbr p lb; + (Foo x : foo) + | x -> + Atdgen_runtime.Oj_run.invalid_variant_tag p x + ) +) +let foo_of_string s = + read_foo (Yojson.Safe.init_lexer ()) (Lexing.from_string s) diff --git a/atdgen/test/test_classic_inline_record_j.expected.mli b/atdgen/test/test_classic_inline_record_j.expected.mli new file mode 100644 index 00000000..bd71f4b7 --- /dev/null +++ b/atdgen/test/test_classic_inline_record_j.expected.mli @@ -0,0 +1,25 @@ +(* Auto-generated from "test_classic_inline_record.atd" *) +[@@@ocaml.warning "-27-32-33-35-39"] + +type foo = Test_classic_inline_record_t.foo = Foo of { x: int; y: float } + +val write_foo : + Buffer.t -> foo -> unit + (** Output a JSON value of type {!type:foo}. *) + +val string_of_foo : + ?len:int -> foo -> string + (** Serialize a value of type {!type:foo} + into a JSON string. + @param len specifies the initial length + of the buffer used internally. + Default: 1024. *) + +val read_foo : + Yojson.Safe.lexer_state -> Lexing.lexbuf -> foo + (** Input JSON data of type {!type:foo}. *) + +val foo_of_string : + string -> foo + (** Deserialize JSON data of type {!type:foo}. *) + diff --git a/atdgen/test/test_classic_inline_record_t.expected.ml b/atdgen/test/test_classic_inline_record_t.expected.ml index 6a542fd5..cf9a8936 100644 --- a/atdgen/test/test_classic_inline_record_t.expected.ml +++ b/atdgen/test/test_classic_inline_record_t.expected.ml @@ -1,4 +1,4 @@ (* Auto-generated from "test_classic_inline_record.atd" *) [@@@ocaml.warning "-27-32-33-35-39"] -type foo = Foo of { x: int } +type foo = Foo of { x: int; y: float } diff --git a/atdgen/test/test_classic_inline_record_t.expected.mli b/atdgen/test/test_classic_inline_record_t.expected.mli index 6a542fd5..cf9a8936 100644 --- a/atdgen/test/test_classic_inline_record_t.expected.mli +++ b/atdgen/test/test_classic_inline_record_t.expected.mli @@ -1,4 +1,4 @@ (* Auto-generated from "test_classic_inline_record.atd" *) [@@@ocaml.warning "-27-32-33-35-39"] -type foo = Foo of { x: int } +type foo = Foo of { x: int; y: float } From 720638cb10affcc795e81c4bb17ab72cbe0c8308 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 3 Jan 2025 12:54:26 -0500 Subject: [PATCH 2/4] Fix `oj_emit` for inline records (#417) --- atdgen/src/oj_emit.ml | 64 ++- .../test_classic_inline_record_j.expected.ml | 473 +++++++++--------- 2 files changed, 281 insertions(+), 256 deletions(-) diff --git a/atdgen/src/oj_emit.ml b/atdgen/src/oj_emit.ml index e182afb9..d32b91dc 100644 --- a/atdgen/src/oj_emit.ml +++ b/atdgen/src/oj_emit.ml @@ -438,6 +438,23 @@ and make_variant_writer p ~tick ~open_enum x : Indent.t list = Line ") ob x;"; ]; ] + | Some (Record (_, a, Record o, Record _)) -> + (* We need a special case because inline-records cannot escape their scope. *) + let op, sep, cl = + if p.std then "[", ",", ']' + else "<", ":", '>' + in + [ + Line (sprintf "| %s%s x ->" tick ocaml_cons); + Block [ + Line (sprintf "Buffer.add_string ob %S;" + (op ^ make_json_string json_cons ^ sep)); + Line "begin"; + Block (make_record_writer p a o); + Line "end (* ob x *);"; + Line (sprintf "Buffer.add_char ob %C" cl); + ] + ] | Some v -> let op, sep, cl = if p.std then "[", ",", ']' @@ -833,36 +850,47 @@ and make_case_reader ] in true, expr | Some v -> + let read_x, put_x = + match v with + | Record (loc, a, Record o, Record j) -> + (* We need a special case for inline-records: *) + let create_record_prefix = sprintf "%s%s" tick ocaml_cons in + Inline [ + Line "let x = ("; + Block (make_record_reader ~create_record_prefix p type_annot loc a j); + Line ") in"; + ], + Line "x" + | other -> + Inline [ + Line "let x = ("; + Block [ + Block (make_reader p None other); + Line ") p lb"; + ]; + Line "in"; + ], + Line (Ox_emit.opt_annot + type_annot (sprintf "%s%s x" tick ocaml_cons)); + in let expr = if std then [ Line "Yojson.Safe.read_space p lb;"; Line "Yojson.Safe.read_comma p lb;"; Line "Yojson.Safe.read_space p lb;"; - Line "let x = ("; - Block [ - Block (make_reader p None v); - Line ") p lb"; - ]; - Line "in"; + read_x; Line "Yojson.Safe.read_space p lb;"; Line "Yojson.Safe.read_rbr p lb;"; - Line (Ox_emit.opt_annot - type_annot (sprintf "%s%s x" tick ocaml_cons)); + put_x; ] else [ Line "Atdgen_runtime.Oj_run.read_until_field_value p lb;"; - Line "let x = ("; - Block [ - Block (make_reader p None v); - Line ") p lb"; - ]; - Line "in"; + read_x; Line "Yojson.Safe.read_space p lb;"; Line "Yojson.Safe.read_gt p lb;"; - Line (Ox_emit.opt_annot - type_annot (sprintf "%s%s x" tick ocaml_cons)); + put_x; ] in false, expr @@ -909,7 +937,7 @@ and make_cases_reader p type_annot ~tick ~open_enum ~std ~fallback_expr l = in all_cases @ catch_all -and make_record_reader p type_annot loc a json_options = +and make_record_reader ?(create_record_prefix = "") p type_annot loc a json_options = let keep_nulls = json_options.json_keep_nulls in let fields = Ox_emit.get_fields p.deref a in let init_fields, create_record = @@ -1014,7 +1042,7 @@ and make_record_reader p type_annot loc a json_options = Line "with Yojson.End_of_object -> ("; Block [ Block [ - Line "("; + Line (sprintf "(%s" create_record_prefix); Block create_record; Line (sprintf "%s)" (Ox_emit.insert_annot type_annot)); ]; diff --git a/atdgen/test/test_classic_inline_record_j.expected.ml b/atdgen/test/test_classic_inline_record_j.expected.ml index 455a4d76..f6350149 100644 --- a/atdgen/test/test_classic_inline_record_j.expected.ml +++ b/atdgen/test/test_classic_inline_record_j.expected.ml @@ -8,30 +8,31 @@ let write_foo : _ -> foo -> _ = ( match x with | Foo x -> Buffer.add_string ob "<\"Foo\":"; - ( - fun ob x -> - Buffer.add_char ob '{'; - let is_first = ref true in - if !is_first then - is_first := false - else - Buffer.add_char ob ','; - Buffer.add_string ob "\"x\":"; - ( - Yojson.Safe.write_int - ) - ob x.x; - if !is_first then - is_first := false - else - Buffer.add_char ob ','; - Buffer.add_string ob "\"y\":"; - ( - Yojson.Safe.write_float - ) - ob x.y; - Buffer.add_char ob '}'; - ) ob x; + Buffer.add_string ob "{"; + begin + Buffer.add_char ob '{'; + let is_first = ref true in + if !is_first then + is_first := false + else + Buffer.add_char ob ','; + Buffer.add_string ob "\"x\":"; + ( + Yojson.Safe.write_int + ) + ob x.x; + if !is_first then + is_first := false + else + Buffer.add_char ob ','; + Buffer.add_string ob "\"y\":"; + ( + Yojson.Safe.write_float + ) + ob x.y; + Buffer.add_char ob '}'; + end (* ob x *); + Buffer.add_string ob "}"; Buffer.add_char ob '>' ) let string_of_foo ?(len = 1024) x = @@ -47,122 +48,120 @@ let read_foo = ( | "Foo" -> Atdgen_runtime.Oj_run.read_until_field_value p lb; let x = ( - fun p lb -> - Yojson.Safe.read_space p lb; - Yojson.Safe.read_lcurl p lb; - let field_x = ref (None) in - let field_y = ref (None) in - try - Yojson.Safe.read_space p lb; - Yojson.Safe.read_object_end lb; - Yojson.Safe.read_space p lb; - let f = - fun s pos len -> - if pos < 0 || len < 0 || pos + len > String.length s then - invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); - if len = 1 then ( - match String.unsafe_get s pos with - | 'x' -> ( - 0 - ) - | 'y' -> ( - 1 - ) - | _ -> ( - -1 - ) - ) - else ( - -1 - ) - in - let i = Yojson.Safe.map_ident p f lb in - Atdgen_runtime.Oj_run.read_until_field_value p lb; - ( - match i with - | 0 -> - field_x := ( - Some ( - ( - Atdgen_runtime.Oj_run.read_int - ) p lb - ) - ); - | 1 -> - field_y := ( - Some ( - ( - Atdgen_runtime.Oj_run.read_number - ) p lb - ) - ); - | _ -> ( - Yojson.Safe.skip_json p lb + Yojson.Safe.read_space p lb; + Yojson.Safe.read_lcurl p lb; + let field_x = ref (None) in + let field_y = ref (None) in + try + Yojson.Safe.read_space p lb; + Yojson.Safe.read_object_end lb; + Yojson.Safe.read_space p lb; + let f = + fun s pos len -> + if pos < 0 || len < 0 || pos + len > String.length s then + invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); + if len = 1 then ( + match String.unsafe_get s pos with + | 'x' -> ( + 0 ) - ); - while true do - Yojson.Safe.read_space p lb; - Yojson.Safe.read_object_sep p lb; - Yojson.Safe.read_space p lb; - let f = - fun s pos len -> - if pos < 0 || len < 0 || pos + len > String.length s then - invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); - if len = 1 then ( - match String.unsafe_get s pos with - | 'x' -> ( - 0 - ) - | 'y' -> ( - 1 - ) - | _ -> ( - -1 - ) + | 'y' -> ( + 1 ) - else ( + | _ -> ( -1 ) - in - let i = Yojson.Safe.map_ident p f lb in - Atdgen_runtime.Oj_run.read_until_field_value p lb; - ( - match i with - | 0 -> - field_x := ( - Some ( - ( - Atdgen_runtime.Oj_run.read_int - ) p lb - ) - ); - | 1 -> - field_y := ( - Some ( - ( - Atdgen_runtime.Oj_run.read_number - ) p lb - ) - ); + ) + else ( + -1 + ) + in + let i = Yojson.Safe.map_ident p f lb in + Atdgen_runtime.Oj_run.read_until_field_value p lb; + ( + match i with + | 0 -> + field_x := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_int + ) p lb + ) + ); + | 1 -> + field_y := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_number + ) p lb + ) + ); + | _ -> ( + Yojson.Safe.skip_json p lb + ) + ); + while true do + Yojson.Safe.read_space p lb; + Yojson.Safe.read_object_sep p lb; + Yojson.Safe.read_space p lb; + let f = + fun s pos len -> + if pos < 0 || len < 0 || pos + len > String.length s then + invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); + if len = 1 then ( + match String.unsafe_get s pos with + | 'x' -> ( + 0 + ) + | 'y' -> ( + 1 + ) | _ -> ( - Yojson.Safe.skip_json p lb + -1 ) - ); - done; - assert false; - with Yojson.End_of_object -> ( - ( - { - x = (match !field_x with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "x"); - y = (match !field_y with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "y"); - } ) - ) - ) p lb - in + else ( + -1 + ) + in + let i = Yojson.Safe.map_ident p f lb in + Atdgen_runtime.Oj_run.read_until_field_value p lb; + ( + match i with + | 0 -> + field_x := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_int + ) p lb + ) + ); + | 1 -> + field_y := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_number + ) p lb + ) + ); + | _ -> ( + Yojson.Safe.skip_json p lb + ) + ); + done; + assert false; + with Yojson.End_of_object -> ( + (Foo + { + x = (match !field_x with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "x"); + y = (match !field_y with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "y"); + } + : foo) + ) + ) in Yojson.Safe.read_space p lb; Yojson.Safe.read_gt p lb; - (Foo x : foo) + x | x -> Atdgen_runtime.Oj_run.invalid_variant_tag p x ) @@ -178,122 +177,120 @@ let read_foo = ( Yojson.Safe.read_comma p lb; Yojson.Safe.read_space p lb; let x = ( - fun p lb -> - Yojson.Safe.read_space p lb; - Yojson.Safe.read_lcurl p lb; - let field_x = ref (None) in - let field_y = ref (None) in - try - Yojson.Safe.read_space p lb; - Yojson.Safe.read_object_end lb; - Yojson.Safe.read_space p lb; - let f = - fun s pos len -> - if pos < 0 || len < 0 || pos + len > String.length s then - invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); - if len = 1 then ( - match String.unsafe_get s pos with - | 'x' -> ( - 0 - ) - | 'y' -> ( - 1 - ) - | _ -> ( - -1 - ) - ) - else ( - -1 - ) - in - let i = Yojson.Safe.map_ident p f lb in - Atdgen_runtime.Oj_run.read_until_field_value p lb; - ( - match i with - | 0 -> - field_x := ( - Some ( - ( - Atdgen_runtime.Oj_run.read_int - ) p lb - ) - ); - | 1 -> - field_y := ( - Some ( - ( - Atdgen_runtime.Oj_run.read_number - ) p lb - ) - ); - | _ -> ( - Yojson.Safe.skip_json p lb + Yojson.Safe.read_space p lb; + Yojson.Safe.read_lcurl p lb; + let field_x = ref (None) in + let field_y = ref (None) in + try + Yojson.Safe.read_space p lb; + Yojson.Safe.read_object_end lb; + Yojson.Safe.read_space p lb; + let f = + fun s pos len -> + if pos < 0 || len < 0 || pos + len > String.length s then + invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); + if len = 1 then ( + match String.unsafe_get s pos with + | 'x' -> ( + 0 ) - ); - while true do - Yojson.Safe.read_space p lb; - Yojson.Safe.read_object_sep p lb; - Yojson.Safe.read_space p lb; - let f = - fun s pos len -> - if pos < 0 || len < 0 || pos + len > String.length s then - invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); - if len = 1 then ( - match String.unsafe_get s pos with - | 'x' -> ( - 0 - ) - | 'y' -> ( - 1 - ) - | _ -> ( - -1 - ) + | 'y' -> ( + 1 ) - else ( + | _ -> ( -1 ) - in - let i = Yojson.Safe.map_ident p f lb in - Atdgen_runtime.Oj_run.read_until_field_value p lb; - ( - match i with - | 0 -> - field_x := ( - Some ( - ( - Atdgen_runtime.Oj_run.read_int - ) p lb - ) - ); - | 1 -> - field_y := ( - Some ( - ( - Atdgen_runtime.Oj_run.read_number - ) p lb - ) - ); + ) + else ( + -1 + ) + in + let i = Yojson.Safe.map_ident p f lb in + Atdgen_runtime.Oj_run.read_until_field_value p lb; + ( + match i with + | 0 -> + field_x := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_int + ) p lb + ) + ); + | 1 -> + field_y := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_number + ) p lb + ) + ); + | _ -> ( + Yojson.Safe.skip_json p lb + ) + ); + while true do + Yojson.Safe.read_space p lb; + Yojson.Safe.read_object_sep p lb; + Yojson.Safe.read_space p lb; + let f = + fun s pos len -> + if pos < 0 || len < 0 || pos + len > String.length s then + invalid_arg (Printf.sprintf "out-of-bounds substring position or length: string = %S, requested position = %i, requested length = %i" s pos len); + if len = 1 then ( + match String.unsafe_get s pos with + | 'x' -> ( + 0 + ) + | 'y' -> ( + 1 + ) | _ -> ( - Yojson.Safe.skip_json p lb + -1 ) - ); - done; - assert false; - with Yojson.End_of_object -> ( - ( - { - x = (match !field_x with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "x"); - y = (match !field_y with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "y"); - } ) - ) - ) p lb - in + else ( + -1 + ) + in + let i = Yojson.Safe.map_ident p f lb in + Atdgen_runtime.Oj_run.read_until_field_value p lb; + ( + match i with + | 0 -> + field_x := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_int + ) p lb + ) + ); + | 1 -> + field_y := ( + Some ( + ( + Atdgen_runtime.Oj_run.read_number + ) p lb + ) + ); + | _ -> ( + Yojson.Safe.skip_json p lb + ) + ); + done; + assert false; + with Yojson.End_of_object -> ( + (Foo + { + x = (match !field_x with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "x"); + y = (match !field_y with Some x -> x | None -> Atdgen_runtime.Oj_run.missing_field p "y"); + } + : foo) + ) + ) in Yojson.Safe.read_space p lb; Yojson.Safe.read_rbr p lb; - (Foo x : foo) + x | x -> Atdgen_runtime.Oj_run.invalid_variant_tag p x ) From 429dc0b3dd723bdff1bd307c33f38e5e624c10ab Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 3 Jan 2025 13:10:07 -0500 Subject: [PATCH 3/4] Add more tests for inline-records (#417) --- atdgen/test/dune | 4 +++- atdgen/test/test_atdgen_main.ml | 15 +++++++++++++++ .../test/test_classic_inline_record_j.expected.ml | 8 +++----- 3 files changed, 21 insertions(+), 6 deletions(-) diff --git a/atdgen/test/dune b/atdgen/test/dune index 787ff288..f20416bd 100644 --- a/atdgen/test/dune +++ b/atdgen/test/dune @@ -286,7 +286,7 @@ (rule (targets test_classic_inline_record_j.ml test_classic_inline_record_j.mli) (deps test_classic_inline_record.atd) - (action (run %{bin:atdgen} -j %{deps}))) + (action (run %{bin:atdgen} -j-std -j %{deps}))) (rule (alias runtest) @@ -416,6 +416,8 @@ test_ppx_t test_abstract_t test_abstract_j + test_classic_inline_record_t + test_classic_inline_record_j )) (rule diff --git a/atdgen/test/test_atdgen_main.ml b/atdgen/test/test_atdgen_main.ml index c6636730..d0c4c895 100644 --- a/atdgen/test/test_atdgen_main.ml +++ b/atdgen/test/test_atdgen_main.ml @@ -674,6 +674,20 @@ let test_untyped_json () = let encoded = Test_abstract_j.string_of_any_items decoded in check (encoded = input) +let test_inline_records () = + let open Test_classic_inline_record_t in + let foo = Foo { x = 42; y = 5.1 } in + Alcotest.(check string) + "test_inline_records" + (Test_classic_inline_record_j.string_of_foo foo) + {|["Foo",{"x":42,"y":5.1}]|}; + Alcotest.(check bool) + "test_inline_records-involution" + (foo = (Test_classic_inline_record_j.string_of_foo foo + |> Test_classic_inline_record_j.foo_of_string)) + true; + () + let all_tests : (string * (unit -> unit)) list = [ "ocaml internals", test_ocaml_internals; "biniou missing record fields", test_biniou_missing_field; @@ -722,6 +736,7 @@ let all_tests : (string * (unit -> unit)) list = [ "json encoding & decoding int with string representation", test_encoding_decoding_int_with_string_repr; "abstract types", test_abstract_types; "untyped json", test_untyped_json; + "inline-records", test_inline_records; ] let () = diff --git a/atdgen/test/test_classic_inline_record_j.expected.ml b/atdgen/test/test_classic_inline_record_j.expected.ml index f6350149..81f9ccf2 100644 --- a/atdgen/test/test_classic_inline_record_j.expected.ml +++ b/atdgen/test/test_classic_inline_record_j.expected.ml @@ -7,8 +7,7 @@ let write_foo : _ -> foo -> _ = ( fun ob (x : foo) -> match x with | Foo x -> - Buffer.add_string ob "<\"Foo\":"; - Buffer.add_string ob "{"; + Buffer.add_string ob "[\"Foo\","; begin Buffer.add_char ob '{'; let is_first = ref true in @@ -27,13 +26,12 @@ let write_foo : _ -> foo -> _ = ( Buffer.add_char ob ','; Buffer.add_string ob "\"y\":"; ( - Yojson.Safe.write_float + Yojson.Safe.write_std_float ) ob x.y; Buffer.add_char ob '}'; end (* ob x *); - Buffer.add_string ob "}"; - Buffer.add_char ob '>' + Buffer.add_char ob ']' ) let string_of_foo ?(len = 1024) x = let ob = Buffer.create len in From 4325c28efde23aee4e66983458e2ade33b576abe Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 3 Jan 2025 13:13:25 -0500 Subject: [PATCH 4/4] Add changelog entry --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 87fecf91..9c6d93ac 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -7,6 +7,8 @@ Unreleased * atdgen: Add support for `` in Melange (#401) * atdcpp: Initial Release (#404) * atdcpp: Use `double` c++ type as default floating point type (#411) +* atdgen: Fix JSON I/O for inline records (#419) + 2.15.0 (2023-10-26) -------------------