Skip to content

Commit 08528f6

Browse files
jchavarrijchavarri
authored
Merge pull request #27 from melange-community/ppx-flatten-poly
ppx: flatten tuples in poly constructors
2 parents a47cc59 + ee8c513 commit 08528f6

File tree

7 files changed

+313
-2
lines changed

7 files changed

+313
-2
lines changed

‎CHANGES.md

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,9 @@
55
- PPX: Add `yojson` as runtime dep for the native version
66
([#15](https://github.com/melange-community/melange-json/pull/15))
77
- PPX: Rename `[@json.as]` to `[@json.name]`
8+
- PPX: change JSON representation of polyvariants, make it compatible with
9+
ppx_deriving_yojson and ppx_yojson_conv
10+
([#27](https://github.com/melange-community/melange-json/pull/27))
811

912
## 1.3.0 (2024-08-28)
1013

‎ppx/test/example.ml

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,9 @@ type record = { name : string; age : int } [@@deriving json]
88
type record_aliased = { name : string; [@json.key "my_name"] age : int; [@json.key "my_age"] [@json.default 100] } [@@deriving json]
99
type record_opt = { k : int option; [@json.option] } [@@deriving json]
1010
type sum = A | B of int | C of { name : string } [@@deriving json]
11+
type sum2 = S2 of int * string [@@deriving json]
1112
type other = [ `C ] [@@deriving json] type poly = [ `A | `B of int | other ] [@@deriving json]
13+
type poly2 = [ `P2 of int * string ] [@@deriving json]
1214
type 'a c = [ `C of 'a ] [@@deriving json]
1315
type recur = A | Fix of recur [@@deriving json]
1416
type polyrecur = [ `A | `Fix of polyrecur ] [@@deriving json]
@@ -36,8 +38,10 @@ module Cases = struct
3638
C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
3739
C ({|["B", 42]|}, sum_of_json, sum_to_json, (B 42 : sum));
3840
C ({|["C", {"name": "cname"}]|}, sum_of_json, sum_to_json, (C {name="cname"} : sum));
39-
C ({|["A"]|}, poly_of_json, poly_to_json, (`A : poly));
41+
C ({|["A"]|}, sum_of_json, sum_to_json, (A : sum));
42+
C ({|["S2", 42, "hello"]|}, sum2_of_json, sum2_to_json, (S2 (42, "hello")));
4043
C ({|["B", 42]|}, poly_of_json, poly_to_json, (`B 42 : poly));
44+
C ({|["P2", 42, "hello"]|}, poly2_of_json, poly2_to_json, (`P2 (42, "hello") : poly2));
4145
C ({|["Fix",["Fix",["Fix",["A"]]]]|}, recur_of_json, recur_to_json, (Fix (Fix (Fix A))));
4246
C ({|["Fix",["Fix",["Fix",["A"]]]]|}, polyrecur_of_json, polyrecur_to_json, (`Fix (`Fix (`Fix `A))));
4347
C ({|"A"|}, evar_of_json, evar_to_json, (A : evar));

‎ppx/test/ppx_deriving_json_js.e2e.t

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -54,8 +54,12 @@
5454
JSON REPRINT: ["C",{"name":"cname"}]
5555
JSON DATA: ["A"]
5656
JSON REPRINT: ["A"]
57+
JSON DATA: ["S2", 42, "hello"]
58+
JSON REPRINT: ["S2",42,"hello"]
5759
JSON DATA: ["B", 42]
5860
JSON REPRINT: ["B",42]
61+
JSON DATA: ["P2", 42, "hello"]
62+
JSON REPRINT: ["P2",42,"hello"]
5963
JSON DATA: ["Fix",["Fix",["Fix",["A"]]]]
6064
JSON REPRINT: ["Fix",["Fix",["Fix",["A"]]]]
6165
JSON DATA: ["Fix",["Fix",["Fix",["A"]]]]

‎ppx/test/ppx_deriving_json_js.t

Lines changed: 171 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,29 @@
1919
let _ = user_to_json
2020
end [@@ocaml.doc "@inline"] [@@merlin.hide]
2121

22+
$ cat <<"EOF" | run
23+
> type floaty = float [@@deriving json]
24+
> EOF
25+
type floaty = float [@@deriving json]
26+
27+
include struct
28+
let _ = fun (_ : floaty) -> ()
29+
30+
[@@@ocaml.warning "-39-11-27"]
31+
32+
let rec floaty_of_json =
33+
(fun x -> float_of_json x : Js.Json.t -> floaty)
34+
35+
let _ = floaty_of_json
36+
37+
[@@@ocaml.warning "-39-11-27"]
38+
39+
let rec floaty_to_json =
40+
(fun x -> float_to_json x : floaty -> Js.Json.t)
41+
42+
let _ = floaty_to_json
43+
end [@@ocaml.doc "@inline"] [@@merlin.hide]
44+
2245
$ cat <<"EOF" | run
2346
> type 'a param = 'a [@@deriving json]
2447
> EOF
@@ -65,6 +88,31 @@
6588
let _ = opt_to_json
6689
end [@@ocaml.doc "@inline"] [@@merlin.hide]
6790
91+
$ cat <<"EOF" | run
92+
> type res = (int, string) result [@@deriving json]
93+
> EOF
94+
type res = (int, string) result [@@deriving json]
95+
96+
include struct
97+
let _ = fun (_ : res) -> ()
98+
99+
[@@@ocaml.warning "-39-11-27"]
100+
101+
let rec res_of_json =
102+
(fun x -> (result_of_json int_of_json string_of_json) x
103+
: Js.Json.t -> res)
104+
105+
let _ = res_of_json
106+
107+
[@@@ocaml.warning "-39-11-27"]
108+
109+
let rec res_to_json =
110+
(fun x -> (result_to_json int_to_json string_to_json) x
111+
: res -> Js.Json.t)
112+
113+
let _ = res_to_json
114+
end [@@ocaml.doc "@inline"] [@@merlin.hide]
115+
68116
$ cat <<"EOF" | run
69117
> type tuple = int * string [@@deriving json]
70118
> EOF
@@ -375,6 +423,63 @@
375423
let _ = sum_to_json
376424
end [@@ocaml.doc "@inline"] [@@merlin.hide]
377425
426+
$ cat <<"EOF" | run
427+
> type sum2 = S2 of int * string [@@deriving json]
428+
> EOF
429+
type sum2 = S2 of int * string [@@deriving json]
430+
431+
include struct
432+
let _ = fun (_ : sum2) -> ()
433+
434+
[@@@ocaml.warning "-39-11-27"]
435+
436+
let rec sum2_of_json =
437+
(fun x ->
438+
if Js.Array.isArray x then
439+
let array = (Obj.magic x : Js.Json.t array) in
440+
let len = Js.Array.length array in
441+
if Stdlib.( > ) len 0 then
442+
let tag = Js.Array.unsafe_get array 0 in
443+
if Stdlib.( = ) (Js.typeof tag) "string" then
444+
let tag = (Obj.magic tag : string) in
445+
if Stdlib.( = ) tag "S2" then (
446+
if Stdlib.( <> ) len 3 then
447+
Ppx_deriving_json_runtime.of_json_error
448+
"expected a JSON array of length 3";
449+
S2
450+
( int_of_json (Js.Array.unsafe_get array 1),
451+
string_of_json (Js.Array.unsafe_get array 2) ))
452+
else Ppx_deriving_json_runtime.of_json_error "invalid JSON"
453+
else
454+
Ppx_deriving_json_runtime.of_json_error
455+
"expected a non empty JSON array with element being a \
456+
string"
457+
else
458+
Ppx_deriving_json_runtime.of_json_error
459+
"expected a non empty JSON array"
460+
else
461+
Ppx_deriving_json_runtime.of_json_error
462+
"expected a non empty JSON array"
463+
: Js.Json.t -> sum2)
464+
465+
let _ = sum2_of_json
466+
467+
[@@@ocaml.warning "-39-11-27"]
468+
469+
let rec sum2_to_json =
470+
(fun x ->
471+
match x with
472+
| S2 (x_0, x_1) ->
473+
(Obj.magic
474+
[|
475+
string_to_json "S2"; int_to_json x_0; string_to_json x_1;
476+
|]
477+
: Js.Json.t)
478+
: sum2 -> Js.Json.t)
479+
480+
let _ = sum2_to_json
481+
end [@@ocaml.doc "@inline"] [@@merlin.hide]
482+
378483
$ cat <<"EOF" | run
379484
> type other = [ `C ] [@@deriving json] type poly = [ `A | `B of int | other ] [@@deriving json]
380485
> EOF
@@ -478,6 +583,72 @@
478583
let _ = poly_to_json
479584
end [@@ocaml.doc "@inline"] [@@merlin.hide]
480585
586+
$ cat <<"EOF" | run
587+
> type poly2 = [ `P2 of int * string ] [@@deriving json]
588+
> EOF
589+
type poly2 = [ `P2 of int * string ] [@@deriving json]
590+
591+
include struct
592+
let _ = fun (_ : poly2) -> ()
593+
594+
[@@@ocaml.warning "-39-11-27"]
595+
596+
let rec poly2_of_json_poly =
597+
(fun x ->
598+
if Js.Array.isArray x then
599+
let array = (Obj.magic x : Js.Json.t array) in
600+
let len = Js.Array.length array in
601+
if Stdlib.( > ) len 0 then
602+
let tag = Js.Array.unsafe_get array 0 in
603+
if Stdlib.( = ) (Js.typeof tag) "string" then
604+
let tag = (Obj.magic tag : string) in
605+
if Stdlib.( = ) tag "P2" then (
606+
if Stdlib.( <> ) len 3 then
607+
Ppx_deriving_json_runtime.of_json_error
608+
"expected a JSON array of length 3";
609+
Some
610+
(`P2
611+
( int_of_json (Js.Array.unsafe_get array 1),
612+
string_of_json (Js.Array.unsafe_get array 2) )))
613+
else None
614+
else
615+
Ppx_deriving_json_runtime.of_json_error
616+
"expected a non empty JSON array with element being a \
617+
string"
618+
else
619+
Ppx_deriving_json_runtime.of_json_error
620+
"expected a non empty JSON array"
621+
else
622+
Ppx_deriving_json_runtime.of_json_error
623+
"expected a non empty JSON array"
624+
: Js.Json.t -> poly2 option)
625+
626+
and poly2_of_json =
627+
(fun x ->
628+
match poly2_of_json_poly x with
629+
| Some x -> x
630+
| None -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
631+
: Js.Json.t -> poly2)
632+
633+
let _ = poly2_of_json_poly
634+
and _ = poly2_of_json
635+
636+
[@@@ocaml.warning "-39-11-27"]
637+
638+
let rec poly2_to_json =
639+
(fun x ->
640+
match x with
641+
| `P2 (x_0, x_1) ->
642+
(Obj.magic
643+
[|
644+
string_to_json "P2"; int_to_json x_0; string_to_json x_1;
645+
|]
646+
: Js.Json.t)
647+
: poly2 -> Js.Json.t)
648+
649+
let _ = poly2_to_json
650+
end [@@ocaml.doc "@inline"] [@@merlin.hide]
651+
481652
$ cat <<"EOF" | run
482653
> type 'a c = [ `C of 'a ] [@@deriving json]
483654
> EOF

‎ppx/test/ppx_deriving_json_native.e2e.t

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -46,8 +46,12 @@
4646
JSON REPRINT: ["C",{"name":"cname"}]
4747
JSON DATA: ["A"]
4848
JSON REPRINT: ["A"]
49+
JSON DATA: ["S2", 42, "hello"]
50+
JSON REPRINT: ["S2",42,"hello"]
4951
JSON DATA: ["B", 42]
5052
JSON REPRINT: ["B",42]
53+
JSON DATA: ["P2", 42, "hello"]
54+
JSON REPRINT: ["P2",42,"hello"]
5155
JSON DATA: ["Fix",["Fix",["Fix",["A"]]]]
5256
JSON REPRINT: ["Fix",["Fix",["Fix",["A"]]]]
5357
JSON DATA: ["Fix",["Fix",["Fix",["A"]]]]

0 commit comments

Comments
 (0)