diff --git a/vendors/ocplib-json-typed/lib_json_typed/json_encoding.ml b/vendors/ocplib-json-typed/lib_json_typed/json_encoding.ml index eb6508f73..408f37f8a 100644 --- a/vendors/ocplib-json-typed/lib_json_typed/json_encoding.ml +++ b/vendors/ocplib-json-typed/lib_json_typed/json_encoding.ml @@ -69,7 +69,9 @@ type _ encoding = | Tups : 'a encoding * 'b encoding -> ('a * 'b) encoding | Custom : 't repr_agnostic_custom * Json_schema.schema -> 't encoding | Conv : ('a -> 'b) * ('b -> 'a) * 'b encoding * Json_schema.schema option -> 'a encoding - | Describe : string option * string option * 'a encoding -> 'a encoding + | Describe : { title: string option ; + description: string option ; + encoding: 'a encoding } -> 'a encoding | Mu : string * ('a encoding -> 'a encoding) -> 'a encoding | Union : 't case list -> 't encoding @@ -123,7 +125,7 @@ module Make (Repr : Json_repr.Repr) = struct if float < minimum || float > maximum then invalid_arg err ; Repr.repr (`Float float)) | Float None -> (fun float -> Repr.repr (`Float float)) - | Describe (_, _, t) -> construct t + | Describe { encoding = t } -> construct t | Custom ({ write }, _) -> (fun (j : t) -> write (module Repr) j) | Conv (ffrom, _, t, _) -> (fun v -> construct t (ffrom v)) | Mu (name, self) -> construct (self (Mu (name, self))) @@ -215,7 +217,7 @@ module Make (Repr : Json_repr.Repr) = struct raise (Cannot_destruct ([], exn)) else f | k -> raise (unexpected k "float")) - | Describe (_, _, t) -> destruct t + | Describe { encoding = t } -> destruct t | Custom ({ read }, _) -> read (module Repr) | Conv (_, fto, t, _) -> (fun v -> fto (destruct t v)) | Mu (name, self) -> destruct (self (Mu (name, self))) @@ -294,7 +296,7 @@ module Make (Repr : Json_repr.Repr) = struct let r, i = destruct_tup i t in (fun arr -> fto (r arr)), i | Mu (_, self) as mu -> destruct_tup i (self mu) - | Describe (_, _, enc) -> destruct_tup i enc + | Describe { encoding } -> destruct_tup i encoding | _ -> invalid_arg "Json_encoding.destruct: consequence of bad merge_tups" and destruct_obj : type t. t encoding -> (string * Repr.value) list -> t * (string * Repr.value) list * bool @@ -347,7 +349,7 @@ module Make (Repr : Json_repr.Repr) = struct let r, rest, ign = d fields in fto r, rest, ign) | Mu (_, self) as mu -> destruct_obj (self mu) - | Describe (_, _, enc) -> destruct_obj enc + | Describe { encoding } -> destruct_obj encoding | Union cases -> (fun fields -> let rec do_cases errs = function @@ -403,7 +405,7 @@ let schema encoding = (fun (Case (o, _, _)) -> object_schema o) cases) | Mu (_, self) as mu -> object_schema (self mu) - | Describe (_, _, t) -> object_schema t + | Describe { encoding = t } -> object_schema t | Conv (_, _, _, Some _) (* FIXME: We could do better *) | _ -> invalid_arg "Json_encoding.schema: consequence of bad merge_objs" and array_schema @@ -413,7 +415,7 @@ let schema encoding = | Tup t -> [ schema t ] | Tups (t1, t2) -> array_schema t1 @ array_schema t2 | Mu (_, self) as mu -> array_schema (self mu) - | Describe (_, _, t) -> array_schema t + | Describe { encoding = t } -> array_schema t | Conv (_, _, _, Some _) (* FIXME: We could do better *) | _ -> invalid_arg "Json_encoding.schema: consequence of bad merge_tups" and schema @@ -438,12 +440,16 @@ let schema encoding = minimum = Some (minimum, `Inclusive) ; maximum = Some (maximum, `Inclusive) }) | Float None -> element (Number numeric_specs) - | Describe (None, None, t) -> schema t - | Describe (Some _ as title, None, t) -> + | Describe { title = None ; description = None ; + encoding = t } -> schema t + | Describe { title = Some _ as title ; description = None ; + encoding = t } -> { (schema t) with title } - | Describe (None, (Some _ as description), t) -> + | Describe { title = None ; description = Some _ as description ; + encoding = t } -> { (schema t) with description } - | Describe (Some _ as title, (Some _ as description), t) -> + | Describe { title = Some _ as title ; description = Some _ as description ; + encoding = t } -> { (schema t) with title ; description } | Custom (_, s) -> sch := fst (merge_definitions (!sch, s)) ; @@ -507,9 +513,9 @@ let schema encoding = (*-- utility wrappers over the GADT ------------------------------------------*) -let req ?title ?description n t = Req (n, Describe (title, description, t)) -let opt ?title ?description n t = Opt (n, Describe (title, description, t)) -let dft ?title ?description n t d = Dft (n, Describe (title, description, t), d) +let req ?title ?description n t = Req (n, Describe { title ; encoding = t ; description }) +let opt ?title ?description n t = Opt (n, Describe { title ; encoding = t; description }) +let dft ?title ?description n t d = Dft (n, Describe { title ; encoding = t ; description }, d) let mu name self = Mu (name, self) let null = Null @@ -666,7 +672,7 @@ let tup10 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 = let repr_agnostic_custom { write ; read } ~schema = Custom ({ write ; read }, schema) -let describe ?title ?description t = Describe (title, description, t) +let describe ?title ?description t = Describe { title ; encoding = t ; description } let constant s = Constant s @@ -741,7 +747,7 @@ let rec is_nullable: type t. t encoding -> bool = function | Conv (_, _, t, _) -> is_nullable t | Union cases -> List.exists (fun (Case (t, _, _)) -> is_nullable t) cases - | Describe (_, _, t) -> is_nullable t + | Describe { encoding = t } -> is_nullable t | Mu (_, f) as self -> is_nullable (f self) | Custom (_, sch) -> Json_schema.is_nullable sch @@ -784,7 +790,7 @@ let merge_tups t1 t2 = | Tups _ (* by construction *) -> true | Conv (_, _, t, None) -> is_tup t | Mu (_name, self) as mu -> is_tup (self mu) - | Describe (_, _, t) -> is_tup t + | Describe { encoding = t } -> is_tup t | _ -> false in if is_tup t1 && is_tup t2 then Tups (t1, t2) @@ -804,7 +810,7 @@ let merge_objs o1 o2 = | Ignore -> true | Union cases -> List.for_all (fun (Case (o, _, _)) -> is_obj o) cases | Mu (_name, self) as mu -> is_obj (self mu) - | Describe (_, _, t) -> is_obj t + | Describe { encoding = t } -> is_obj t | _ -> false in if is_obj o1 && is_obj o2 then Objs (o1, o2)