ppx: make variant_as_array the default

ahrefs · Oct 4, 2024 · e7acc7d · e7acc7d
1 parent 9da632e
commit e7acc7d
Show file tree

Hide file tree

Showing 6 changed files with 2,047 additions and 665 deletions.
diff --git a/README.md b/README.md
@@ -2,7 +2,10 @@
 
 `ppx_deriving_jsonschema` is a PPX syntax extension that generates JSON schema from OCaml types.
 
-The conversion aims to be compatible with the existing json derivers.
+The conversion aims to be compatible with the existing json derivers:
+- https://github.com/melange-community/melange-json
+- https://github.com/ocaml-ppx/ppx_deriving_yojson
+- https://github.com/janestreet/ppx_yojson_conv
 
 ## Installation
 
@@ -88,20 +91,7 @@ type t = int * string [@@deriving jsonschema]
 
 #### Variants and polymorphic variants
 
-By default, variants are converted to `"anyOf": [{ "const": "..." }, ...]`. This means that while the constructor names are represented as strings, any associated payload is not included.
-
-```ocaml
-type t =
-| Typ
-| Class of string
-[@@deriving jsonschema]
-```
-
-```json
-{ "anyOf": [ { "const": "Typ" }, { "const": "Class" } ] }
-```
-
-To include the payload in the encoding, the `~variant_as_array` flag should be used. This flag also ensures compatibility with [ppx_deriving_json] and [ppx_yojson_conv]. In this case each constructor is represented like a tuple.
+By default, constructors in variants are represented as a list with one string, which is the name of the contructor. Constructors with arguments are represented as lists, the first element being the constructor name, the rest being its arguments. It reproduces the representation of `ppx_deriving_yojson` and `ppx_yojson_conv`. For example:
 
 ```ocaml
 type t =
@@ -131,13 +121,26 @@ type t =
 }
 ```
 
+A `~variant_as_string` flag is exposed to obtain a more natural representation `"anyOf": [{ "const": "..." }, ...]`. This representation does _not_ support payloads. It reproduces the representation of `melange-json` for [enumeration like variants](https://github.com/melange-community/melange-json?tab=readme-ov-file#enumeration-like-variants). For example:
+
+```ocaml
+type t =
+| Typ
+| Class of string
+[@@deriving jsonschema ~variant_as_string]
+```
+
+```json
+{ "anyOf": [ { "const": "Typ" }, { "const": "Class" } ] }
+```
+
 If the JSON variant names differ from OCaml conventions, it is possible to specify the corresponding JSON string explicitly using `[@name "constr"]`, for example:
 
 ```ocaml
 type t =
 | Typ   [@name "type"]
 | Class of string [@name "class"]
-[@@deriving jsonschema]
+[@@deriving jsonschema ~variant_as_string]
 ```
 
 ```json

diff --git a/src/ppx_deriving_jsonschema.ml b/src/ppx_deriving_jsonschema.ml
@@ -2,32 +2,32 @@ open Ppxlib
 open Ast_builder.Default
 
 type config = {
-  variant_as_array : bool;
-    (** Encode variants as arrays of string enum instead of a string enum.
-      Provides compatibility with the encoding used by the [ppx_deriving_json]
-      and [ppx_yojson_conv] extensions. *)
+  variant_as_string : bool;
+    (** Encode variants as string instead of string array.
+        This option breaks compatibility with yojson derivers and
+        doesn't support constructors with a payload. *)
 }
 
 let deriver_name = "jsonschema"
 
 let jsonschema_key =
   Attribute.declare "jsonschema.key" Attribute.Context.label_declaration
-    Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil))
+    Ast_pattern.(single_expr_payload (estring __'))
     (fun x -> x)
 
 let jsonschema_ref =
   Attribute.declare "jsonschema.ref" Attribute.Context.label_declaration
-    Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil))
+    Ast_pattern.(single_expr_payload (estring __'))
     (fun x -> x)
 
 let jsonschema_variant_name =
   Attribute.declare "jsonschema.name" Attribute.Context.constructor_declaration
-    Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil))
+    Ast_pattern.(single_expr_payload (estring __'))
     (fun x -> x)
 
 let jsonschema_polymorphic_variant_name =
   Attribute.declare "jsonschema.name" Attribute.Context.rtag
-    Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil))
+    Ast_pattern.(single_expr_payload (estring __'))
     (fun x -> x)
 
 let attributes =
@@ -39,7 +39,7 @@ let attributes =
   ]
 
 (* let args () = Deriving.Args.(empty) *)
-let args () = Deriving.Args.(empty +> flag "variant_as_array")
+let args () = Deriving.Args.(empty +> flag "variant_as_string")
 
 let deps = []
 
@@ -123,9 +123,9 @@ let variant ~loc ~config constrs =
        (function
          | `Inherit typ -> typ
          | `Tag (name, typs) ->
-         match config.variant_as_array with
-         | true -> Schema.tuple ~loc (Schema.const ~loc name :: typs)
-         | false -> Schema.const ~loc name)
+         match config.variant_as_string with
+         | true -> Schema.const ~loc name
+         | false -> Schema.tuple ~loc (Schema.const ~loc name :: typs))
        constrs)
 
 let value_name_pattern ~loc type_name = ppat_var ~loc { txt = type_name ^ "_jsonschema"; loc }
@@ -168,7 +168,7 @@ let rec type_of_core ~config core_type =
           | { prf_desc = Rtag (name, _, typs); _ } ->
             let name =
               match Attribute.get jsonschema_polymorphic_variant_name row_field with
-              | Some name -> name
+              | Some name -> name.txt
               | None -> name.txt
             in
             let typs = List.map (type_of_core ~config) typs in
@@ -180,9 +180,9 @@ let rec type_of_core ~config core_type =
     in
     (* todo: raise an error if encoding is as string and constructor has a payload *)
     let v =
-      match config.variant_as_array with
-      | true -> variant_as_array ~loc constrs
-      | false -> variant_as_string ~loc constrs
+      match config.variant_as_string with
+      | true -> variant_as_string ~loc constrs
+      | false -> variant_as_array ~loc constrs
     in
     v
   | _ ->
@@ -195,12 +195,12 @@ let object_ ~loc ~config fields =
       (fun (fields, required) ({ pld_name; pld_type; pld_loc = _loc; _ } as field) ->
         let name =
           match Attribute.get jsonschema_key field with
-          | Some name -> name
+          | Some name -> name.txt
           | None -> pld_name.txt
         in
         let type_def =
           match Attribute.get jsonschema_ref field with
-          | Some def -> Schema.type_ref ~loc def
+          | Some def -> Schema.type_ref ~loc def.txt
           | None -> type_of_core ~config pld_type
         in
         ( [%expr [%e estring ~loc name], [%e type_def]] :: fields,
@@ -216,17 +216,17 @@ let object_ ~loc ~config fields =
         "required", `List [%e elist ~loc required];
       ]]
 
-let derive_jsonschema ~ctxt ast flag_variant_as_array =
+let derive_jsonschema ~ctxt ast flag_variant_as_string =
   let loc = Expansion_context.Deriver.derived_item_loc ctxt in
-  let config = { variant_as_array = flag_variant_as_array } in
+  let config = { variant_as_string = flag_variant_as_string } in
   match ast with
   | _, [ { ptype_name = { txt = type_name; _ }; ptype_kind = Ptype_variant variants; _ } ] ->
     let variants =
       List.map
         (fun ({ pcd_args; pcd_name = { txt = name; _ }; _ } as var) ->
           let name =
             match Attribute.get jsonschema_variant_name var with
-            | Some name -> name
+            | Some name -> name.txt
             | None -> name
           in
           match pcd_args with
@@ -240,9 +240,9 @@ let derive_jsonschema ~ctxt ast flag_variant_as_array =
     in
     let v =
       (* todo: raise an error if encoding is as string and constructor has a payload *)
-      match config.variant_as_array with
-      | true -> variant_as_array ~loc variants
-      | false -> variant_as_string ~loc variants
+      match config.variant_as_string with
+      | true -> variant_as_string ~loc variants
+      | false -> variant_as_array ~loc variants
     in
     let jsonschema_expr = create_value ~loc type_name v in
     [ jsonschema_expr ]

diff --git a/test/generate_schemas.ml b/test/generate_schemas.ml
@@ -5,13 +5,13 @@ let schemas =
   [
     json_schema with_modules_jsonschema;
     json_schema kind_jsonschema;
-    json_schema kind_as_array_jsonschema;
+    json_schema kind_as_string_jsonschema;
     json_schema poly_kind_jsonschema;
-    json_schema poly_kind_as_array_jsonschema;
+    json_schema poly_kind_as_string_jsonschema;
     json_schema poly_kind_with_payload_jsonschema;
-    json_schema poly_kind_with_payload_as_array_jsonschema;
+    json_schema poly_kind_with_payload_as_string_jsonschema;
     json_schema poly_inherit_jsonschema;
-    json_schema poly_inherit_as_array_jsonschema;
+    json_schema poly_inherit_as_string_jsonschema;
     json_schema event_jsonschema;
     json_schema events_jsonschema;
     json_schema eventss_jsonschema;