Skip to content

Commit

Permalink
support polymorphic variant inheritance
Browse files Browse the repository at this point in the history
  • Loading branch information
@Khady
Khady committed Sep 25, 2024
1 parent 9eec6a7 commit 46b18c5
Show file tree
Hide file tree
Showing 4 changed files with 268 additions and 79 deletions.
39 changes: 23 additions & 16 deletions src/ppx_deriving_jsonschema.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -99,18 +99,29 @@ module Schema = struct
enum ~loc (Some "string") values
end

let variant_as_array ~loc values = Schema.array_ ~loc ~min_items:1 ~max_items:1 (Schema.enum_string ~loc values)
let variant_as_string ~loc constrs =
Schema.oneOf ~loc
(List.map
(function
| `Tag (name, _typs) -> Schema.const ~loc name
| `Inherit typ -> typ)
constrs)

let variant_as_string ~loc values = Schema.enum_string ~loc values

let variant_with_payload ~loc constrs =
Schema.oneOf ~loc (List.map (fun (name, typs) -> Schema.tuple ~loc (Schema.const ~loc name :: typs)) constrs)
let variant_as_array ~loc constrs = Schema.array_ ~loc ~min_items:1 ~max_items:1 (variant_as_string ~loc constrs)

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

let variant_with_payload ~loc constrs =
Schema.oneOf ~loc
(List.map
(function
| `Tag (name, typs) -> Schema.tuple ~loc (Schema.const ~loc name :: typs)
| `Inherit typ -> typ)
constrs)

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

let create_value ~loc name value =
Expand Down Expand Up @@ -154,21 +165,17 @@ let rec type_of_core ~loc ~config core_type =
| None -> name.txt
in
let typs = List.map (type_of_core ~loc ~config) typs in
name, typs
`Tag (name, typs)
| { prf_desc = Rinherit core_type; _ } ->
(* let typs = [ type_of_core ~loc ~config core_type ] in *)
let name =
Format.asprintf "unsupported polymorphic variant inheritance: %a" Astlib.Pprintast.core_type
core_type (* todo: *)
in
name, [])
let typ = type_of_core ~loc ~config core_type in
`Inherit typ)
row_fields
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_with_payload ~loc constrs
| false -> variant_as_string ~loc (List.map fst constrs)
| false -> variant_as_string ~loc constrs
in
v
| _ ->
Expand Down Expand Up @@ -224,17 +231,17 @@ let derive_jsonschema ~ctxt ast variant_as_array =
match pcd_args with
| Pcstr_record label_declarations ->
let typs = [ object_ ~loc ~config label_declarations ] in
name, typs
`Tag (name, typs)
| Pcstr_tuple typs ->
let types = List.map (type_of_core ~loc ~config) typs in
name, types)
`Tag (name, types))
variants
in
let v =
(* todo: raise an error if encoding is as string and constructor has a payload *)
match variant_as_array with
| true -> variant_with_payload ~loc variants
| false -> variant_as_string ~loc (List.map fst variants)
| false -> variant_as_string ~loc variants
in
let jsonschema_expr = create_value ~loc type_name v in
[ jsonschema_expr ]
Expand Down
117 changes: 89 additions & 28 deletions test/test.expected.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,8 +13,10 @@ module Mod1 =
struct
let m_1_jsonschema =
`Assoc
[("type", (`String "string"));
("enum", (`List [`String "A"; `String "B"]))][@@warning "-32-39"]
[("oneOf",
(`List
[`Assoc [("const", (`String "A"))];
`Assoc [("const", (`String "B"))]]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
module Mod2 =
struct
Expand All @@ -25,9 +27,11 @@ module Mod1 =
struct
let m_2_jsonschema =
`Assoc
[("type", (`String "string"));
("enum", (`List [`String "C"; `String "D"]))][@@warning
"-32-39"]
[("oneOf",
(`List
[`Assoc [("const", (`String "C"))];
`Assoc [("const", (`String "D"))]]))][@@warning
"-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
end
end
Expand All @@ -54,10 +58,11 @@ include
struct
let kind_jsonschema =
`Assoc
[("type", (`String "string"));
("enum",
(`List [`String "Success"; `String "Error"; `String "skipped"]))]
[@@warning "-32-39"]
[("oneOf",
(`List
[`Assoc [("const", (`String "Success"))];
`Assoc [("const", (`String "Error"))];
`Assoc [("const", (`String "skipped"))]]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema kind_jsonschema
type kind_as_array =
Expand Down Expand Up @@ -98,9 +103,11 @@ include
struct
let poly_kind_jsonschema =
`Assoc
[("type", (`String "string"));
("enum", (`List [`String "Aaa"; `String "Bbb"; `String "ccc"]))]
[@@warning "-32-39"]
[("oneOf",
(`List
[`Assoc [("const", (`String "Aaa"))];
`Assoc [("const", (`String "Bbb"))];
`Assoc [("const", (`String "ccc"))]]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema poly_kind_jsonschema
type poly_kind_as_array = [ `Aaa | `Bbb | `Ccc [@name "ccc"]][@@deriving
Expand Down Expand Up @@ -142,9 +149,11 @@ include
struct
let poly_kind_with_payload_jsonschema =
`Assoc
[("type", (`String "string"));
("enum", (`List [`String "Aaa"; `String "Bbb"; `String "ccc"]))]
[@@warning "-32-39"]
[("oneOf",
(`List
[`Assoc [("const", (`String "Aaa"))];
`Assoc [("const", (`String "Bbb"))];
`Assoc [("const", (`String "ccc"))]]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema poly_kind_with_payload_jsonschema
type poly_kind_with_payload_as_array =
Expand Down Expand Up @@ -192,19 +201,48 @@ include
("maxItems", (`Int 2))]]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema poly_kind_with_payload_as_array_jsonschema
type poly_inherit = [ `New_one | poly_kind][@@deriving jsonschema]
type poly_inherit = [ `New_one | `Second_one of int | poly_kind][@@deriving
jsonschema]
include
struct
let poly_inherit_jsonschema =
`Assoc
[("type", (`String "string"));
("enum",
(`List
[`String "New_one";
`String "unsupported polymorphic variant inheritance: poly_kind"]))]
[@@warning "-32-39"]
[("oneOf",
(`List
[`Assoc [("const", (`String "New_one"))];
`Assoc [("const", (`String "Second_one"))];
poly_kind_jsonschema]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema poly_inherit_jsonschema
type poly_inherit_as_array =
[ `New_one | `Second_one of int | poly_kind_as_array][@@deriving
jsonschema
~variant_as_array]
include
struct
let poly_inherit_as_array_jsonschema =
`Assoc
[("oneOf",
(`List
[`Assoc
[("type", (`String "array"));
("prefixItems",
(`List [`Assoc [("const", (`String "New_one"))]]));
("unevaluatedItems", (`Bool false));
("minItems", (`Int 1));
("maxItems", (`Int 1))];
`Assoc
[("type", (`String "array"));
("prefixItems",
(`List
[`Assoc [("const", (`String "Second_one"))];
`Assoc [("type", (`String "integer"))]]));
("unevaluatedItems", (`Bool false));
("minItems", (`Int 2));
("maxItems", (`Int 2))];
poly_kind_as_array_jsonschema]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema poly_inherit_as_array_jsonschema
type event =
{
date: float ;
Expand Down Expand Up @@ -237,9 +275,11 @@ include
("maxLength", (`Int 1))]));
("t",
(`Assoc
[("type", (`String "string"));
("enum",
(`List [`String "Foo"; `String "Bar"; `String "Baz"]))]));
[("oneOf",
(`List
[`Assoc [("const", (`String "Foo"))];
`Assoc [("const", (`String "Bar"))];
`Assoc [("const", (`String "Baz"))]]))]));
("l",
(`Assoc
[("type", (`String "array"));
Expand Down Expand Up @@ -379,10 +419,29 @@ type 'param2 poly2 =
include
struct
let poly2_jsonschema =
`Assoc [("type", (`String "string")); ("enum", (`List [`String "C"]))]
`Assoc [("oneOf", (`List [`Assoc [("const", (`String "C"))]]))]
[@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema poly2_jsonschema
type 'param2 poly2_as_array =
| C of 'param2 [@@deriving jsonschema ~variant_as_array]
include
struct
let poly2_as_array_jsonschema =
`Assoc
[("oneOf",
(`List
[`Assoc
[("type", (`String "array"));
("prefixItems",
(`List
[`Assoc [("const", (`String "C"))];
`Assoc [("unsuported core type", (`String "'param2"))]]));
("unevaluatedItems", (`Bool false));
("minItems", (`Int 2));
("maxItems", (`Int 2))]]))][@@warning "-32-39"]
end[@@ocaml.doc "@inline"][@@merlin.hide ]
let () = print_schema poly2_as_array_jsonschema
type tuple_with_variant = (int * [ `A | `B [@name "second_cstr"]])[@@deriving
jsonschema]
include
Expand All @@ -394,8 +453,10 @@ include
(`List
[`Assoc [("type", (`String "integer"))];
`Assoc
[("type", (`String "string"));
("enum", (`List [`String "A"; `String "second_cstr"]))]]));
[("oneOf",
(`List
[`Assoc [("const", (`String "A"))];
`Assoc [("const", (`String "second_cstr"))]]))]]));
("unevaluatedItems", (`Bool false));
("minItems", (`Int 2));
("maxItems", (`Int 2))][@@warning "-32-39"]
Expand Down
14 changes: 14 additions & 0 deletions test/test.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -81,12 +81,22 @@ let () = print_schema poly_kind_with_payload_as_array_jsonschema

type poly_inherit =
[ `New_one
| `Second_one of int
| poly_kind
]
[@@deriving jsonschema]

let () = print_schema poly_inherit_jsonschema

type poly_inherit_as_array =
[ `New_one
| `Second_one of int
| poly_kind_as_array
]
[@@deriving jsonschema ~variant_as_array]

let () = print_schema poly_inherit_as_array_jsonschema

type event = {
date : float;
kind_f : kind;
Expand Down Expand Up @@ -164,6 +174,10 @@ type 'param2 poly2 = C of 'param2 [@@deriving jsonschema]

let () = print_schema poly2_jsonschema

type 'param2 poly2_as_array = C of 'param2 [@@deriving jsonschema ~variant_as_array]

let () = print_schema poly2_as_array_jsonschema

type tuple_with_variant = int * [ `A | `B [@name "second_cstr"] ] [@@deriving jsonschema]

let () = print_schema tuple_with_variant_jsonschema
Expand Down
Loading

0 comments on commit 46b18c5

Please sign in to comment.