Merge pull request #27 from melange-community/ppx-flatten-poly

ppx: flatten tuples in poly constructors
melange-community · Oct 7, 2024 · 08528f6 · 08528f6
2 parents a47cc59 + ee8c513
commit 08528f6
Show file tree

Hide file tree

Showing 7 changed files with 313 additions and 2 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -5,6 +5,9 @@
 - PPX: Add `yojson` as runtime dep for the native version
   ([#15](https://github.com/melange-community/melange-json/pull/15))
 - PPX: Rename `[@json.as]` to `[@json.name]`
+- PPX: change JSON representation of polyvariants, make it compatible with 
+  ppx_deriving_yojson and ppx_yojson_conv
+  ([#27](https://github.com/melange-community/melange-json/pull/27))
 
 ## 1.3.0 (2024-08-28)
 

diff --git a/ppx/test/example.ml b/ppx/test/example.ml
@@ -8,7 +8,9 @@ type record = { name : string; age : int } [@@deriving json]
 type record_aliased = { name : string; [@json.key "my_name"] age : int; [@json.key "my_age"] [@json.default 100] } [@@deriving json]
 type record_opt = { k : int option; [@json.option] } [@@deriving json]
 type sum = A | B of int | C of { name : string } [@@deriving json]
+type sum2 = S2 of int * string [@@deriving json]
 type other = [ `C ] [@@deriving json] type poly = [ `A | `B of int | other ] [@@deriving json]
+type poly2 = [ `P2 of int * string ] [@@deriving json]
 type 'a c = [ `C of 'a ] [@@deriving json]
 type recur = A | Fix of recur [@@deriving json]
 type polyrecur = [ `A | `Fix of polyrecur ] [@@deriving json]
@@ -36,8 +38,10 @@ module Cases = struct
     C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
     C ({|["B", 42]|}, sum_of_json, sum_to_json, (B 42 : sum));
     C ({|["C", {"name": "cname"}]|}, sum_of_json, sum_to_json, (C {name="cname"} : sum));
-    C ({|["A"]|}, poly_of_json, poly_to_json, (`A : poly));
+    C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
+    C ({|["S2", 42, "hello"]|}, sum2_of_json, sum2_to_json, (S2 (42, "hello")));
     C ({|["B", 42]|}, poly_of_json, poly_to_json, (`B 42 : poly));
+    C ({|["P2", 42, "hello"]|}, poly2_of_json, poly2_to_json, (`P2 (42, "hello") : poly2));
     C ({|["Fix",["Fix",["Fix",["A"]]]]|}, recur_of_json, recur_to_json, (Fix (Fix (Fix A))));
     C ({|["Fix",["Fix",["Fix",["A"]]]]|}, polyrecur_of_json, polyrecur_to_json, (`Fix (`Fix (`Fix `A))));
     C ({|"A"|}, evar_of_json, evar_to_json, (A : evar));

diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t
@@ -54,8 +54,12 @@
   JSON REPRINT: ["C",{"name":"cname"}]
   JSON    DATA: ["A"]
   JSON REPRINT: ["A"]
+  JSON    DATA: ["S2", 42, "hello"]
+  JSON REPRINT: ["S2",42,"hello"]
   JSON    DATA: ["B", 42]
   JSON REPRINT: ["B",42]
+  JSON    DATA: ["P2", 42, "hello"]
+  JSON REPRINT: ["P2",42,"hello"]
   JSON    DATA: ["Fix",["Fix",["Fix",["A"]]]]
   JSON REPRINT: ["Fix",["Fix",["Fix",["A"]]]]
   JSON    DATA: ["Fix",["Fix",["Fix",["A"]]]]

diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t
@@ -19,6 +19,29 @@
     let _ = user_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]
 
+  $ cat <<"EOF" | run
+  > type floaty = float [@@deriving json]
+  > EOF
+  type floaty = float [@@deriving json]
+
+  include struct
+    let _ = fun (_ : floaty) -> ()
+
+    [@@@ocaml.warning "-39-11-27"]
+
+    let rec floaty_of_json =
+      (fun x -> float_of_json x : Js.Json.t -> floaty)
+
+    let _ = floaty_of_json
+
+    [@@@ocaml.warning "-39-11-27"]
+
+    let rec floaty_to_json =
+      (fun x -> float_to_json x : floaty -> Js.Json.t)
+
+    let _ = floaty_to_json
+  end [@@ocaml.doc "@inline"] [@@merlin.hide]
+
   $ cat <<"EOF" | run
   > type 'a param = 'a [@@deriving json]
   > EOF
@@ -65,6 +88,31 @@
     let _ = opt_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]
 
+  $ cat <<"EOF" | run
+  > type res = (int, string) result [@@deriving json]
+  > EOF
+  type res = (int, string) result [@@deriving json]
+  
+  include struct
+    let _ = fun (_ : res) -> ()
+  
+    [@@@ocaml.warning "-39-11-27"]
+  
+    let rec res_of_json =
+      (fun x -> (result_of_json int_of_json string_of_json) x
+        : Js.Json.t -> res)
+  
+    let _ = res_of_json
+  
+    [@@@ocaml.warning "-39-11-27"]
+  
+    let rec res_to_json =
+      (fun x -> (result_to_json int_to_json string_to_json) x
+        : res -> Js.Json.t)
+  
+    let _ = res_to_json
+  end [@@ocaml.doc "@inline"] [@@merlin.hide]
+
   $ cat <<"EOF" | run
   > type tuple = int * string [@@deriving json]
   > EOF
@@ -375,6 +423,63 @@
     let _ = sum_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]
 
+  $ cat <<"EOF" | run
+  > type sum2 = S2 of int * string [@@deriving json]
+  > EOF
+  type sum2 = S2 of int * string [@@deriving json]
+  
+  include struct
+    let _ = fun (_ : sum2) -> ()
+  
+    [@@@ocaml.warning "-39-11-27"]
+  
+    let rec sum2_of_json =
+      (fun x ->
+         if Js.Array.isArray x then
+           let array = (Obj.magic x : Js.Json.t array) in
+           let len = Js.Array.length array in
+           if Stdlib.( > ) len 0 then
+             let tag = Js.Array.unsafe_get array 0 in
+             if Stdlib.( = ) (Js.typeof tag) "string" then
+               let tag = (Obj.magic tag : string) in
+               if Stdlib.( = ) tag "S2" then (
+                 if Stdlib.( <> ) len 3 then
+                   Ppx_deriving_json_runtime.of_json_error
+                     "expected a JSON array of length 3";
+                 S2
+                   ( int_of_json (Js.Array.unsafe_get array 1),
+                     string_of_json (Js.Array.unsafe_get array 2) ))
+               else Ppx_deriving_json_runtime.of_json_error "invalid JSON"
+             else
+               Ppx_deriving_json_runtime.of_json_error
+                 "expected a non empty JSON array with element being a \
+                  string"
+           else
+             Ppx_deriving_json_runtime.of_json_error
+               "expected a non empty JSON array"
+         else
+           Ppx_deriving_json_runtime.of_json_error
+             "expected a non empty JSON array"
+        : Js.Json.t -> sum2)
+  
+    let _ = sum2_of_json
+  
+    [@@@ocaml.warning "-39-11-27"]
+  
+    let rec sum2_to_json =
+      (fun x ->
+         match x with
+         | S2 (x_0, x_1) ->
+             (Obj.magic
+                [|
+                  string_to_json "S2"; int_to_json x_0; string_to_json x_1;
+                |]
+               : Js.Json.t)
+        : sum2 -> Js.Json.t)
+  
+    let _ = sum2_to_json
+  end [@@ocaml.doc "@inline"] [@@merlin.hide]
+
   $ cat <<"EOF" | run
   > type other = [ `C ] [@@deriving json] type poly = [ `A | `B of int | other ] [@@deriving json]
   > EOF
@@ -478,6 +583,72 @@
     let _ = poly_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]
 
+  $ cat <<"EOF" | run
+  > type poly2 = [ `P2 of int * string ] [@@deriving json]
+  > EOF
+  type poly2 = [ `P2 of int * string ] [@@deriving json]
+  
+  include struct
+    let _ = fun (_ : poly2) -> ()
+  
+    [@@@ocaml.warning "-39-11-27"]
+  
+    let rec poly2_of_json_poly =
+      (fun x ->
+         if Js.Array.isArray x then
+           let array = (Obj.magic x : Js.Json.t array) in
+           let len = Js.Array.length array in
+           if Stdlib.( > ) len 0 then
+             let tag = Js.Array.unsafe_get array 0 in
+             if Stdlib.( = ) (Js.typeof tag) "string" then
+               let tag = (Obj.magic tag : string) in
+               if Stdlib.( = ) tag "P2" then (
+                 if Stdlib.( <> ) len 3 then
+                   Ppx_deriving_json_runtime.of_json_error
+                     "expected a JSON array of length 3";
+                 Some
+                   (`P2
+                     ( int_of_json (Js.Array.unsafe_get array 1),
+                       string_of_json (Js.Array.unsafe_get array 2) )))
+               else None
+             else
+               Ppx_deriving_json_runtime.of_json_error
+                 "expected a non empty JSON array with element being a \
+                  string"
+           else
+             Ppx_deriving_json_runtime.of_json_error
+               "expected a non empty JSON array"
+         else
+           Ppx_deriving_json_runtime.of_json_error
+             "expected a non empty JSON array"
+        : Js.Json.t -> poly2 option)
+  
+    and poly2_of_json =
+      (fun x ->
+         match poly2_of_json_poly x with
+         | Some x -> x
+         | None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
+        : Js.Json.t -> poly2)
+  
+    let _ = poly2_of_json_poly
+    and _ = poly2_of_json
+  
+    [@@@ocaml.warning "-39-11-27"]
+  
+    let rec poly2_to_json =
+      (fun x ->
+         match x with
+         | `P2 (x_0, x_1) ->
+             (Obj.magic
+                [|
+                  string_to_json "P2"; int_to_json x_0; string_to_json x_1;
+                |]
+               : Js.Json.t)
+        : poly2 -> Js.Json.t)
+  
+    let _ = poly2_to_json
+  end [@@ocaml.doc "@inline"] [@@merlin.hide]
+
   $ cat <<"EOF" | run
   > type 'a c = [ `C of 'a ] [@@deriving json]
   > EOF

diff --git a/ppx/test/ppx_deriving_json_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t
@@ -46,8 +46,12 @@
   JSON REPRINT: ["C",{"name":"cname"}]
   JSON    DATA: ["A"]
   JSON REPRINT: ["A"]
+  JSON    DATA: ["S2", 42, "hello"]
+  JSON REPRINT: ["S2",42,"hello"]
   JSON    DATA: ["B", 42]
   JSON REPRINT: ["B",42]
+  JSON    DATA: ["P2", 42, "hello"]
+  JSON REPRINT: ["P2",42,"hello"]
   JSON    DATA: ["Fix",["Fix",["Fix",["A"]]]]
   JSON REPRINT: ["Fix",["Fix",["Fix",["A"]]]]
   JSON    DATA: ["Fix",["Fix",["Fix",["A"]]]]