ppx: add [@json.catch_all] for forward-compatible string enums

CHANGES.md

@@ -1,5 +1,19 @@
 ## Unreleased
 
+- Library: Add `Melange_json.unknown_variant_case`, a record type with
+  fields `tag : string` and `payload : Melange_json.t list option`,
+  meant to be referenced as the argument of a catch-all constructor (see
+  next entry). Companion JSON-schema literal
+  `Melange_json.unknown_variant_case_jsonschema` plugs into
+  `ppx_deriving_jsonschema`.
+- PPX: Add `[@json.catch_all]` attribute, marking a constructor as the
+  catch-all for any unrecognised string tag. The constructor's argument
+  is `Melange_json.unknown_variant_case`; `payload` distinguishes bare
+  strings (`None`) from array forms (`Some xs`), preserving the wire
+  shape for round-trip-faithful decoding/encoding even when a future
+  producer adds payload-bearing variants. Works on both classic variants
+  and polymorphic variants. Pairs naturally with
+  `[@@json.compact_variants]`.
 - PPX: Add `[@@json.compact_variants]` attribute for variant and polyvariant
   types. Encodes constructors without arguments as plain JSON strings and
   constructors with arguments as JSON arrays `["ConstructorName", arg1, ...]`.

README.md

@@ -424,6 +424,47 @@ This also works for polyvariant types:
 type t = [`A | `B of int] [@@deriving json] [@@json.compact_variants]
 ```
 
+#### `[@json.catch_all]`: catch-all constructor for unknown string tags
+
+The `[@json.catch_all]` attribute marks a constructor as the catch-all for any
+unrecognised string tag. The constructor's argument is the library type
+`Melange_json.unknown_variant_case`, a record with fields `tag : string` and
+`payload : Melange_json.t list option`. The decoder routes bare unknown
+strings *and* unknown array variants — including their payload — into this
+constructor; the encoder re-emits the exact wire shape, so decoding/encoding
+round-trips.
+
+Pairs naturally with `[@@json.compact_variants]` so the known cases are also
+bare strings.
+
+```ocaml
+type evt =
+  | Login [@json.name "login"]
+  | Click of int [@json.name "click"]
+  | Unknown of Melange_json.unknown_variant_case [@json.catch_all]
+[@@deriving json] [@@json.compact_variants]
+```
+
+The same syntax works for polymorphic variants:
+
+```ocaml
+type evt = [
+  | `Login [@json.name "login"]
+  | `Click of int [@json.name "click"]
+  | `Unknown of Melange_json.unknown_variant_case [@json.catch_all]
+] [@@deriving json] [@@json.compact_variants]
+```
+
+##### Wire shape mapping
+
+`payload` distinguishes the wire shape so the value round-trips faithfully:
+
+| Wire JSON               | Decoded                                                   | Re-encodes as          |
+|-------------------------|-----------------------------------------------------------|------------------------|
+| `"future_tag"`          | `{ tag = "future_tag"; payload = None }`                  | `"future_tag"`         |
+| `["future_tag"]`        | `{ tag = "future_tag"; payload = Some [] }`               | `["future_tag"]`       |
+| `["future_tag", 42]`    | `{ tag = "future_tag"; payload = Some [`Int 42] }`        | `["future_tag", 42]`   |
+
 #### `[@@deriving json_string]`: a shortcut for JSON string conversion
 
 For convenience, one can use `[@@deriving json_string]` to generate converters

ppx/browser/ppx_deriving_json_js.ml

@@ -150,9 +150,52 @@ module Of_json = struct
         else [%e not_array_error]
       else [%e string_branch]]
 
+  (* Build a payload-preserving unknown_variant_case value from the already-extracted
+     [tag] / [len] / [array] vars (see [derive_of_variant]). Wire shapes:
+     bare string ↔ payload=None; single-element array ↔ payload=Some[];
+     n-element array ↔ payload=Some(rest). *)
+  let build_unknown_variant_case_record ~loc =
+    [%expr
+      let tag_s = tag in
+      let payload =
+        if Stdlib.( = ) len 0 then Stdlib.Option.None
+        else if Stdlib.( = ) len 1 then Stdlib.Option.Some []
+        else
+          let rest =
+            Stdlib.Array.sub array 1 (Stdlib.( - ) len 1)
+            |> Stdlib.Array.to_list
+            |> Stdlib.List.map (fun j -> (Obj.magic j : Melange_json.t))
+          in
+          Stdlib.Option.Some rest
+      in
+      ({ tag = tag_s; payload } : Melange_json.unknown_variant_case)]
+
   let derive_of_variant_case ?td derive make c ~allow_any_constr next =
     let compact = Option.fold ~none:false ~some:is_compact_variants td in
+    let _ = derive in
+    let _ = allow_any_constr in
     match c with
+    | Vcs_tuple (n, t) when vcs_attr_json_catch_all t.tpl_ctx ->
+        let loc = n.loc in
+        (match t.tpl_types with
+         | [ _ ] -> make (Some (build_unknown_variant_case_record ~loc))
+         | _ ->
+             Location.raise_errorf ~loc
+               "[@json.catch_all] requires exactly one argument: a record \
+                type with fields `tag : string` and \
+                `payload : Melange_json.t list option` (typically \
+                [Melange_json.unknown_variant_case])")
+    | Vcs_record (_n, t) when vcs_attr_json_catch_all t.rcd_ctx ->
+        let loc = t.rcd_loc in
+        (match t.rcd_fields with
+         | [ { pld_name = { txt = "tag"; _ }; _ };
+             { pld_name = { txt = "payload"; _ }; _ } ] ->
+             make (Some (build_unknown_variant_case_record ~loc))
+         | _ ->
+             Location.raise_errorf ~loc
+               "[@json.catch_all] inline record must have exactly two \
+                fields named `tag` and `payload` (in that order), with \
+                types `string` and `Melange_json.t list option`")
     | Vcs_record (n, r) ->
         let loc = n.loc in
         let n = Option.value ~default:n (vcs_attr_json_name r.rcd_ctx) in
@@ -246,6 +289,57 @@ module To_json = struct
   let derive_of_variant_case ?td derive c es =
     let compact = Option.fold ~none:false ~some:is_compact_variants td in
     match c with
+    | Vcs_tuple (n, t) when vcs_attr_json_catch_all t.tpl_ctx -> (
+        let loc = n.loc in
+        match t.tpl_types, es with
+        | [ _ ], [ arg_e ] ->
+            [%expr
+              match [%e arg_e].payload with
+              | Stdlib.Option.None ->
+                  (Obj.magic ([%e arg_e].tag : string) : Js.Json.t)
+              | Stdlib.Option.Some xs ->
+                  let head =
+                    (Obj.magic ([%e arg_e].tag : string) : Js.Json.t)
+                  in
+                  let rest =
+                    Stdlib.List.map
+                      (fun (j : Melange_json.t) -> (Obj.magic j : Js.Json.t))
+                      xs
+                  in
+                  (Obj.magic
+                     (Stdlib.Array.of_list (head :: rest) : Js.Json.t array)
+                    : Js.Json.t)]
+        | _ ->
+            Location.raise_errorf ~loc
+              "[@json.catch_all] requires exactly one argument: a record \
+               type with fields `tag : string` and \
+               `payload : Melange_json.t list option` (typically \
+               [Melange_json.unknown_variant_case])")
+    | Vcs_record (_n, t) when vcs_attr_json_catch_all t.rcd_ctx -> (
+        let loc = t.rcd_loc in
+        match t.rcd_fields, es with
+        | ( [ { pld_name = { txt = "tag"; _ }; _ };
+              { pld_name = { txt = "payload"; _ }; _ } ],
+            [ tag_e; payload_e ] ) ->
+            [%expr
+              match [%e payload_e] with
+              | Stdlib.Option.None ->
+                  (Obj.magic ([%e tag_e] : string) : Js.Json.t)
+              | Stdlib.Option.Some xs ->
+                  let head = (Obj.magic ([%e tag_e] : string) : Js.Json.t) in
+                  let rest =
+                    Stdlib.List.map
+                      (fun (j : Melange_json.t) -> (Obj.magic j : Js.Json.t))
+                      xs
+                  in
+                  (Obj.magic
+                     (Stdlib.Array.of_list (head :: rest) : Js.Json.t array)
+                    : Js.Json.t)]
+        | _ ->
+            Location.raise_errorf ~loc
+              "[@json.catch_all] inline record must have exactly two \
+               fields named `tag` and `payload` (in that order), with \
+               types `string` and `Melange_json.t list option`")
     | Vcs_record (n, r) ->
         let loc = n.loc in
         let n = Option.value ~default:n (vcs_attr_json_name r.rcd_ctx) in

ppx/native/common/ppx_deriving_json_common.ml

@@ -35,6 +35,25 @@ let vcs_attr_json_allow_any =
     | None -> false
     | Some () -> true
 
+(* [@json.catch_all] marks a variant constructor as the catch-all for any
+   unrecognised string tag. The decoder routes both bare unknown strings and
+   unknown array variants ["future_tag", ...] to this constructor (in the
+   array case any payload is captured into the [payload] field for lossless
+   round-trip). The encoder writes the value back in the same wire shape.
+   Pairs naturally with [@@json.compact_variants] so the known cases are
+   also bare strings. *)
+let attr_json_catch_all ctx = Attribute.declare_flag "json.catch_all" ctx
+
+let vcs_attr_json_catch_all =
+  let variant =
+    attr_json_catch_all Attribute.Context.constructor_declaration
+  in
+  let polyvariant = attr_json_catch_all 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/native/ppx_deriving_json_native.ml

@@ -137,6 +137,56 @@ module Of_json = struct
     | Vcs_tuple (n, t) when vcs_attr_json_allow_any t.tpl_ctx ->
         let loc = n.loc in
         [%pat? _] --> make (Some [%expr x])
+    | Vcs_tuple (n, t) when vcs_attr_json_catch_all t.tpl_ctx ->
+        let loc = n.loc in
+        (match t.tpl_types with
+         | [ _ ] ->
+             [%pat? (`String _ | `List (`String _ :: _)) as v]
+             --> [%expr
+                   let tag =
+                     match v with
+                     | `String s -> s
+                     | `List (`String s :: _) -> s
+                     | _ -> assert false
+                   in
+                   let payload =
+                     match v with
+                     | `String _ -> Stdlib.Option.None
+                     | `List (_ :: rest) -> Stdlib.Option.Some rest
+                     | _ -> assert false
+                   in
+                   [%e make (Some [%expr ({ tag; payload } : Melange_json.unknown_variant_case)])]]
+         | _ ->
+             Location.raise_errorf ~loc
+               "[@json.catch_all] requires exactly one argument: a record \
+                type with fields `tag : string` and \
+                `payload : Yojson.Basic.t list option` (typically \
+                [Melange_json.unknown_variant_case])")
+    | Vcs_record (_n, t) when vcs_attr_json_catch_all t.rcd_ctx ->
+        let loc = t.rcd_loc in
+        (match t.rcd_fields with
+         | [ { pld_name = { txt = "tag"; _ }; _ };
+             { pld_name = { txt = "payload"; _ }; _ } ] ->
+             [%pat? (`String _ | `List (`String _ :: _)) as v]
+             --> [%expr
+                   let tag =
+                     match v with
+                     | `String s -> s
+                     | `List (`String s :: _) -> s
+                     | _ -> assert false
+                   in
+                   let payload =
+                     match v with
+                     | `String _ -> Stdlib.Option.None
+                     | `List (_ :: rest) -> Stdlib.Option.Some rest
+                     | _ -> assert false
+                   in
+                   [%e make (Some [%expr ({ tag; payload } : Melange_json.unknown_variant_case)])]]
+         | _ ->
+             Location.raise_errorf ~loc
+               "[@json.catch_all] inline record must have exactly two \
+                fields named `tag` and `payload` (in that order), with \
+                types `string` and `Yojson.Basic.t list option`")
     | Vcs_tuple (n, t) ->
         let loc = n.loc in
         let n = Option.value ~default:n (vcs_attr_json_name t.tpl_ctx) in
@@ -164,16 +214,21 @@ module Of_json = struct
         --> build_record ~allow_extra_fields ~loc derive t.rcd_fields
               [%expr fs] (fun e -> make (Some e))
 
+  (* Sort key for variant cases. Smaller = visited earlier by the
+     fold-left in [deriving_of_match], which means it ends up *later* in
+     the generated [match …] cases (the fold prepends). So we want the
+     widest catch-alls to come first here:
+       - [@json.allow_any] (catches any JSON)
+       - [@json.catch_all] (catches any string)
+       - specific constructor cases
+   *)
   let cmp_sort_vcs vcs1 vcs2 =
-    let allow_any_1 =
-      Ppx_deriving_json_common.vcs_attr_json_allow_any vcs1
-    and allow_any_2 =
-      Ppx_deriving_json_common.vcs_attr_json_allow_any vcs2
+    let key vcs =
+      if Ppx_deriving_json_common.vcs_attr_json_allow_any vcs then 0
+      else if Ppx_deriving_json_common.vcs_attr_json_catch_all vcs then 1
+      else 2
     in
-    match allow_any_1, allow_any_2 with
-    | true, true | false, false -> 0
-    | true, false -> -1
-    | false, true -> 1
+    compare (key vcs1) (key vcs2)
 
   let deriving : Ppx_deriving_tools.deriving =
     deriving_of_match () ~name:"of_json"
@@ -241,6 +296,37 @@ module To_json = struct
             failwith
               (sprintf "expected a tuple of length 1, got %i"
                  (List.length es)))
+    | Vcs_tuple (n, t) when vcs_attr_json_catch_all t.tpl_ctx -> (
+        let loc = n.loc in
+        match t.tpl_types, es with
+        | [ _ ], [ arg_e ] ->
+            [%expr
+              match [%e arg_e].payload with
+              | Stdlib.Option.None -> `String [%e arg_e].tag
+              | Stdlib.Option.Some xs ->
+                  `List (`String [%e arg_e].tag :: xs)]
+        | _ ->
+            Location.raise_errorf ~loc
+              "[@json.catch_all] requires exactly one argument: a record \
+               type with fields `tag : string` and \
+               `payload : Yojson.Basic.t list option` (typically \
+               [Melange_json.unknown_variant_case])")
+    | Vcs_record (_n, t) when vcs_attr_json_catch_all t.rcd_ctx -> (
+        let loc = t.rcd_loc in
+        match t.rcd_fields, es with
+        | ( [ { pld_name = { txt = "tag"; _ }; _ };
+              { pld_name = { txt = "payload"; _ }; _ } ],
+            [ tag_e; payload_e ] ) ->
+            [%expr
+              match [%e payload_e] with
+              | Stdlib.Option.None -> `String [%e tag_e]
+              | Stdlib.Option.Some xs ->
+                  `List (`String [%e tag_e] :: xs)]
+        | _ ->
+            Location.raise_errorf ~loc
+              "[@json.catch_all] inline record must have exactly two \
+               fields named `tag` and `payload` (in that order), with \
+               types `string` and `Yojson.Basic.t list option`")
     | Vcs_tuple (n, t) ->
         let loc = n.loc in
         let n = Option.value ~default:n (vcs_attr_json_name t.tpl_ctx) in

ppx/test/catch_all.t/dune

@@ -0,0 +1,6 @@
+(executable
+  (name prettify)
+  (libraries yojson)
+  (flags (:standard -open Melange_json.Primitives -w -33))
+  (preprocess
+   (pps melange-json-native.ppx)))

ppx/test/catch_all.t/dune-project

@@ -0,0 +1 @@
+(lang dune 1.0)

ppx/test/catch_all.t/prettify.ml

@@ -0,0 +1,50 @@
+(* [@json.catch_all] marks the constructor that absorbs any unrecognised
+   string tag during decoding. The constructor's argument is the library
+   type [Melange_json.unknown_variant_case], a record with fields
+   [{ tag : string; payload : Melange_json.t list option }]. The decoder
+   captures both bare-string and array wire shapes losslessly; the encoder
+   re-emits the captured wire shape. *)
+
+type sum_enum =
+  | Alpha [@json.name "alpha"]
+  | Beta of int [@json.name "beta"]
+  | Other of Melange_json.unknown_variant_case [@json.catch_all]
+[@@deriving json] [@@json.compact_variants]
+
+type poly_enum =
+  [ `Alpha [@json.name "alpha"]
+  | `Beta of int [@json.name "beta"]
+  | `Other of Melange_json.unknown_variant_case [@json.catch_all]
+  ]
+[@@deriving json] [@@json.compact_variants]
+
+let pp_unknown { Melange_json.tag; payload } =
+  match payload with
+  | None -> Printf.sprintf "Other(%s,bare)" tag
+  | Some xs -> Printf.sprintf "Other(%s,[%s])" tag (String.concat ";" (List.map Yojson.Basic.to_string xs))
+
+let pp = function
+  | Alpha -> "Alpha"
+  | Beta n -> Printf.sprintf "Beta(%d)" n
+  | Other u -> pp_unknown u
+
+let pp_poly (v : poly_enum) =
+  match v with
+  | `Alpha -> "Alpha"
+  | `Beta n -> Printf.sprintf "Beta(%d)" n
+  | `Other u -> pp_unknown u
+
+let () =
+  let json = Yojson.Basic.from_string Sys.argv.(1) in
+  let kind = Sys.argv.(2) in
+  let in_s = Yojson.Basic.to_string json in
+  match kind with
+  | "sum" ->
+    let v = sum_enum_of_json json in
+    Printf.printf "got %s\n" (pp v);
+    Printf.printf "round-trip %s -> %s\n" in_s (Yojson.Basic.to_string (sum_enum_to_json v))
+  | "poly" ->
+    let v = poly_enum_of_json json in
+    Printf.printf "got %s\n" (pp_poly v);
+    Printf.printf "round-trip %s -> %s\n" in_s (Yojson.Basic.to_string (poly_enum_to_json v))
+  | _ -> failwith "kind must be sum or poly"