Skip to content

Commit

Permalink
fix encoding of tuples
Browse files Browse the repository at this point in the history
  • Loading branch information
@Khady
Khady committed Sep 25, 2024
1 parent a0e96ab commit 6ba0aa9
Show file tree
Hide file tree
Showing 3 changed files with 103 additions and 53 deletions.
88 changes: 60 additions & 28 deletions src/ppx_deriving_jsonschema.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,35 +46,67 @@ let deps = []
let predefined_types = [ "string"; "int"; "float"; "bool" ]
let is_predefined_type type_name = List.mem type_name predefined_types

let type_ref ~loc type_name =
let name = estring ~loc ("#/$defs/" ^ type_name) in
[%expr `Assoc [ "$ref", `String [%e name] ]]
module Schema = struct
let const ~loc value = [%expr `Assoc [ "const", `String [%e estring ~loc value] ]]

let type_def ~loc type_name = [%expr `Assoc [ "type", `String [%e estring ~loc type_name] ]]
let type_ref ~loc type_name =
let name = estring ~loc ("#/$defs/" ^ type_name) in
[%expr `Assoc [ "$ref", `String [%e name] ]]

let null ~loc = [%expr `Assoc [ "type", `String "null" ]]
let type_def ~loc type_name = [%expr `Assoc [ "type", `String [%e estring ~loc type_name] ]]

let char ~loc = [%expr `Assoc [ "type", `String "string"; "minLength", `Int 1; "maxLength", `Int 1 ]]
let null ~loc = [%expr `Assoc [ "type", `String "null" ]]

let enum ~loc ~config values =
match config.variant_as_array with
| true ->
let values = List.map (fun name -> [%expr `String [%e estring ~loc name]]) values in
let char ~loc = [%expr `Assoc [ "type", `String "string"; "minLength", `Int 1; "maxLength", `Int 1 ]]

let oneOf ~loc values = [%expr `Assoc [ "oneOf", `List [%e elist ~loc values] ]]

let array_ ~loc ?min_items ?max_items element_type =
let fields =
List.filter_map
(fun x -> x)
[
Some [%expr "type", `String "array"];
Some [%expr "items", [%e element_type]];
(match min_items with
| Some min -> Some [%expr "minItems", `Int [%e eint ~loc min]]
| None -> None);
(match max_items with
| Some max -> Some [%expr "maxItems", `Int [%e eint ~loc max]]
| None -> None);
]
in
[%expr `Assoc [%e elist ~loc fields]]

let tuple ~loc elements =
[%expr
`Assoc
[
"type", `String "array";
"items", `Assoc [ "type", `String "string"; "enum", `List [%e elist ~loc values] ];
"minContains", `Int 1;
"maxContains", `Int 1;
"prefixItems", `List [%e elist ~loc elements];
"unevaluatedItems", `Bool false;
"minItems", `Int [%e eint ~loc (List.length elements)];
"maxItems", `Int [%e eint ~loc (List.length elements)];
]]
| false ->

let enum ~loc typ values =
match typ with
| Some typ -> [%expr `Assoc [ "type", `String [%e estring ~loc typ]; "enum", `List [%e elist ~loc values] ]]
| None -> [%expr `Assoc [ "enum", `List [%e elist ~loc values] ]]

let enum_string ~loc values =
let values = List.map (fun name -> [%expr `String [%e estring ~loc name]]) values in
[%expr `Assoc [ "type", `String "string"; "enum", `List [%e elist ~loc values] ]]
enum ~loc (Some "string") values
end

let array_ ~loc element_type = [%expr `Assoc [ "type", `String "array"; "items", [%e element_type] ]]
let variant_as_array ~loc values = Schema.array_ ~loc ~min_items:1 ~max_items:1 (Schema.enum_string ~loc values)

let tuple ~loc elements = [%expr `Assoc [ "type", `String "array"; "items", `List [%e elist ~loc elements] ]]
let variant_as_string ~loc values = Schema.enum_string ~loc values

let variant ~loc ~config values =
match config.variant_as_array with
| true -> variant_as_array ~loc values
| false -> variant_as_string ~loc values

let value_name_pattern ~loc type_name = ppat_var ~loc { txt = type_name ^ "_jsonschema"; loc }

Expand All @@ -88,25 +120,25 @@ let is_optional_type core_type =

let rec type_of_core ~loc ~config core_type =
match core_type with
| [%type: int] | [%type: int32] | [%type: int64] | [%type: nativeint] -> type_def ~loc "integer"
| [%type: float] -> type_def ~loc "number"
| [%type: string] | [%type: bytes] -> type_def ~loc "string"
| [%type: bool] -> type_def ~loc "boolean"
| [%type: char] -> char ~loc
| [%type: unit] -> null ~loc
| [%type: int] | [%type: int32] | [%type: int64] | [%type: nativeint] -> Schema.type_def ~loc "integer"
| [%type: float] -> Schema.type_def ~loc "number"
| [%type: string] | [%type: bytes] -> Schema.type_def ~loc "string"
| [%type: bool] -> Schema.type_def ~loc "boolean"
| [%type: char] -> Schema.char ~loc
| [%type: unit] -> Schema.null ~loc
| [%type: [%t? t] option] -> type_of_core ~loc ~config t
| [%type: [%t? t] ref] -> type_of_core ~loc ~config t
| [%type: [%t? t] list] | [%type: [%t? t] array] ->
let t = type_of_core ~loc ~config t in
array_ ~loc t
Schema.array_ ~loc t
| _ ->
match core_type.ptyp_desc with
| Ptyp_constr (id, []) ->
(* todo: support using references with [type_ref ~loc type_name] instead of inlining everything *)
type_constr_conv ~loc id ~f:(fun s -> s ^ "_jsonschema") []
| Ptyp_tuple types ->
let ts = List.map (type_of_core ~loc ~config) types in
tuple ~loc ts
Schema.tuple ~loc ts
| Ptyp_variant (row_fields, _, _) ->
let constr_names =
List.map
Expand All @@ -121,7 +153,7 @@ let rec type_of_core ~loc ~config core_type =
Format.asprintf "unsupported polymorphic variant type: %a" Astlib.Pprintast.core_type core_type (* todo: *))
row_fields
in
enum ~loc ~config constr_names
variant ~loc ~config constr_names
| _ ->
(* Format.printf "unsuported core type: %a\n------\n" Astlib.Pprintast.core_type core_type; *)
[%expr
Expand All @@ -143,7 +175,7 @@ let object_ ~loc ~config fields =
in
let type_def =
match Attribute.get jsonschema_ref field with
| Some def -> type_ref ~loc def
| Some def -> Schema.type_ref ~loc def
| None -> type_of_core ~loc ~config pld_type
in
( [%expr [%e estring ~loc name], [%e type_def]] :: fields,
Expand Down Expand Up @@ -181,7 +213,7 @@ let derive_jsonschema ~ctxt ast variant_as_array =
variants
in
(* let names = List.map (fun { pcd_name = { txt = value; _ }; _ } -> value) variants in *)
let jsonschema_expr = create_value ~loc type_name (enum ~loc ~config variants) in
let jsonschema_expr = create_value ~loc type_name (variant ~loc ~config variants) in
[ jsonschema_expr ]
| _, [ { ptype_name = { txt = type_name; _ }; ptype_kind = Ptype_record label_declarations; _ } ] ->
let jsonschema_expr = create_value ~loc type_name (object_ ~loc ~config label_declarations) in
Expand Down
32 changes: 19 additions & 13 deletions test/test.expected.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -74,8 +74,8 @@ include
[("type", (`String "string"));
("enum",
(`List [`String "Success"; `String "Error"; `String "skipped"]))]));
("minContains", (`Int 1));
("maxContains", (`Int 1))][@@warning "-32-39"]
("minItems", (`Int 1));
("maxItems", (`Int 1))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema kind_as_array_jsonschema
type poly_kind = [ `Aaa | `Bbb | `Ccc [@name "ccc"]][@@deriving jsonschema]
Expand All @@ -100,8 +100,8 @@ include
(`Assoc
[("type", (`String "string"));
("enum", (`List [`String "Aaa"; `String "Bbb"; `String "ccc"]))]));
("minContains", (`Int 1));
("maxContains", (`Int 1))][@@warning "-32-39"]
("minItems", (`Int 1));
("maxItems", (`Int 1))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema poly_kind_as_array_jsonschema
type poly_inherit = [ `New_one | poly_kind][@@deriving jsonschema]
Expand Down Expand Up @@ -205,9 +205,11 @@ include
let event_comment_jsonschema =
`Assoc
[("type", (`String "array"));
("items",
(`List [event_jsonschema; `Assoc [("type", (`String "string"))]]))]
[@@warning "-32-39"]
("prefixItems",
(`List [event_jsonschema; `Assoc [("type", (`String "string"))]]));
("unevaluatedItems", (`Bool false));
("minItems", (`Int 2));
("maxItems", (`Int 2))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema event_comment_jsonschema
type event_comments' = event_comment list[@@deriving jsonschema]
Expand All @@ -228,10 +230,12 @@ include
("items",
(`Assoc
[("type", (`String "array"));
("items",
("prefixItems",
(`List
[event_jsonschema; `Assoc [("type", (`String "integer"))]]))]))]
[@@warning "-32-39"]
[event_jsonschema; `Assoc [("type", (`String "integer"))]]));
("unevaluatedItems", (`Bool false));
("minItems", (`Int 2));
("maxItems", (`Int 2))]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema event_n_jsonschema
type events_array = events array[@@deriving jsonschema]
Expand Down Expand Up @@ -304,13 +308,15 @@ include
let tuple_with_variant_jsonschema =
`Assoc
[("type", (`String "array"));
("items",
("prefixItems",
(`List
[`Assoc [("type", (`String "integer"))];
`Assoc
[("type", (`String "string"));
("enum", (`List [`String "A"; `String "second_cstr"]))]]))]
[@@warning "-32-39"]
("enum", (`List [`String "A"; `String "second_cstr"]))]]));
("unevaluatedItems", (`Bool false));
("minItems", (`Int 2));
("maxItems", (`Int 2))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema tuple_with_variant_jsonschema
type player_scores =
Expand Down
36 changes: 24 additions & 12 deletions test/test_schemas.expected.json
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,8 +16,8 @@
"$schema": "https://json-schema.org/draft/2020-12/schema",
"type": "array",
"items": { "type": "string", "enum": [ "Success", "Error", "skipped" ] },
"minContains": 1,
"maxContains": 1
"minItems": 1,
"maxItems": 1
}
{
"$schema": "https://json-schema.org/draft/2020-12/schema",
Expand All @@ -28,8 +28,8 @@
"$schema": "https://json-schema.org/draft/2020-12/schema",
"type": "array",
"items": { "type": "string", "enum": [ "Aaa", "Bbb", "ccc" ] },
"minContains": 1,
"maxContains": 1
"minItems": 1,
"maxItems": 1
}
{
"$schema": "https://json-schema.org/draft/2020-12/schema",
Expand Down Expand Up @@ -123,7 +123,7 @@
{
"$schema": "https://json-schema.org/draft/2020-12/schema",
"type": "array",
"items": [
"prefixItems": [
{
"type": "object",
"properties": {
Expand All @@ -149,14 +149,17 @@
]
},
{ "type": "string" }
]
],
"unevaluatedItems": false,
"minItems": 2,
"maxItems": 2
}
{
"$schema": "https://json-schema.org/draft/2020-12/schema",
"type": "array",
"items": {
"type": "array",
"items": [
"prefixItems": [
{
"type": "object",
"properties": {
Expand All @@ -182,15 +185,18 @@
]
},
{ "type": "string" }
]
],
"unevaluatedItems": false,
"minItems": 2,
"maxItems": 2
}
}
{
"$schema": "https://json-schema.org/draft/2020-12/schema",
"type": "array",
"items": {
"type": "array",
"items": [
"prefixItems": [
{
"type": "object",
"properties": {
Expand All @@ -216,7 +222,10 @@
]
},
{ "type": "integer" }
]
],
"unevaluatedItems": false,
"minItems": 2,
"maxItems": 2
}
}
{
Expand Down Expand Up @@ -281,10 +290,13 @@
{
"$schema": "https://json-schema.org/draft/2020-12/schema",
"type": "array",
"items": [
"prefixItems": [
{ "type": "integer" },
{ "type": "string", "enum": [ "A", "second_cstr" ] }
]
],
"unevaluatedItems": false,
"minItems": 2,
"maxItems": 2
}
{
"$schema": "https://json-schema.org/draft/2020-12/schema",
Expand Down

0 comments on commit 6ba0aa9

Please sign in to comment.