From 97685aef52fe91fcfee003b2e38476b2851a98ba Mon Sep 17 00:00:00 2001 From: Andrey Popp <8mayday@gmail.com> Date: Fri, 6 Sep 2024 17:04:19 +0400 Subject: [PATCH] ppx: add [@drop_default] for record fields For now it only works for record fields annotated with `[@option]`, by dropping the field from JSON repr when the record value is `None`. What's missing is to also support `[@drop_default]` for fields annotated by `[@default X]` but we need to decide how to check for equality between the default value and the field value. One nice idea I had is to generate code like this: ```ocaml type t = { a : int [@default 0] [@drop_default] } ... let bnds = match [%equal int] a 0 with | true -> bnds | false -> ("a", a)::bnds in ... ``` but this means this ppx will depends on another ppx which provides `[%equal t]` deriver but sadly `ppx_compare` doesn't work with melange now. --- CHANGES.md | 3 + README.md | 16 +++ ppx/browser/dune | 6 +- ppx/browser/ppx_deriving_json_js.ml | 19 ++- ppx/native/ppx_deriving_json_common.ml | 16 +++ ppx/native/ppx_deriving_json_native.ml | 38 ++++-- ppx/test/example.ml | 3 + ppx/test/ppx_deriving_json_js.e2e.t | 4 + ppx/test/ppx_deriving_json_js.t | 71 ++++++++++++ ppx/test/ppx_deriving_json_js_errors.t | 6 + ppx/test/ppx_deriving_json_native.e2e.t | 4 + ppx/test/ppx_deriving_json_native.t | 129 +++++++++++++++++++-- ppx/test/ppx_deriving_json_native_errors.t | 6 + 13 files changed, 295 insertions(+), 26 deletions(-) create mode 100644 ppx/test/ppx_deriving_json_js_errors.t create mode 100644 ppx/test/ppx_deriving_json_native_errors.t diff --git a/CHANGES.md b/CHANGES.md index 6096cbb..553a340 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -11,6 +11,9 @@ ([#11](https://github.com/melange-community/melange-json/pull/11)) - Add `melange-json-native` package ([#12](https://github.com/melange-community/melange-json/pull/12)) +- Add `[@drop_default]` attribute to drop `None` values from JSON + representation + ([#17](https://github.com/melange-community/melange-json/pull/17)) ## 1.2.0 (2024-08-16) diff --git a/README.md b/README.md index 47eec17..4a3832f 100644 --- a/README.md +++ b/README.md @@ -252,6 +252,22 @@ let t = of_json (Json.parseOrRaise {|{"a": 42}|}) (* t = { a = 42; b = None; } *) ``` +#### `[@json.drop_default]`: drop default values from JSON + +When a field has `[@option]` attribute one can use `[@json.drop_default]` +attribute to make the generated `to_json` function to drop the field if it's +value is `None`: + +```ocaml +type t = { + a: int; + b: string option [@json.option] [@json.drop_default]; +} [@@deriving to_json] + +let t = to_json { a = 1; b = None; } +(* {"a": 1} *) +``` + #### `[@json.key "S"]`: customizing keys for record fields You can specify custom keys for record fields using the `[@json.key E]` diff --git a/ppx/browser/dune b/ppx/browser/dune index e75dcf8..80d1c95 100644 --- a/ppx/browser/dune +++ b/ppx/browser/dune @@ -1,11 +1,7 @@ (library (public_name melange-json.ppx) (name ppx_deriving_json_js) - (modules - :standard - \ - ppx_deriving_json_runtime - ppx_deriving_json_js_test) + (modules :standard \ ppx_deriving_json_runtime ppx_deriving_json_js_test) (libraries ppxlib) (ppx_runtime_libraries melange-json.ppx-runtime) (preprocess diff --git a/ppx/browser/ppx_deriving_json_js.ml b/ppx/browser/ppx_deriving_json_js.ml index 91e437d..4be0ee7 100644 --- a/ppx/browser/ppx_deriving_json_js.ml +++ b/ppx/browser/ppx_deriving_json_js.ml @@ -190,10 +190,21 @@ module To_json = struct let loc = t.rcd_loc in let fs = List.map2 t.rcd_fields es ~f:(fun ld x -> - let n = ld.pld_name in - let n = Option.value ~default:n (ld_attr_json_key ld) in - let this = derive ld.pld_type x in - map_loc lident n, this) + let k = + let k = ld.pld_name in + Option.value ~default:k (ld_attr_json_key ld) + in + let v = + let v = derive ld.pld_type x in + match ld_drop_default ld with + | `No -> v + | `Drop_option -> + [%expr + match [%e x] with + | Stdlib.Option.None -> Js.Undefined.empty + | Stdlib.Option.Some _ -> Js.Undefined.return [%e v]] + in + map_loc lident k, v) in let record = pexp_record ~loc fs None in as_json ~loc [%expr [%mel.obj [%e record]]] diff --git a/ppx/native/ppx_deriving_json_common.ml b/ppx/native/ppx_deriving_json_common.ml index 6466849..08f732d 100644 --- a/ppx/native/ppx_deriving_json_common.ml +++ b/ppx/native/ppx_deriving_json_common.ml @@ -51,6 +51,13 @@ let ld_attr_json_default = Ast_pattern.(single_expr_payload __) (fun x -> x)) +let ld_attr_json_drop_default = + Attribute.get + (Attribute.declare "json.drop_default" + Attribute.Context.label_declaration + Ast_pattern.(pstr nil) + ()) + let ld_attr_default ld = match ld_attr_json_default ld with | Some e -> Some e @@ -60,3 +67,12 @@ let ld_attr_default ld = let loc = ld.pld_loc in Some [%expr Stdlib.Option.None] | None -> None) + +let ld_drop_default ld = + let loc = ld.pld_loc in + match ld_attr_json_drop_default ld, ld_attr_json_option ld with + | Some (), None -> + Ppx_deriving_tools.error ~loc + "found [@drop_default] attribute without [@option]" + | Some (), Some () -> `Drop_option + | None, _ -> `No diff --git a/ppx/native/ppx_deriving_json_native.ml b/ppx/native/ppx_deriving_json_native.ml index 44cd069..33d3d6f 100644 --- a/ppx/native/ppx_deriving_json_native.ml +++ b/ppx/native/ppx_deriving_json_native.ml @@ -171,6 +171,10 @@ module Of_json = struct end module To_json = struct + let gen_exp_pat ~loc prefix = + let n = gen_symbol ~prefix () in + evar ~loc n, pvar ~loc n + let derive_of_tuple derive t es = let loc = t.tpl_loc in let es = List.map2 t.tpl_types es ~f:derive in @@ -178,15 +182,33 @@ module To_json = struct let derive_of_record derive t es = let loc = t.rcd_loc in - let es = - List.map2 t.rcd_fields es ~f:(fun ld x -> - let key = - Option.value ~default:ld.pld_name (ld_attr_json_key ld) - in - [%expr - [%e estring ~loc:key.loc key.txt], [%e derive ld.pld_type x]]) + let ebnds, pbnds = gen_exp_pat ~loc "bnds" in + let e = + List.combine t.rcd_fields es + |> List.fold_left ~init:ebnds ~f:(fun acc (ld, x) -> + let key = + Option.value ~default:ld.pld_name (ld_attr_json_key ld) + in + let k = estring ~loc:key.loc key.txt in + let v = derive ld.pld_type x in + let ebnds = + match ld_drop_default ld with + | `No -> [%expr ([%e k], [%e v]) :: [%e ebnds]] + | `Drop_option -> + [%expr + match [%e x] with + | Stdlib.Option.None -> [%e ebnds] + | Stdlib.Option.Some _ -> + ([%e k], [%e v]) :: [%e ebnds]] + in + [%expr + let [%p pbnds] = [%e ebnds] in + [%e acc]]) in - [%expr `Assoc [%e elist ~loc es]] + [%expr + `Assoc + (let [%p pbnds] = [] in + [%e e])] let derive_of_variant_case derive vcs es = match vcs with diff --git a/ppx/test/example.ml b/ppx/test/example.ml index 750b70c..ac8c3ed 100644 --- a/ppx/test/example.ml +++ b/ppx/test/example.ml @@ -16,6 +16,7 @@ type epoly = [ `a [@json.as "A_aliased"] | `b ] [@@deriving json] type ('a, 'b) p2 = A of 'a | B of 'b [@@deriving json] type allow_extra_fields = {a: int} [@@deriving json] [@@json.allow_extra_fields] type allow_extra_fields2 = A of {a: int} [@json.allow_extra_fields] [@@deriving json] +type drop_default_option = { a: int; b_opt: int option; [@option] [@json.drop_default] } [@@deriving json] module Cases = struct type json = Ppx_deriving_json_runtime.t @@ -47,6 +48,8 @@ module Cases = struct C ({|["B","ok"]|}, p2_of_json int_of_json string_of_json, p2_to_json int_to_json string_to_json, B "ok"); C ({|{"a":1,"b":2}|}, allow_extra_fields_of_json, allow_extra_fields_to_json, {a=1}); C ({|["A",{"a":1,"b":2}]|}, allow_extra_fields2_of_json, allow_extra_fields2_to_json, A {a=1}); + C ({|{"a":1}|}, drop_default_option_of_json, drop_default_option_to_json, {a=1; b_opt=None}); + C ({|{"a":1,"b_opt":2}|}, drop_default_option_of_json, drop_default_option_to_json, {a=1; b_opt=Some 2}); ] let run' ~json_of_string ~json_to_string (C (data, of_json, to_json, v)) = print_endline (Printf.sprintf "JSON DATA: %s" data); diff --git a/ppx/test/ppx_deriving_json_js.e2e.t b/ppx/test/ppx_deriving_json_js.e2e.t index 5f93fed..100da75 100644 --- a/ppx/test/ppx_deriving_json_js.e2e.t +++ b/ppx/test/ppx_deriving_json_js.e2e.t @@ -78,3 +78,7 @@ JSON REPRINT: {"a":1} JSON DATA: ["A",{"a":1,"b":2}] JSON REPRINT: ["A",{"a":1}] + JSON DATA: {"a":1} + JSON REPRINT: {"a":1} + JSON DATA: {"a":1,"b_opt":2} + JSON REPRINT: {"a":1,"b_opt":2} diff --git a/ppx/test/ppx_deriving_json_js.t b/ppx/test/ppx_deriving_json_js.t index 066269c..f258575 100644 --- a/ppx/test/ppx_deriving_json_js.t +++ b/ppx/test/ppx_deriving_json_js.t @@ -915,3 +915,74 @@ let _ = allow_extra_fields2_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] + $ cat <<"EOF" | run + > type drop_default_option = { a: int; b_opt: int option; [@option] [@json.drop_default] } [@@deriving json] + > EOF + type drop_default_option = { + a : int; + b_opt : int option; [@option] [@json.drop_default] + } + [@@deriving json] + + include struct + let _ = fun (_ : drop_default_option) -> () + + [@@@ocaml.warning "-39-11-27"] + + let rec drop_default_option_of_json = + (fun x -> + if + Stdlib.not + (Stdlib.( && ) + (Stdlib.( = ) (Js.typeof x) "object") + (Stdlib.( && ) + (Stdlib.not (Js.Array.isArray x)) + (Stdlib.not + (Stdlib.( == ) (Obj.magic x : 'a Js.null) Js.null)))) + then + Ppx_deriving_json_runtime.of_json_error "expected a JSON object"; + let fs = + (Obj.magic x + : < a : Js.Json.t Js.undefined + ; b_opt : Js.Json.t Js.undefined > + Js.t) + in + { + a = + (match Js.Undefined.toOption fs##a with + | Stdlib.Option.Some v -> int_of_json v + | Stdlib.Option.None -> + Ppx_deriving_json_runtime.of_json_error + "missing field \"a\""); + b_opt = + (match Js.Undefined.toOption fs##b_opt with + | Stdlib.Option.Some v -> (option_of_json int_of_json) v + | Stdlib.Option.None -> Stdlib.Option.None); + } + : Js.Json.t -> drop_default_option) + + let _ = drop_default_option_of_json + + [@@@ocaml.warning "-39-11-27"] + + let rec drop_default_option_to_json = + (fun x -> + match x with + | { a = x_a; b_opt = x_b_opt } -> + (Obj.magic + [%mel.obj + { + a = int_to_json x_a; + b_opt = + (match x_b_opt with + | Stdlib.Option.None -> Js.Undefined.empty + | Stdlib.Option.Some _ -> + Js.Undefined.return + ((option_to_json int_to_json) x_b_opt)); + }] + : Js.Json.t) + : drop_default_option -> Js.Json.t) + + let _ = drop_default_option_to_json + end [@@ocaml.doc "@inline"] [@@merlin.hide] + diff --git a/ppx/test/ppx_deriving_json_js_errors.t b/ppx/test/ppx_deriving_json_js_errors.t new file mode 100644 index 0000000..76f7fdb --- /dev/null +++ b/ppx/test/ppx_deriving_json_js_errors.t @@ -0,0 +1,6 @@ + + + $ echo 'type t = { a: int option; [@drop_default] } [@@deriving json]' | ../browser/ppx_deriving_json_js_test.exe -impl - + Fatal error: exception Ppx_deriving_json_js__Ppx_deriving_tools.Error(_, "found [@drop_default] attribute without [@option]") + [2] + diff --git a/ppx/test/ppx_deriving_json_native.e2e.t b/ppx/test/ppx_deriving_json_native.e2e.t index 10ab746..76b4fa8 100644 --- a/ppx/test/ppx_deriving_json_native.e2e.t +++ b/ppx/test/ppx_deriving_json_native.e2e.t @@ -70,3 +70,7 @@ JSON REPRINT: {"a":1} JSON DATA: ["A",{"a":1,"b":2}] JSON REPRINT: ["A",{"a":1}] + JSON DATA: {"a":1} + JSON REPRINT: {"a":1} + JSON DATA: {"a":1,"b_opt":2} + JSON REPRINT: {"a":1,"b_opt":2} diff --git a/ppx/test/ppx_deriving_json_native.t b/ppx/test/ppx_deriving_json_native.t index 200f9e2..7cd3980 100644 --- a/ppx/test/ppx_deriving_json_native.t +++ b/ppx/test/ppx_deriving_json_native.t @@ -154,7 +154,12 @@ match x with | { name = x_name; age = x_age } -> `Assoc - [ "name", string_to_json x_name; "age", int_to_json x_age ] + (let bnds__001_ = [] in + let bnds__001_ = ("age", int_to_json x_age) :: bnds__001_ in + let bnds__001_ = + ("name", string_to_json x_name) :: bnds__001_ + in + bnds__001_) : record -> Yojson.Basic.t) let _ = record_to_json @@ -219,10 +224,14 @@ match x with | { name = x_name; age = x_age } -> `Assoc - [ - "my_name", string_to_json x_name; - "my_age", int_to_json x_age; - ] + (let bnds__001_ = [] in + let bnds__001_ = + ("my_age", int_to_json x_age) :: bnds__001_ + in + let bnds__001_ = + ("my_name", string_to_json x_name) :: bnds__001_ + in + bnds__001_) : record_aliased -> Yojson.Basic.t) let _ = record_aliased_to_json @@ -274,7 +283,13 @@ let rec record_opt_to_json = (fun x -> match x with - | { k = x_k } -> `Assoc [ "k", (option_to_json int_to_json) x_k ] + | { k = x_k } -> + `Assoc + (let bnds__001_ = [] in + let bnds__001_ = + ("k", (option_to_json int_to_json) x_k) :: bnds__001_ + in + bnds__001_) : record_opt -> Yojson.Basic.t) let _ = record_opt_to_json @@ -331,7 +346,16 @@ | A -> `List [ `String "A" ] | B x_0 -> `List [ `String "B"; int_to_json x_0 ] | C { name = x_name } -> - `List [ `String "C"; `Assoc [ "name", string_to_json x_name ] ] + `List + [ + `String "C"; + `Assoc + (let bnds__001_ = [] in + let bnds__001_ = + ("name", string_to_json x_name) :: bnds__001_ + in + bnds__001_); + ] : sum -> Yojson.Basic.t) let _ = sum_to_json @@ -656,7 +680,12 @@ let rec allow_extra_fields_to_json = (fun x -> - match x with { a = x_a } -> `Assoc [ "a", int_to_json x_a ] + match x with + | { a = x_a } -> + `Assoc + (let bnds__001_ = [] in + let bnds__001_ = ("a", int_to_json x_a) :: bnds__001_ in + bnds__001_) : allow_extra_fields -> Yojson.Basic.t) let _ = allow_extra_fields_to_json @@ -707,9 +736,91 @@ (fun x -> match x with | A { a = x_a } -> - `List [ `String "A"; `Assoc [ "a", int_to_json x_a ] ] + `List + [ + `String "A"; + `Assoc + (let bnds__001_ = [] in + let bnds__001_ = ("a", int_to_json x_a) :: bnds__001_ in + bnds__001_); + ] : allow_extra_fields2 -> Yojson.Basic.t) let _ = allow_extra_fields2_to_json end [@@ocaml.doc "@inline"] [@@merlin.hide] + $ cat <<"EOF" | run + > type drop_default_option = { a: int; b_opt: int option; [@option] [@json.drop_default] } [@@deriving json] + > EOF + type drop_default_option = { + a : int; + b_opt : int option; [@option] [@json.drop_default] + } + [@@deriving json] + + include struct + let _ = fun (_ : drop_default_option) -> () + + [@@@ocaml.warning "-39-11-27"] + + let rec drop_default_option_of_json = + (fun x -> + match x with + | `Assoc fs -> + let x_a = ref Stdlib.Option.None in + let x_b_opt = ref (Stdlib.Option.Some Stdlib.Option.None) in + let rec iter = function + | [] -> () + | (n', v) :: fs -> + (match n' with + | "a" -> x_a := Stdlib.Option.Some (int_of_json v) + | "b_opt" -> + x_b_opt := + Stdlib.Option.Some ((option_of_json int_of_json) v) + | name -> + Ppx_deriving_json_runtime.of_json_error + (Stdlib.Printf.sprintf "unknown field: %s" name)); + iter fs + in + iter fs; + { + a = + (match Stdlib.( ! ) x_a with + | Stdlib.Option.Some v -> v + | Stdlib.Option.None -> + Ppx_deriving_json_runtime.of_json_error + "missing field \"a\""); + b_opt = + (match Stdlib.( ! ) x_b_opt with + | Stdlib.Option.Some v -> v + | Stdlib.Option.None -> Stdlib.Option.None); + } + | _ -> + Ppx_deriving_json_runtime.of_json_error + "expected a JSON object" + : Yojson.Basic.t -> drop_default_option) + + let _ = drop_default_option_of_json + + [@@@ocaml.warning "-39-11-27"] + + let rec drop_default_option_to_json = + (fun x -> + match x with + | { a = x_a; b_opt = x_b_opt } -> + `Assoc + (let bnds__001_ = [] in + let bnds__001_ = + match x_b_opt with + | Stdlib.Option.None -> bnds__001_ + | Stdlib.Option.Some _ -> + ("b_opt", (option_to_json int_to_json) x_b_opt) + :: bnds__001_ + in + let bnds__001_ = ("a", int_to_json x_a) :: bnds__001_ in + bnds__001_) + : drop_default_option -> Yojson.Basic.t) + + let _ = drop_default_option_to_json + end [@@ocaml.doc "@inline"] [@@merlin.hide] + diff --git a/ppx/test/ppx_deriving_json_native_errors.t b/ppx/test/ppx_deriving_json_native_errors.t new file mode 100644 index 0000000..d0cdfa8 --- /dev/null +++ b/ppx/test/ppx_deriving_json_native_errors.t @@ -0,0 +1,6 @@ + + + $ echo 'type t = { a: int option; [@drop_default] } [@@deriving json]' | ../native/ppx_deriving_json_native_test.exe -impl - + Fatal error: exception Ppx_deriving_json_native__Ppx_deriving_tools.Error(_, "found [@drop_default] attribute without [@option]") + [2] +