diff --git a/src/lib_gen/json_codec.ml b/src/lib_gen/json_codec.ml index 8ac27b3..83b5bff 100644 --- a/src/lib_gen/json_codec.ml +++ b/src/lib_gen/json_codec.ml @@ -1557,7 +1557,7 @@ let gen_json_schema : ?openapi:bool -> type_decl -> Schema_object.t = let docopt = function `docstr s -> Some s | `nodoc -> None in - let convert_coretype ?alias_decl_props ~self_name ~self_mangled_type_name base_mangling_style ?description (ct: coretype) = + let convert_coretype ?alias_decl_props ~self_name:_ ~self_mangled_type_name base_mangling_style ?description (ct: coretype) = let base_mangling_style = Json_config.get_mangling_style_opt ct.ct_configs |? base_mangling_style in @@ -1592,8 +1592,10 @@ let gen_json_schema : ?openapi:bool -> type_decl -> Schema_object.t = begin match tuple_style with | `arr -> if openapi then - raise (Incompatible_with_openapi_v3 ( - sprintf "OpenAPI v3 does not support tuple validation (in type '%s')" self_name)) + let len = List.length ts in + Schema_object.array () ?schema ?id ?title ?description + ~minItems:len ~maxItems:len + ~items:(`T (ts |> List.map go |> Schema_object.oneOf)) else Schema_object.tuple ?schema ?id ?title ?description (ts |> List.map go) | `obj `default -> @@ -1727,12 +1729,14 @@ let gen_json_schema : ?openapi:bool -> type_decl -> Schema_object.t = match ts, Json_config.get_tuple_style vc_configs with | [], _ -> [arg_name, convert_variant_argument t] | _, `arr -> + let ts = args |> List.map convert_variant_argument in if openapi then - raise (Incompatible_with_openapi_v3 ( - sprintf "OpenAPI v3 does not support tuple validation (in type '%s')" self_name)) - else - let ts = args |> List.map convert_variant_argument in - [arg_name, Schema_object.tuple ts] + let len = List.length ts in + [ arg_name, + Schema_object.array () + ~minItems:len ~maxItems:len + ~items:(`T (ts |> Schema_object.oneOf)) ] + else [arg_name, Schema_object.tuple ts] | _, `obj `default -> args |> List.mapi (fun i t -> Json_config.tuple_index_to_field_name i, convert_variant_argument t diff --git a/src/lib_typedesc/coretypes.ml b/src/lib_typedesc/coretypes.ml index dc3cdee..9369a16 100644 --- a/src/lib_typedesc/coretypes.ml +++ b/src/lib_typedesc/coretypes.ml @@ -39,7 +39,7 @@ let to_coretype : 'x t -> coretype = let with_config : [`coretype] configs -> 'x t -> 'x t = fun configs -> function - | C (desc, _) -> C (desc, configs) + | C (desc, orig) -> C (desc, Configs.merge configs orig) module Prims = struct let unit : unit t = C (prim `unit, Configs.empty) @@ -64,7 +64,7 @@ let uninhabitable : Kxclib.null t = C (Uninhabitable, Configs.empty) let option : 'v t -> 'v option t = - fun ct -> C (to_desc ct |> option, Configs.empty) + fun ct -> C (to_desc ct |> option, configs ct) let tuple_tag = Obj.tag (Obj.repr (0, 0)) let is_tuple : 'x. 'x -> bool = @@ -81,7 +81,14 @@ module Tuple = struct let ds = iota (Obj.size r) |&> Obj.field r |&> (fun pos -> Obj.obj pos |> to_desc) in - C (tuple ds, Configs.empty) + let cs = + iotafl (fun acc i -> + Configs.merge + (Obj.field r i |> Obj.obj |> configs) + acc) + Configs.empty (Obj.size r) + in + C (tuple ds, cs) let tup2 : ('v1 t * 'v2 t) -> ('v1 * 'v2) t = tuple_unsafe let tup3 : ('v1 t * 'v2 t * 'v3 t) -> ('v1 * 'v2 * 'v3) t = tuple_unsafe @@ -94,11 +101,11 @@ module Tuple = struct end let list : 'v t -> 'v list t = - fun ct -> C (to_desc ct |> list, Configs.empty) + fun ct -> C (to_desc ct |> list, configs ct) module Map = struct let string_map : 'v t -> (string * 'v) list t = - fun ct -> C (to_desc ct |> map `string, Configs.empty) + fun ct -> C (to_desc ct |> map `string, configs ct) end module Enum = struct diff --git a/src/lib_typedesc/type_desc.ml b/src/lib_typedesc/type_desc.ml index 22e6539..8669f1e 100644 --- a/src/lib_typedesc/type_desc.ml +++ b/src/lib_typedesc/type_desc.ml @@ -44,6 +44,12 @@ module Configs = struct let empty : 'pos t = [] + let merge : 'pos t -> 'pos t -> 'pos t = fun xs ys -> + let rec go acc = function + | [] -> acc + | (c :: xs) -> go (c :: acc) xs in + go ys xs + let find : (('pos, 'kind) config -> 'a option) -> 'pos t -> 'a option = fun finder configs -> let rec go : 'pos t -> 'a option = function diff --git a/src/lib_typedesc/type_desc.mli b/src/lib_typedesc/type_desc.mli index bd9282e..ea8a7d1 100644 --- a/src/lib_typedesc/type_desc.mli +++ b/src/lib_typedesc/type_desc.mli @@ -47,6 +47,8 @@ module Configs : sig val find : (('pos, 'kind) config -> 'a option) -> 'pos t -> 'a option (** Returns the result of the appropriate conversion if found, else [None]. *) + val merge : ([< pos] as 'pos) t -> 'pos t -> 'pos t + val find_or_default : default:'a -> (('pos, 'kind) config -> 'a option) -> 'pos t -> 'a (** Returns the result of the appropriate conversion if found, else the default value. *)