Skip to content

Commit 3ae9d96

Browse files
committed
ppx: add polymorphic_variant_tuple flag
1 parent 03dd18b commit 3ae9d96

File tree

5 files changed

+298
-135
lines changed

5 files changed

+298
-135
lines changed

README.md

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -121,6 +121,62 @@ type t =
121121
}
122122
```
123123

124+
Note that the implicit tuple in a polymorphic variant is flattened. This can be disabled using the `~polymorphic_variant_tuple` flag.
125+
126+
```ocaml
127+
type a = [ `A of int * string * bool ] [@@deriving jsonschema]
128+
```
129+
130+
```json
131+
{
132+
"anyOf": [
133+
{
134+
"type": "array",
135+
"prefixItems": [
136+
{ "const": "A" },
137+
{ "type": "integer" },
138+
{ "type": "string" },
139+
{ "type": "boolean" }
140+
],
141+
"unevaluatedItems": false,
142+
"minItems": 4,
143+
"maxItems": 4
144+
}
145+
]
146+
}
147+
```
148+
149+
```ocaml
150+
type b = [ `B of int * string * bool ] [@@deriving jsonschema ~polymorphic_variant_tuple]
151+
```
152+
153+
```json
154+
{
155+
"anyOf": [
156+
{
157+
"type": "array",
158+
"prefixItems": [
159+
{ "const": "B" },
160+
{
161+
"type": "array",
162+
"prefixItems": [
163+
{ "type": "integer" },
164+
{ "type": "string" },
165+
{ "type": "boolean" }
166+
],
167+
"unevaluatedItems": false,
168+
"minItems": 3,
169+
"maxItems": 3
170+
}
171+
],
172+
"unevaluatedItems": false,
173+
"minItems": 2,
174+
"maxItems": 2
175+
}
176+
]
177+
}
178+
```
179+
124180
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:
125181

126182
```ocaml

src/ppx_deriving_jsonschema.ml

Lines changed: 31 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,9 @@ type config = {
66
(** Encode variants as string instead of string array.
77
This option breaks compatibility with yojson derivers and
88
doesn't support constructors with a payload. *)
9+
polymorphic_variant_tuple : bool;
10+
(** Preserve the implicit tuple in a polymorphic variant.
11+
This option breaks compatibility with yojson derivers. *)
912
}
1013

1114
let deriver_name = "jsonschema"
@@ -39,7 +42,7 @@ let attributes =
3942
]
4043

4144
(* let args () = Deriving.Args.(empty) *)
42-
let args () = Deriving.Args.(empty +> flag "variant_as_string")
45+
let args () = Deriving.Args.(empty +> flag "variant_as_string" +> flag "polymorphic_variant_tuple")
4346

4447
let deps = []
4548

@@ -164,18 +167,37 @@ let rec type_of_core ~config core_type =
164167
let constrs =
165168
List.map
166169
(fun row_field ->
167-
match row_field with
168-
| { prf_desc = Rtag (name, _, typs); _ } ->
170+
match row_field.prf_desc with
171+
| Rtag (name, true, []) ->
169172
let name =
170173
match Attribute.get jsonschema_polymorphic_variant_name row_field with
171174
| Some name -> name.txt
172175
| None -> name.txt
173176
in
177+
`Tag (name, [])
178+
| Rtag (name, false, [ typ ]) ->
179+
let name =
180+
match Attribute.get jsonschema_polymorphic_variant_name row_field with
181+
| Some name -> name.txt
182+
| None -> name.txt
183+
in
184+
let typs =
185+
match config.polymorphic_variant_tuple with
186+
| true -> [ typ ]
187+
| false ->
188+
match typ.ptyp_desc with
189+
| Ptyp_tuple tps -> tps
190+
| _ -> [ typ ]
191+
in
174192
let typs = List.map (type_of_core ~config) typs in
175193
`Tag (name, typs)
176-
| { prf_desc = Rinherit core_type; _ } ->
194+
| Rtag (_, true, [ _ ]) | Rtag (_, _, _ :: _ :: _) ->
195+
Location.raise_errorf ~loc "ppx_deriving_jsonschema: polymorphic_variant/Rtag/&"
196+
| Rinherit core_type ->
177197
let typ = type_of_core ~config core_type in
178-
`Inherit typ)
198+
`Inherit typ
199+
(* impossible?*)
200+
| Rtag (_, false, []) -> assert false)
179201
row_fields
180202
in
181203
(* todo: raise an error if encoding is as string and constructor has a payload *)
@@ -216,9 +238,11 @@ let object_ ~loc ~config fields =
216238
"required", `List [%e elist ~loc required];
217239
]]
218240

219-
let derive_jsonschema ~ctxt ast flag_variant_as_string =
241+
let derive_jsonschema ~ctxt ast flag_variant_as_string flag_polymorphic_variant_tuple =
220242
let loc = Expansion_context.Deriver.derived_item_loc ctxt in
221-
let config = { variant_as_string = flag_variant_as_string } in
243+
let config =
244+
{ variant_as_string = flag_variant_as_string; polymorphic_variant_tuple = flag_polymorphic_variant_tuple }
245+
in
222246
match ast with
223247
| _, [ { ptype_name = { txt = type_name; _ }; ptype_kind = Ptype_variant variants; _ } ] ->
224248
let variants =

0 commit comments

Comments
 (0)