ppx: allow dropping arbitrary values with [@drop_default]

Author: zazedd

CHANGES.md

@@ -2,6 +2,10 @@
 
 - Support `Ptype_open`, e.g. `type u = X.(x) [@@deriving json]`
   ([#60](https://github.com/melange-community/melange-json/pull/60))
+- Add support for `[@drop_default]` to drop arbitrary values provided
+  with `[@default]` from JSON representation, with option to provide
+  function used for equality check
+  ([#77](https://github.com/melange-community/melange-json/pull/77))
 
 ## 2.0.0 (2025-03-11)
 

README.md

@@ -281,20 +281,79 @@ let t = of_json (Melange_json.of_string {|{"a": 42}|})
 
 #### `[@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`:
+When a field has either `[@json.option]` or `[@json.default]` attributes, you can use the `[@json.drop_default]` 
+attribute to make the generated `to_json` function drop the field
+from the JSON output when its value matches the default.
+
+In its flag form (no argument), `[@json.drop_default]` checks for `None` when used with
+`[@json.option]`, and requires an `equal_<type>` function in scope when used with
+`[@json.default]`:
 
 ```ocaml
+let equal_string = String.equal
+
 type t = {
   a: int;
   b: string option [@json.option] [@json.drop_default];
+  c: string [@json.default "-"] [@json.drop_default];
 } [@@deriving to_json]
 
-let t = to_json { a = 1; b = None; }
+let t = to_json { a = 1; b = None; c = "-"; }
 (* {"a": 1} *)
 ```
 
+For parameterized types, the equal function takes the inner type's `equal_<type>`
+function as an argument, so a field of type `int list` generates a call to `equal_list equal_int`,
+`int list list` generates `equal_list (equal_list equal_int)`, and so on.
+
+```ocaml
+let equal_int = Int.equal
+let rec equal_list equal_a a b =
+  match a, b with
+  | [], [] -> true
+  | x :: xs, y :: ys -> equal_a x y && equal_list equal_a xs ys
+  | _ -> false
+
+type t = {
+  items: int list [@json.default []] [@json.drop_default];
+} [@@deriving to_json]
+
+let json = to_json { items = [] }
+(* {} *)
+```
+
+You can also provide a custom comparison function of type `'a -> 'a -> bool` directly:
+
+```ocaml
+type t = {
+  f: float [@json.default 0.0] [@json.drop_default Float.equal];
+} [@@deriving to_json]
+
+let json = to_json { f = 0.0 }
+(* {} *)
+```
+
+#### `[@json.drop_default_if_json_equal]`: drop defaults by comparing JSON output
+
+A (mutually exclusive) alternative to `[@json.drop_default]` that compares values at the JSON level
+rather than requiring an `equal_<type>` function. This is useful for complex or
+nested types where you already have `to_json` but don't want to derive or write
+equality functions:
+
+```ocaml
+type color = { r: int; g: int; b: int } [@@deriving json]
+
+type style = {
+  font_size: int;
+  background: color
+    [@json.default { r = 255; g = 255; b = 255 }]
+    [@json.drop_default_if_json_equal];
+} [@@deriving json]
+
+let json = to_json { font_size = 12; background = { r = 255; g = 255; b = 255 } }
+(* {"font_size": 12} *)
+```
+
 #### `[@json.key "S"]`: customizing keys for record fields
 
 You can specify custom keys for record fields using the `[@json.key E]`

ppx/browser/ppx_deriving_json_js.ml

@@ -214,6 +214,16 @@ module To_json = struct
                   match [%e x] with
                   | Stdlib.Option.None -> Js.Undefined.empty
                   | Stdlib.Option.Some _ -> Js.Undefined.return [%e v]]
+            | `Drop_default (cmp, def) ->
+                [%expr
+                  if [%e cmp] [%e x] [%e def] then Js.Undefined.empty
+                  else Js.Undefined.return [%e v]]
+            | `Drop_default_if_json_equal def ->
+                [%expr
+                  let json = [%e v] in
+                  if Melange_json.equal json [%e derive ld.pld_type def]
+                  then Js.Undefined.empty
+                  else Js.Undefined.return json]
           in
           map_loc lident k, v)
     in

ppx/native/common/ppx_deriving_json_common.ml

@@ -71,8 +71,16 @@ let ld_attr_json_drop_default =
   Attribute.get
     (Attribute.declare "json.drop_default"
        Attribute.Context.label_declaration
-       Ast_pattern.(pstr nil)
-       ())
+       Ast_pattern.(
+         pstr (map0 ~f:None nil) (* flag form *)
+         ||| single_expr_payload (map1 ~f:Option.some __)
+         (* comparison function *))
+       (fun x -> x))
+
+let ld_attr_json_drop_default_if_json_equal =
+  Attribute.get
+    (Attribute.declare_flag "json.drop_default_if_json_equal"
+       Attribute.Context.label_declaration)
 
 let ld_attr_default ld =
   match ld_attr_json_default ld with
@@ -84,14 +92,75 @@ let ld_attr_default ld =
           Some [%expr Stdlib.Option.None]
       | None -> None)
 
+let rec equal_of_core_type ~loc ct =
+  match ct.ptyp_desc with
+  | Ptyp_constr ({ txt = Lident name; _ }, args) ->
+      let fn = pexp_ident ~loc { loc; txt = lident ("equal_" ^ name) } in
+      List.fold_left (List.rev args) ~init:fn ~f:(fun acc arg ->
+          pexp_apply ~loc acc [ Nolabel, equal_of_core_type ~loc arg ])
+  | Ptyp_constr ({ txt = Ldot (prefix, name); _ }, args) ->
+      let name = if name = "t" then "equal" else "equal_" ^ name in
+      let fn = pexp_ident ~loc { loc; txt = Ldot (prefix, name) } in
+      List.fold_left (List.rev args) ~init:fn ~f:(fun acc arg ->
+          pexp_apply ~loc acc [ Nolabel, equal_of_core_type ~loc arg ])
+  | Ptyp_var name ->
+      pexp_ident ~loc { loc; txt = lident ("equal_" ^ name) }
+  | _ ->
+      Location.raise_errorf ~loc
+        "[@drop_default]: cannot derive equal for this type, provide a \
+         comparison function via [@json.drop_default f]"
+
 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 ->
+  let drop_default = ld_attr_json_drop_default ld in
+  let drop_json_equal = ld_attr_json_drop_default_if_json_equal ld in
+  match drop_default, drop_json_equal with
+  | Some _, Some () ->
       Location.raise_errorf ~loc
-        "found [@drop_default] attribute without [@option]"
-  | Some (), Some () -> `Drop_option
-  | None, _ -> `No
+        "[@drop_default] and [@drop_default_if_json_equal] are mutually \
+         exclusive"
+  | None, None -> `No
+  | None, Some () -> begin
+      match ld_attr_json_option ld, ld_attr_json_default ld with
+      | None, Some def -> `Drop_default_if_json_equal def
+      | Some (), None ->
+          Location.raise_errorf ~loc
+            "[@drop_default_if_json_equal] cannot be used with \
+             [@option]. Use [@drop_default] instead."
+      | Some (), Some _ ->
+          Location.raise_errorf ~loc
+            "[@drop_default_if_json_equal] cannot be used with both \
+             [@option] and [@default]. Use [@json.default] only."
+      | None, None ->
+          Location.raise_errorf ~loc
+            "[@drop_default_if_json_equal] requires [@json.default]"
+    end
+  | Some None, None -> begin
+      (* flag form: [@json.drop_default] *)
+      match ld_attr_json_option ld, ld_attr_json_default ld with
+      | Some (), None -> `Drop_option
+      | None, Some def ->
+          let cmp = equal_of_core_type ~loc ld.pld_type in
+          `Drop_default (cmp, def)
+      | Some (), Some _ ->
+          Location.raise_errorf ~loc
+            "[@drop_default] cannot be used with both [@option] and \
+             [@default]"
+      | None, None ->
+          Location.raise_errorf ~loc
+            "[@drop_default] requires either [@option] or [@default]"
+    end
+  | Some (Some cmp), None -> begin
+      (* expression form: [@json.drop_default expr] *)
+      match ld_attr_json_option ld, ld_attr_json_default ld with
+      | None, Some def -> `Drop_default (cmp, def)
+      | Some (), _ ->
+          Location.raise_errorf ~loc
+            "[@drop_default expr] cannot be used with [@option]"
+      | None, None ->
+          Location.raise_errorf ~loc
+            "[@drop_default expr] requires [@default]"
+    end
 
 let expand_via ~what ~through make ~ctxt (rec_flag, tds) =
   let loc = Expansion_context.Deriver.derived_item_loc ctxt in

ppx/native/ppx_deriving_json_native.ml

@@ -208,6 +208,16 @@ module To_json = struct
                   match [%e x] with
                   | Stdlib.Option.None -> [%e ebnds]
                   | Stdlib.Option.Some _ -> ([%e k], [%e v]) :: [%e ebnds]]
+            | `Drop_default (cmp, def) ->
+                [%expr
+                  if [%e cmp] [%e x] [%e def] then [%e ebnds]
+                  else ([%e k], [%e v]) :: [%e ebnds]]
+            | `Drop_default_if_json_equal def ->
+                [%expr
+                  let json = [%e v] in
+                  if Melange_json.equal json [%e derive ld.pld_type def]
+                  then [%e ebnds]
+                  else ([%e k], json) :: [%e ebnds]]
           in
           [%expr
             let [%p pbnds] = [%e ebnds] in

ppx/test/dune

@@ -13,4 +13,3 @@
  (applies_to ptype_open)
  (enabled_if
   (>= %{ocaml_version} 5.2.0)))
-