Add a feature to allow any json in a variant (#55)

Co-authored-by: Antonio Nuno Monteiro <anmonteiro@gmail.com>

Author: EmileTrotignon

ppx/browser/dune

@@ -28,7 +28,7 @@
    (run echo "let () = Ppxlib.Driver.standalone ()"))))
 
 (copy_files#
- (files ../common/ppx_deriving_json_common.ml))
+ (files ../native/common/ppx_deriving_json_common.ml))
 
 (copy_files#
- (files ../common/ppx_deriving_tools.{ml,mli}))
+ (files ../native/common/ppx_deriving_tools.{ml,mli}))

ppx/browser/ppx_deriving_json_js.ml

@@ -42,8 +42,9 @@ module Of_json = struct
                     [%expr
                       Ppx_deriving_json_runtime.of_json_error ~json:x
                         [%e
-                          estring ~loc (sprintf "expected field %S to be present" n.txt)]]]]
-      )
+                          estring ~loc
+                            (sprintf "expected field %S to be present"
+                               n.txt)]]]] )
     in
     [%expr
       let fs = (Obj.magic [%e x] : [%t build_js_type ~loc fs]) in
@@ -68,12 +69,19 @@ module Of_json = struct
         Ppx_deriving_json_runtime.of_json_msg_error
           [%e estring ~loc (sprintf "expected a JSON object")]]
 
-  let ensure_json_array_len ~loc n len x =
+  let ensure_json_array_len ~loc ~allow_any_constr ~else_ n len x =
     [%expr
       if Stdlib.( <> ) [%e len] [%e eint ~loc n] then
-        Ppx_deriving_json_runtime.of_json_msg_error ~json:[%e x]
-          [%e
-            estring ~loc (sprintf "expected a JSON array of length %i" n)]]
+        [%e
+          match allow_any_constr with
+          | Some allow_any_constr -> allow_any_constr x
+          | None ->
+              [%expr
+                Ppx_deriving_json_runtime.of_json_msg_error ~json:[%e x]
+                  [%e
+                    estring ~loc
+                      (sprintf "expected a JSON array of length %i" n)]]]
+      else [%e else_]]
 
   let derive_of_tuple derive t x =
     let loc = t.tpl_loc in
@@ -99,7 +107,7 @@ module Of_json = struct
       [%e ensure_json_object ~loc x];
       [%e build_record ~loc derive t.rcd_fields x Fun.id]]
 
-  let derive_of_variant _derive t body x =
+  let derive_of_variant _derive t ~allow_any_constr body x =
     let loc = t.vrt_loc in
     [%expr
       if Js.Array.isArray [%e x] then
@@ -111,52 +119,75 @@ module Of_json = struct
             let tag = (Obj.magic tag : string) in
             [%e body]
           else
-            Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
-              "expected a non empty JSON array with element being a \
-               string"
+            [%e
+              match allow_any_constr with
+              | Some allow_any_constr -> allow_any_constr x
+              | None ->
+                  [%expr
+                    Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
+                      "expected a non empty JSON array with element \
+                       being a string"]]
         else
-          Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
-            "expected a non empty JSON array"
+          [%e
+            match allow_any_constr with
+            | Some allow_any_constr -> allow_any_constr x
+            | None ->
+                [%expr
+                  Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
+                    "expected a non empty JSON array"]]
       else
-        Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
-          "expected a non empty JSON array"]
+        [%e
+          match allow_any_constr with
+          | Some allow_any_constr -> allow_any_constr x
+          | None ->
+              [%expr
+                Ppx_deriving_json_runtime.of_json_error ~json:[%e x]
+                  "expected a non empty JSON array"]]]
 
-  let derive_of_variant_case derive make c next =
+  let derive_of_variant_case derive make c ~allow_any_constr next =
     match c with
     | Vcs_record (n, r) ->
         let loc = n.loc in
         let n = Option.value ~default:n (vcs_attr_json_name r.rcd_ctx) in
         [%expr
-          if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then (
-            [%e ensure_json_array_len ~loc 2 [%expr len] [%expr x]];
-            let fs = Js.Array.unsafe_get array 1 in
-            [%e ensure_json_object ~loc [%expr fs]];
+          if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then
             [%e
-              build_record ~loc derive r.rcd_fields [%expr fs] (fun e ->
-                  make (Some e))])
+              ensure_json_array_len ~loc ~allow_any_constr 2 [%expr len]
+                [%expr x]
+                ~else_:
+                  [%expr
+                    let fs = Js.Array.unsafe_get array 1 in
+                    [%e ensure_json_object ~loc [%expr fs]];
+                    [%e
+                      build_record ~loc derive r.rcd_fields [%expr fs]
+                        (fun e -> make (Some e))]]]
           else [%e next]]
     | Vcs_tuple (n, t) ->
         let loc = n.loc in
         let n = Option.value ~default:n (vcs_attr_json_name t.tpl_ctx) in
         let arity = List.length t.tpl_types in
         [%expr
-          if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then (
-            [%e ensure_json_array_len ~loc (arity + 1) [%expr len] [%expr x]];
+          if Stdlib.( = ) tag [%e estring ~loc:n.loc n.txt] then
             [%e
-              if Stdlib.( = ) arity 0 then make None
-              else
-                make
-                  (Some
-                     (build_tuple ~loc derive 1 t.tpl_types [%expr array]))])
+              ensure_json_array_len ~loc ~allow_any_constr (arity + 1)
+                [%expr len] [%expr x]
+                ~else_:
+                  (if Stdlib.( = ) arity 0 then make None
+                   else
+                     make
+                       (Some
+                          (build_tuple ~loc derive 1 t.tpl_types
+                             [%expr array])))]
           else [%e next]]
 
+  let is_allow_any_constr vcs =
+    Ppx_deriving_json_common.vcs_attr_json_allow_any vcs
+
   let deriving : Ppx_deriving_tools.deriving =
     deriving_of () ~name:"of_json"
-      ~error:(fun ~loc ->
-        [%expr Ppx_deriving_json_runtime.of_json_msg_error "invalid JSON"])
       ~of_t:(fun ~loc -> [%type: Js.Json.t])
-      ~derive_of_tuple ~derive_of_record ~derive_of_variant
-      ~derive_of_variant_case
+      ~is_allow_any_constr ~derive_of_tuple ~derive_of_record
+      ~derive_of_variant ~derive_of_variant_case
 end
 
 module To_json = struct
@@ -194,13 +225,24 @@ module To_json = struct
     | Vcs_record (n, r) ->
         let loc = n.loc in
         let n = Option.value ~default:n (vcs_attr_json_name r.rcd_ctx) in
-        let tag = [%expr (Obj.magic [%e estring ~loc:n.loc n.txt]: Js.Json.t)] in
+        let tag =
+          [%expr (Obj.magic [%e estring ~loc:n.loc n.txt] : Js.Json.t)]
+        in
         let es = [ derive_of_record derive r es ] in
         as_json ~loc (pexp_array ~loc (tag :: es))
+    | Vcs_tuple (_n, t) when vcs_attr_json_allow_any t.tpl_ctx -> (
+        match es with
+        | [ x ] -> x
+        | es ->
+            failwith
+              (sprintf "expected a tuple of length 1, got %i"
+                 (List.length es)))
     | Vcs_tuple (n, t) ->
         let loc = n.loc in
         let n = Option.value ~default:n (vcs_attr_json_name t.tpl_ctx) in
-        let tag = [%expr (Obj.magic [%e estring ~loc:n.loc n.txt]: Js.Json.t)] in
+        let tag =
+          [%expr (Obj.magic [%e estring ~loc:n.loc n.txt] : Js.Json.t)]
+        in
         let es = List.map2 t.tpl_types es ~f:derive in
         as_json ~loc (pexp_array ~loc (tag :: es))
 

ppx/common/ppx_deriving_json_common.ml …ative/common/ppx_deriving_json_common.mlppx/common/ppx_deriving_json_common.ml renamed to ppx/native/common/ppx_deriving_json_common.ml ppx/common/ppx_deriving_json_common.ml renamed to ppx/native/common/ppx_deriving_json_common.ml

@@ -7,6 +7,7 @@ let get_of_variant_case ?mark_as_seen ~variant ~polyvariant = function
   | Vcs_ctx_variant ctx -> Attribute.get ?mark_as_seen variant ctx
   | Vcs_ctx_polyvariant ctx -> Attribute.get ?mark_as_seen polyvariant ctx
 
+
 let get_of_variant ?mark_as_seen ~variant ~polyvariant = function
   | Vrt_ctx_variant ctx -> Attribute.get ?mark_as_seen variant ctx
   | Vrt_ctx_polyvariant ctx -> Attribute.get ?mark_as_seen polyvariant ctx
@@ -23,6 +24,20 @@ let vcs_attr_json_name =
   let polyvariant = attr_json_name Attribute.Context.rtag in
   get_of_variant_case ~variant ~polyvariant
 
+
+
+let attr_json_allow_any ctx = Attribute.declare_flag "json.allow_any" ctx
+
+let vcs_attr_json_allow_any =
+  let variant =
+    attr_json_allow_any Attribute.Context.constructor_declaration
+  in
+  let polyvariant = attr_json_allow_any Attribute.Context.rtag in
+  fun ?mark_as_seen ctx ->
+    match get_of_variant_case ~variant ~polyvariant ?mark_as_seen ctx with
+    | None -> false
+    | Some () -> true
+
 let ld_attr_json_key =
   Attribute.get
     (Attribute.declare "json.key" Attribute.Context.label_declaration

ppx/common/ppx_deriving_tools.ml ppx/native/common/ppx_deriving_tools.mlppx/common/ppx_deriving_tools.ml renamed to ppx/native/common/ppx_deriving_tools.ml

@@ -364,8 +364,8 @@ module Conv = struct
 
   let repr_variant_cases cs = List.rev cs
 
-  let deriving_of ~name ~of_t ~error ~derive_of_tuple ~derive_of_record
-      ~derive_of_variant ~derive_of_variant_case () =
+  let deriving_of ~name ~of_t ~is_allow_any_constr ~derive_of_tuple
+      ~derive_of_record ~derive_of_variant ~derive_of_variant_case () =
     (object (self)
        inherit Schema.deriving1
        method name = name
@@ -384,9 +384,43 @@ module Conv = struct
        method! derive_of_variant td cs x =
          let loc = td.ptype_loc in
          let cs = repr_variant_cases cs in
+         let allow_any_constr =
+           cs
+           |> List.find_opt ~f:(fun cs ->
+                  is_allow_any_constr (Vcs_ctx_variant cs))
+           |> Option.map (fun cs e -> econstruct cs (Some e))
+         in
+         let cs =
+           List.filter
+             ~f:(fun cs -> not (is_allow_any_constr (Vcs_ctx_variant cs)))
+             cs
+         in
          let body, cases =
            List.fold_left cs
-             ~init:(error ~loc, [])
+             ~init:
+               (match allow_any_constr with
+               | Some allow_any_constr -> allow_any_constr x, []
+               | None ->
+                   let error_message =
+                     Printf.sprintf "expected %s"
+                       (cs
+                       |> List.map ~f:(fun c ->
+                              let name = c.pcd_name in
+                              match c.pcd_args with
+                              | Pcstr_record _fs ->
+                                  Printf.sprintf {|["%s", { _ }]|}
+                                    name.txt
+                              | Pcstr_tuple li ->
+                                  Printf.sprintf {|["%s"%s]|} name.txt
+                                    (li
+                                    |> List.map ~f:(fun _ -> ", _")
+                                    |> String.concat ~sep:""))
+                       |> String.concat ~sep:" or ")
+                   in
+                   ( [%expr
+                       Ppx_deriving_json_errors.of_json_error ~json:[%e x]
+                         [%e estring ~loc error_message]],
+                     [] ))
              ~f:(fun (next, cases) c ->
                let make (n : label loc) arg =
                  pexp_construct (map_loc lident n) ~loc:n.loc arg
@@ -403,7 +437,7 @@ module Conv = struct
                    in
                    let next =
                      derive_of_variant_case self#derive_of_core_type
-                       (make n) t next
+                       (make n) t ~allow_any_constr next
                    in
                    next, t :: cases
                | Pcstr_tuple ts ->
@@ -415,7 +449,7 @@ module Conv = struct
                    in
                    let next =
                      derive_of_variant_case self#derive_of_core_type
-                       (make n) case next
+                       (make n) case ~allow_any_constr next
                    in
                    next, case :: cases)
          in
@@ -426,20 +460,41 @@ module Conv = struct
              vrt_ctx = Vrt_ctx_variant td;
            }
          in
-         derive_of_variant self#derive_of_core_type t body x
+         derive_of_variant self#derive_of_core_type t ~allow_any_constr
+           body x
 
        method! derive_of_polyvariant t (cs : row_field list) x =
          let loc = t.ptyp_loc in
+         let allow_any_constr =
+           cs
+           |> List.find_opt ~f:(fun cs ->
+                  is_allow_any_constr (Vcs_ctx_polyvariant cs))
+           |> Option.map (fun cs ->
+                  match cs.prf_desc with
+                  | Rinherit _ ->
+                      failwith "[@allow_any] placed on inherit clause"
+                  | Rtag (n, _, _) ->
+                      fun e -> pexp_variant ~loc:n.loc n.txt (Some e))
+         in
+         let cs =
+           List.filter
+             ~f:(fun cs ->
+               not (is_allow_any_constr (Vcs_ctx_polyvariant cs)))
+             cs
+         in
          let cases = repr_polyvariant_cases cs in
          let body, cases =
            List.fold_left cases
              ~init:
-               ( [%expr
-                   raise
-                     (Ppx_deriving_json_runtime.Of_json_error
-                        (Ppx_deriving_json_runtime.Unexpected_variant
-                           "unexpected variant"))],
-                 [] )
+               (match allow_any_constr with
+               | Some allow_any_constr -> allow_any_constr x, []
+               | None ->
+                   ( [%expr
+                       raise
+                         (Ppx_deriving_json_runtime.Of_json_error
+                            (Ppx_deriving_json_runtime.Unexpected_variant
+                               "unexpected variant"))],
+                     [] ))
              ~f:(fun (next, cases) (c, r) ->
                let ctx = Vcs_ctx_polyvariant c in
                match r with
@@ -453,7 +508,7 @@ module Conv = struct
                    in
                    let next =
                      derive_of_variant_case self#derive_of_core_type make
-                       case next
+                       case ~allow_any_constr next
                    in
                    next, case :: cases
                | `Rinherit (n, ts) ->
@@ -480,12 +535,13 @@ module Conv = struct
              vrt_ctx = Vrt_ctx_polyvariant t;
            }
          in
-         derive_of_variant self#derive_of_core_type t body x
+         derive_of_variant self#derive_of_core_type t ~allow_any_constr
+           body x
      end
       :> deriving)
 
-  let deriving_of_match ~name ~of_t ~derive_of_tuple ~derive_of_record
-      ~derive_of_variant_case () =
+  let deriving_of_match ~name ~of_t ~cmp_sort_vcs ~derive_of_tuple
+      ~derive_of_record ~derive_of_variant_case () =
     (object (self)
        inherit Schema.deriving1
        method name = name
@@ -519,6 +575,14 @@ module Conv = struct
              |> String.concat ~sep:" or ")
          in
          let cs = repr_variant_cases cs in
+         let cs =
+           List.stable_sort
+             ~cmp:(fun cs1 cs2 ->
+               let vcs1 = Vcs_ctx_variant cs1
+               and vcs2 = Vcs_ctx_variant cs2 in
+               cmp_sort_vcs vcs1 vcs2)
+             cs
+         in
          let cases =
            List.fold_left cs
              ~init:
@@ -561,6 +625,14 @@ module Conv = struct
        method! derive_of_polyvariant t (cs : row_field list) x =
          let loc = t.ptyp_loc in
          let cases = repr_polyvariant_cases cs in
+         let cases =
+           List.stable_sort
+             ~cmp:(fun (cs1, _) (cs2, _) ->
+               let vcs1 = Vcs_ctx_polyvariant cs1
+               and vcs2 = Vcs_ctx_polyvariant cs2 in
+               cmp_sort_vcs vcs1 vcs2)
+             cases
+         in
          let ctors, inherits =
            List.partition_map cases ~f:(fun (c, r) ->
                let ctx = Vcs_ctx_polyvariant c in