Fix JSON I/O for inline records (fix #417)

CHANGES.md

@@ -7,6 +7,8 @@ Unreleased
 * atdgen: Add support for `<json open_enum>` 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)
 -------------------

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));
       ];

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-std -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)
@@ -400,6 +416,8 @@
   test_ppx_t
   test_abstract_t
   test_abstract_j
+  test_classic_inline_record_t
+  test_classic_inline_record_j
   ))
 
 (rule

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 () =

atdgen/test/test_classic_inline_record.atd

@@ -1 +1 @@
-type foo = [ Foo of {x: int} ]<ocaml repr="classic">
+type foo = [ Foo of {x: int; y: float} ]<ocaml repr="classic">