json: support [@allow_extra_fields]

Used at record type declarations:

  type t = { ... } [@@json.allow_extra_fields]

and constructor declarations with record payloads

  type t = A of { ... } [@json.allow_extra_fields]

Supported only for native deriver now as browser deriver (for
performance) reasons allow this behaviour even without the annotation.

json/native/dune

@@ -39,7 +39,4 @@
    (run echo "let () = Ppxlib.Driver.standalone ()"))))
 
 (copy_files#
- (files ../../tools/ppx_deriving_tools.ml))
-
-(copy_files#
- (files ../../tools/ppx_deriving_tools.mli))
+ (files ../../tools/ppx_deriving_tools.{ml,mli}))

json/native/ppx_deriving_json_common.ml

@@ -31,6 +31,20 @@ let ld_attr_json_option =
        Ast_pattern.(pstr nil)
        ())
 
+let attr_json_allow_extra_fields ctx =
+  Attribute.declare "json.allow_extra_fields" ctx
+    Ast_pattern.(pstr nil)
+    ()
+
+let td_attr_json_allow_extra_fields =
+  Attribute.get
+    (attr_json_allow_extra_fields Attribute.Context.type_declaration)
+
+let cd_attr_json_allow_extra_fields =
+  Attribute.get
+    (attr_json_allow_extra_fields
+       Attribute.Context.constructor_declaration)
+
 let ld_attr_json_default =
   Attribute.get
     (Attribute.declare "json.default" Attribute.Context.label_declaration

json/native/ppx_deriving_json_native.ml

@@ -38,14 +38,17 @@ module Of_json = struct
     in
     pexp_tuple ~loc args
 
-  let build_record ~loc derive fs x make =
+  let build_record ~allow_extra_fields ~loc derive fs x make =
     with_refs ~loc "x" fs @@ fun ename ->
     let handle_field k v =
       let fail_case =
         [%pat? name]
-        --> [%expr
-              Ppx_deriving_json_runtime.of_json_error
-                (Stdlib.Printf.sprintf "unknown field: %s" name)]
+        -->
+        if allow_extra_fields then [%expr ()]
+        else
+          [%expr
+            Ppx_deriving_json_runtime.of_json_error
+              (Stdlib.Printf.sprintf "unknown field: %s" name)]
       in
       let cases =
         List.fold_left (List.rev fs) ~init:[ fail_case ]
@@ -114,10 +117,14 @@ module Of_json = struct
 
   let derive_of_record derive t x =
     let loc = t.rcd_loc in
+    let allow_extra_fields =
+      Option.is_some (td_attr_json_allow_extra_fields t.rcd_ctx)
+    in
     pexp_match ~loc x
       [
         [%pat? `Assoc fs]
-        --> build_record ~loc derive t.rcd_fields [%expr fs] Fun.id;
+        --> build_record ~allow_extra_fields ~loc derive t.rcd_fields
+              [%expr fs] Fun.id;
         [%pat? _]
         --> [%expr
               Ppx_deriving_json_runtime.of_json_error
@@ -145,9 +152,15 @@ module Of_json = struct
     | Vcs_record (n, t) ->
         let loc = n.loc in
         let n = Option.get_or ~default:n (vcs_attr_json_as t.rcd_ctx) in
+        let allow_extra_fields =
+          match t.rcd_ctx with
+          | Vcs_ctx_variant cd ->
+              Option.is_some (cd_attr_json_allow_extra_fields cd)
+          | Vcs_ctx_polyvariant _ -> false
+        in
         [%pat? `List [ `String [%p pstring ~loc:n.loc n.txt]; `Assoc fs ]]
-        --> build_record ~loc derive t.rcd_fields [%expr fs] (fun e ->
-                make (Some e))
+        --> build_record ~allow_extra_fields ~loc derive t.rcd_fields
+              [%expr fs] (fun e -> make (Some e))
 
   let deriving : Ppx_deriving_tools.deriving =
     deriving_of_match () ~name:"of_json"

json/test/example.ml

@@ -13,6 +13,8 @@ type polyrecur = [ `A | `Fix of polyrecur ] [@@deriving json]
 type evar = A | B [@json.as "b_aliased"] [@@deriving json]
 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]
 
 module Cases = struct 
   type json = Ppx_deriving_json_runtime.t
@@ -40,6 +42,8 @@ module Cases = struct
     C ({|{"k":42}|}, record_opt_of_json, record_opt_to_json, {k=Some 42});
     C ({|["A",1]|}, p2_of_json int_of_json string_of_json, p2_to_json int_to_json string_to_json, A 1);
     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});
   ]
   let run' ~json_of_string ~json_to_string (C (data, of_json, to_json, v)) =
     print_endline (Printf.sprintf "JSON    DATA: %s" data);

json/test/ppx_deriving_json_browser.e2e.t

@@ -70,3 +70,7 @@
   JSON REPRINT: ["A",1]
   JSON    DATA: ["B","ok"]
   JSON REPRINT: ["B","ok"]
+  JSON    DATA: {"a":1,"b":2}
+  JSON REPRINT: {"a":1}
+  JSON    DATA: ["A",{"a":1,"b":2}]
+  JSON REPRINT: ["A",{"a":1}]

json/test/ppx_deriving_json_browser.t

@@ -769,3 +769,125 @@
     let _ = p2_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]
 
+  $ cat <<"EOF" | run
+  > type allow_extra_fields = {a: int} [@@deriving json] [@@json.allow_extra_fields]
+  > EOF
+  type allow_extra_fields = { a : int }
+  [@@deriving json] [@@json.allow_extra_fields]
+  
+  include struct
+    let _ = fun (_ : allow_extra_fields) -> ()
+  
+    [@@@ocaml.warning "-39-11-27"]
+  
+    let rec allow_extra_fields_of_json =
+      (fun x ->
+         if
+           not
+             (Js.typeof x = "object"
+             && (not (Js.Array.isArray x))
+             && not ((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 > 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\"");
+         }
+        : Js.Json.t -> allow_extra_fields)
+
+    let _ = allow_extra_fields_of_json
+
+    [@@@ocaml.warning "-39-11-27"]
+
+    let rec allow_extra_fields_to_json =
+      (fun x ->
+         match x with
+         | { a = x_a } ->
+             (Obj.magic [%mel.obj { a = int_to_json x_a }] : Js.Json.t)
+        : allow_extra_fields -> Js.Json.t)
+
+    let _ = allow_extra_fields_to_json
+  end [@@ocaml.doc "@inline"] [@@merlin.hide]
+
+  $ cat <<"EOF" | run
+  > type allow_extra_fields2 = A of {a: int} [@json.allow_extra_fields] [@@deriving json]
+  > EOF
+  type allow_extra_fields2 = A of { a : int } [@json.allow_extra_fields]
+  [@@deriving json]
+
+  include struct
+    let _ = fun (_ : allow_extra_fields2) -> ()
+
+    [@@@ocaml.warning "-39-11-27"]
+
+    let rec allow_extra_fields2_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 len > 0 then
+             let tag = Js.Array.unsafe_get array 0 in
+             if Js.typeof tag = "string" then
+               let tag = (Obj.magic tag : string) in
+               if tag = "A" then (
+                 if len <> 2 then
+                   Ppx_deriving_json_runtime.of_json_error
+                     "expected a JSON array of length 2";
+                 let fs = Js.Array.unsafe_get array 1 in
+                 if
+                   not
+                     (Js.typeof fs = "object"
+                     && (not (Js.Array.isArray fs))
+                     && not ((Obj.magic fs : 'a Js.null) == Js.null))
+                 then
+                   Ppx_deriving_json_runtime.of_json_error
+                     "expected a JSON object";
+                 let fs =
+                   (Obj.magic fs : < a : Js.Json.t Js.undefined > Js.t)
+                 in
+                 A
+                   {
+                     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\"");
+                   })
+               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 -> allow_extra_fields2)
+  
+    let _ = allow_extra_fields2_of_json
+  
+    [@@@ocaml.warning "-39-11-27"]
+  
+    let rec allow_extra_fields2_to_json =
+      (fun x ->
+         match x with
+         | A { a = x_a } ->
+             (Obj.magic
+                [|
+                  string_to_json "A";
+                  (Obj.magic [%mel.obj { a = int_to_json x_a }] : Js.Json.t);
+                |]
+               : Js.Json.t)
+        : allow_extra_fields2 -> Js.Json.t)
+  
+    let _ = allow_extra_fields2_to_json
+  end [@@ocaml.doc "@inline"] [@@merlin.hide]
+

json/test/ppx_deriving_json_native.e2e.t

@@ -61,3 +61,7 @@
   JSON REPRINT: ["A",1]
   JSON    DATA: ["B","ok"]
   JSON REPRINT: ["B","ok"]
+  JSON    DATA: {"a":1,"b":2}
+  JSON REPRINT: {"a":1}
+  JSON    DATA: ["A",{"a":1,"b":2}]
+  JSON REPRINT: ["A",{"a":1}]

json/test/ppx_deriving_json_native.t

@@ -612,3 +612,104 @@
     let _ = p2_to_json
   end [@@ocaml.doc "@inline"] [@@merlin.hide]
 
+  $ cat <<"EOF" | run
+  > type allow_extra_fields = {a: int} [@@deriving json] [@@json.allow_extra_fields]
+  > EOF
+  type allow_extra_fields = { a : int }
+  [@@deriving json] [@@json.allow_extra_fields]
+
+  include struct
+    let _ = fun (_ : allow_extra_fields) -> ()
+
+    [@@@ocaml.warning "-39-11-27"]
+
+    let rec allow_extra_fields_of_json =
+      (fun x ->
+         match x with
+         | `Assoc fs ->
+             let x_a = ref Stdlib.Option.None in
+             let rec iter = function
+               | [] -> ()
+               | (n', v) :: fs ->
+                   (match n' with
+                   | "a" -> x_a := Stdlib.Option.Some (int_of_json v)
+                   | 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\"");
+             }
+         | _ ->
+             Ppx_deriving_json_runtime.of_json_error
+               "expected a JSON object"
+        : Yojson.Basic.t -> allow_extra_fields)
+
+    let _ = allow_extra_fields_of_json
+
+    [@@@ocaml.warning "-39-11-27"]
+
+    let rec allow_extra_fields_to_json =
+      (fun x ->
+         match x with { a = x_a } -> `Assoc [ "a", int_to_json x_a ]
+        : allow_extra_fields -> Yojson.Basic.t)
+
+    let _ = allow_extra_fields_to_json
+  end [@@ocaml.doc "@inline"] [@@merlin.hide]
+
+  $ cat <<"EOF" | run
+  > type allow_extra_fields2 = A of {a: int} [@json.allow_extra_fields] [@@deriving json]
+  > EOF
+  type allow_extra_fields2 = A of { a : int } [@json.allow_extra_fields]
+  [@@deriving json]
+
+  include struct
+    let _ = fun (_ : allow_extra_fields2) -> ()
+
+    [@@@ocaml.warning "-39-11-27"]
+
+    let rec allow_extra_fields2_of_json =
+      (fun x ->
+         match x with
+         | `List [ `String "A"; `Assoc fs ] ->
+             let x_a = ref Stdlib.Option.None in
+             let rec iter = function
+               | [] -> ()
+               | (n', v) :: fs ->
+                   (match n' with
+                   | "a" -> x_a := Stdlib.Option.Some (int_of_json v)
+                   | name -> ());
+                   iter fs
+             in
+             iter fs;
+             A
+               {
+                 a =
+                   (match Stdlib.( ! ) x_a with
+                   | Stdlib.Option.Some v -> v
+                   | Stdlib.Option.None ->
+                       Ppx_deriving_json_runtime.of_json_error
+                         "missing field \"a\"");
+               }
+         | _ -> Ppx_deriving_json_runtime.of_json_error "invalid JSON"
+        : Yojson.Basic.t -> allow_extra_fields2)
+
+    let _ = allow_extra_fields2_of_json
+
+    [@@@ocaml.warning "-39-11-27"]
+
+    let rec allow_extra_fields2_to_json =
+      (fun x ->
+         match x with
+         | A { a = x_a } ->
+             `List [ `String "A"; `Assoc [ "a", int_to_json x_a ] ]
+        : allow_extra_fields2 -> Yojson.Basic.t)
+
+    let _ = allow_extra_fields2_to_json
+  end [@@ocaml.doc "@inline"] [@@merlin.hide]
+