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.

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

ppx/browser/ppx_deriving_json_js.ml

@@ -190,10 +190,19 @@ 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 = ld.pld_name in
+          let k = Option.value ~default:k (ld_attr_json_key ld) in
+          let v = derive ld.pld_type x in
+          let v =
+            match ld_drop_default ld with
+            | `No -> v
+            | `Drop_option ->
+                [%expr
+                  match [%e x] with
+                  | None -> Js.Undefined.empty
+                  | 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]]]

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

ppx/native/ppx_deriving_json_native.ml

@@ -171,22 +171,43 @@ 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
     [%expr `List [%e elist ~loc es]]
 
   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
+                     | None -> [%e ebnds]
+                     | 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

ppx/test/example.ml

@@ -15,6 +15,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
@@ -44,6 +45,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);

ppx/test/ppx_deriving_json_js.e2e.t

@@ -74,3 +74,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}

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
+                      | None -> Js.Undefined.empty
+                      | 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]
+

ppx/test/ppx_deriving_json_native.e2e.t

@@ -65,3 +65,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}

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
+                  | None -> bnds__001_
+                  | 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]
+