Merge pull request #414 from kxcinc/merge-anz-commits

incorporate some commits

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

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

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

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. *)