From ad90fadf5ec0c1e8780756ee20235e6e55385890 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 4 Jun 2018 09:21:04 +0800 Subject: [PATCH] Data_encoding: use more inline records in sums --- src/lib_data_encoding/binary_length.ml | 40 +++--- src/lib_data_encoding/binary_reader.ml | 38 +++--- src/lib_data_encoding/binary_stream_reader.ml | 38 +++--- src/lib_data_encoding/binary_writer.ml | 18 +-- src/lib_data_encoding/encoding.ml | 90 +++++++------ src/lib_data_encoding/encoding.mli | 34 +++-- src/lib_data_encoding/json.ml | 118 +++++++++--------- 7 files changed, 203 insertions(+), 173 deletions(-) diff --git a/src/lib_data_encoding/binary_length.ml b/src/lib_data_encoding/binary_length.ml index 338b11331..230977ed8 100644 --- a/src/lib_data_encoding/binary_length.ml +++ b/src/lib_data_encoding/binary_length.ml @@ -41,29 +41,26 @@ let rec length : type x. x Encoding.t -> x -> int = | String `Fixed n -> n | String_enum (_, arr) -> Binary_size.integer_to_size @@ Binary_size.enum_size arr - | Objs (`Fixed n, _, _) -> n - | Tups (`Fixed n, _, _) -> n - | Union (`Fixed n, _, _) -> n + | Objs { kind = `Fixed n } -> n + | Tups { kind = `Fixed n } -> n + | Union { kind = `Fixed n } -> n (* Dynamic *) - | Objs (`Dynamic, e1, e2) -> + | Objs { kind = `Dynamic ; left ; right } -> let (v1, v2) = value in - length e1 v1 + length e2 v2 - | Tups (`Dynamic, e1, e2) -> + length left v1 + length right v2 + | Tups { kind = `Dynamic ; left ; right } -> let (v1, v2) = value in - length e1 v1 + length e2 v2 - | Union (`Dynamic, sz, cases) -> + length left v1 + length right v2 + | Union { kind = `Dynamic ; tag_size ; cases } -> let rec length_case = function | [] -> raise (Write_error No_case_matched) | Case { tag = Json_only } :: tl -> length_case tl | Case { encoding = e ; proj ; _ } :: tl -> match proj value with | None -> length_case tl - | Some value -> - let tag_size = Binary_size.tag_size sz in - tag_size + length e value in + | Some value -> Binary_size.tag_size tag_size + length e value in length_case cases - | Mu (`Dynamic, _name, _, _, self) -> - length (self e) value + | Mu { kind = `Dynamic ; fix } -> length (fix e) value | Obj (Opt { kind = `Dynamic ; encoding = e }) -> begin match value with | None -> 1 @@ -81,30 +78,27 @@ let rec length : type x. x Encoding.t -> x -> int = List.fold_left (fun acc v -> length e v + acc) 0 value - | Objs (`Variable, e1, e2) -> + | Objs { kind = `Variable ; left ; right } -> let (v1, v2) = value in - length e1 v1 + length e2 v2 - | Tups (`Variable, e1, e2) -> + length left v1 + length right v2 + | Tups { kind = `Variable ; left ; right } -> let (v1, v2) = value in - length e1 v1 + length e2 v2 + length left v1 + length right v2 | Obj (Opt { kind = `Variable ; encoding = e }) -> begin match value with | None -> 0 | Some value -> length e value end - | Union (`Variable, sz, cases) -> + | Union { kind = `Variable ; tag_size ; cases } -> let rec length_case = function | [] -> raise (Write_error No_case_matched) | Case { tag = Json_only } :: tl -> length_case tl | Case { encoding = e ; proj ; _ } :: tl -> match proj value with | None -> length_case tl - | Some value -> - let tag_size = Binary_size.tag_size sz in - tag_size + length e value in + | Some value -> Binary_size.tag_size tag_size + length e value in length_case cases - | Mu (`Variable, _name, _, _, self) -> - length (self e) value + | Mu { kind = `Variable ; fix } -> length (fix e) value (* Recursive*) | Obj (Req { encoding = e }) -> length e value | Obj (Dft { encoding = e }) -> length e value diff --git a/src/lib_data_encoding/binary_reader.ml b/src/lib_data_encoding/binary_reader.ml index a496483a1..e0e916933 100644 --- a/src/lib_data_encoding/binary_reader.ml +++ b/src/lib_data_encoding/binary_reader.ml @@ -203,35 +203,35 @@ let rec read_rec : type ret. ret Encoding.t -> state -> ret None else Some (read_rec e state) - | Objs (`Fixed sz, e1, e2) -> + | Objs { kind = `Fixed sz ; left ; right } -> ignore (check_remaining_bytes state sz : int) ; ignore (check_allowed_bytes state sz : int option) ; - let left = read_rec e1 state in - let right = read_rec e2 state in + let left = read_rec left state in + let right = read_rec right state in (left, right) - | Objs (`Dynamic, e1, e2) -> - let left = read_rec e1 state in - let right = read_rec e2 state in + | Objs { kind = `Dynamic ; left ; right } -> + let left = read_rec left state in + let right = read_rec right state in (left, right) - | (Objs (`Variable, e1, e2)) -> - read_variable_pair e1 e2 state + | Objs { kind = `Variable ; left ; right } -> + read_variable_pair left right state | Tup e -> read_rec e state - | Tups (`Fixed sz, e1, e2) -> + | Tups { kind = `Fixed sz ; left ; right } -> ignore (check_remaining_bytes state sz : int) ; ignore (check_allowed_bytes state sz : int option) ; - let left = read_rec e1 state in - let right = read_rec e2 state in + let left = read_rec left state in + let right = read_rec right state in (left, right) - | Tups (`Dynamic, e1, e2) -> - let left = read_rec e1 state in - let right = read_rec e2 state in + | Tups { kind = `Dynamic ; left ; right } -> + let left = read_rec left state in + let right = read_rec right state in (left, right) - | (Tups (`Variable, e1, e2)) -> - read_variable_pair e1 e2 state + | Tups { kind = `Variable ; left ; right } -> + read_variable_pair left right state | Conv { inj ; encoding } -> inj (read_rec encoding state) - | Union (_, sz, cases) -> - let ctag = Atom.tag sz state in + | Union { tag_size ; cases } -> + let ctag = Atom.tag tag_size state in let Case { encoding ; inj } = try List.find @@ -272,7 +272,7 @@ let rec read_rec : type ret. ret Encoding.t -> state -> ret v | Describe { encoding = e } -> read_rec e state | Splitted { encoding = e } -> read_rec e state - | Mu (_, _, _, _, self) -> read_rec (self e) state + | Mu { fix } -> read_rec (fix e) state | Delayed f -> read_rec (f ()) state diff --git a/src/lib_data_encoding/binary_stream_reader.ml b/src/lib_data_encoding/binary_stream_reader.ml index a522b4615..a5828f196 100644 --- a/src/lib_data_encoding/binary_stream_reader.ml +++ b/src/lib_data_encoding/binary_stream_reader.ml @@ -268,36 +268,36 @@ let rec read_rec else read_rec e state @@ fun (v, state) -> k (Some v, state) - | Objs (`Fixed sz, e1, e2) -> + | Objs { kind = `Fixed sz ; left ; right } -> ignore (check_remaining_bytes state sz : int option) ; ignore (check_allowed_bytes state sz : int option) ; - read_rec e1 state @@ fun (left, state) -> - read_rec e2 state @@ fun (right, state) -> + read_rec left state @@ fun (left, state) -> + read_rec right state @@ fun (right, state) -> k ((left, right), state) - | Objs (`Dynamic, e1, e2) -> - read_rec e1 state @@ fun (left, state) -> - read_rec e2 state @@ fun (right, state) -> + | Objs { kind = `Dynamic ; left ; right } -> + read_rec left state @@ fun (left, state) -> + read_rec right state @@ fun (right, state) -> k ((left, right), state) - | (Objs (`Variable, e1, e2)) -> - read_variable_pair e1 e2 state k + | Objs { kind = `Variable ; left ; right } -> + read_variable_pair left right state k | Tup e -> read_rec e state k - | Tups (`Fixed sz, e1, e2) -> + | Tups { kind = `Fixed sz ; left ; right } -> ignore (check_remaining_bytes state sz : int option) ; ignore (check_allowed_bytes state sz : int option) ; - read_rec e1 state @@ fun (left, state) -> - read_rec e2 state @@ fun (right, state) -> + read_rec left state @@ fun (left, state) -> + read_rec right state @@ fun (right, state) -> k ((left, right), state) - | Tups (`Dynamic, e1, e2) -> - read_rec e1 state @@ fun (left, state) -> - read_rec e2 state @@ fun (right, state) -> + | Tups { kind = `Dynamic ; left ; right } -> + read_rec left state @@ fun (left, state) -> + read_rec right state @@ fun (right, state) -> k ((left, right), state) - | (Tups (`Variable, e1, e2)) -> - read_variable_pair e1 e2 state k + | Tups { kind = `Variable ; left ; right } -> + read_variable_pair left right state k | Conv { inj ; encoding } -> read_rec encoding state @@ fun (v, state) -> k (inj v, state) - | Union (_, sz, cases) -> begin - Atom.tag sz resume state @@ fun (ctag, state) -> + | Union { tag_size ; cases } -> begin + Atom.tag tag_size resume state @@ fun (ctag, state) -> match List.find (function @@ -341,7 +341,7 @@ let rec read_rec k (v, { state with allowed_bytes }) | Describe { encoding = e } -> read_rec e state k | Splitted { encoding = e } -> read_rec e state k - | Mu (_, _, _, _, self) -> read_rec (self e) state k + | Mu { fix } -> read_rec (fix e) state k | Delayed f -> read_rec (f ()) state k and remaining_bytes { remaining_bytes } = diff --git a/src/lib_data_encoding/binary_writer.ml b/src/lib_data_encoding/binary_writer.ml index f9f3b07a9..baf69b51f 100644 --- a/src/lib_data_encoding/binary_writer.ml +++ b/src/lib_data_encoding/binary_writer.ml @@ -238,18 +238,18 @@ let rec write_rec : type a. a Encoding.t -> state -> a -> unit = | Some value -> write_rec e state value end | Obj (Dft { encoding = e }) -> write_rec e state value - | Objs (_, e1, e2) -> + | Objs { left ; right } -> let (v1, v2) = value in - write_rec e1 state v1 ; - write_rec e2 state v2 + write_rec left state v1 ; + write_rec right state v2 | Tup e -> write_rec e state value - | Tups (_, e1, e2) -> + | Tups { left ; right } -> let (v1, v2) = value in - write_rec e1 state v1 ; - write_rec e2 state v2 + write_rec left state v1 ; + write_rec right state v2 | Conv { encoding = e ; proj } -> write_rec e state (proj value) - | Union (_, sz, cases) -> + | Union { tag_size ; cases } -> let rec write_case = function | [] -> raise No_case_matched | Case { tag = Json_only } :: tl -> write_case tl @@ -257,7 +257,7 @@ let rec write_rec : type a. a Encoding.t -> state -> a -> unit = match proj value with | None -> write_case tl | Some value -> - Atom.tag sz state tag ; + Atom.tag tag_size state tag ; write_rec e state value in write_case cases | Dynamic_size { kind ; encoding = e } -> @@ -273,7 +273,7 @@ let rec write_rec : type a. a Encoding.t -> state -> a -> unit = write_with_limit limit e state value | Describe { encoding = e } -> write_rec e state value | Splitted { encoding = e } -> write_rec e state value - | Mu (_, _, _, _, self) -> write_rec (self e) state value + | Mu { fix } -> write_rec (fix e) state value | Delayed f -> write_rec (f ()) state value and write_with_limit : type a. int -> a Encoding.t -> state -> a -> unit = diff --git a/src/lib_data_encoding/encoding.ml b/src/lib_data_encoding/encoding.ml index 8deb42ea3..a275046ad 100644 --- a/src/lib_data_encoding/encoding.ml +++ b/src/lib_data_encoding/encoding.ml @@ -87,28 +87,43 @@ type 'a desc = | Array : 'a t -> 'a array desc | List : 'a t -> 'a list desc | Obj : 'a field -> 'a desc - | Objs : Kind.t * 'a t * 'b t -> ('a * 'b) desc + | Objs : { kind: Kind.t ; left: 'a t ; right: 'b t } -> ('a * 'b) desc | Tup : 'a t -> 'a desc - | Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc - | Union : Kind.t * Binary_size.tag_size * 'a case list -> 'a desc - | Mu : Kind.enum * string * string option * string option * ('a t -> 'a t) -> 'a desc + | Tups : { kind: Kind.t ; left: 'a t ; right: 'b t } -> ('a * 'b) desc + | Union : + { kind: Kind.t ; + tag_size: Binary_size.tag_size ; + cases: 'a case list ; + } -> 'a desc + | Mu : + { kind: Kind.enum ; + name: string ; + title: string option ; + description: string option ; + fix: 'a t -> 'a t ; + } -> 'a desc | Conv : { proj : ('a -> 'b) ; inj : ('b -> 'a) ; encoding : 'b t ; - schema : Json_schema.schema option } -> 'a desc + schema : Json_schema.schema option ; + } -> 'a desc | Describe : { id : string ; title : string option ; description : string option ; - encoding : 'a t } -> 'a desc + encoding : 'a t ; + } -> 'a desc | Splitted : { encoding : 'a t ; json_encoding : 'a Json_encoding.encoding ; - is_obj : bool ; is_tup : bool } -> 'a desc + is_obj : bool ; + is_tup : bool ; + } -> 'a desc | Dynamic_size : { kind : Binary_size.unsigned_integer ; - encoding : 'a t } -> 'a desc + encoding : 'a t ; + } -> 'a desc | Check_size : { limit : int ; encoding : 'a t } -> 'a desc | Delayed : (unit -> 'a t) -> 'a desc @@ -136,7 +151,8 @@ and 'a case = encoding : 'a t ; proj : ('t -> 'a option) ; inj : ('a -> 't) ; - tag : case_tag } -> 't case + tag : case_tag ; + } -> 't case and 'a t = { encoding: 'a desc ; @@ -171,10 +187,10 @@ let rec classify : type a. a t -> Kind.t = fun e -> | String_enum (_, cases) -> `Fixed Binary_size.(integer_to_size @@ enum_size cases) | Obj (Opt { kind }) -> (kind :> Kind.t) - | Objs (kind, _, _) -> kind - | Tups (kind, _, _) -> kind - | Union (kind, _, _) -> (kind :> Kind.t) - | Mu (kind, _, _, _ , _) -> (kind :> Kind.t) + | Objs { kind } -> kind + | Tups { kind } -> kind + | Union { kind } -> (kind :> Kind.t) + | Mu { kind } -> (kind :> Kind.t) (* Variable *) | Ignore -> `Fixed 0 | Array _ -> `Variable @@ -240,13 +256,13 @@ let rec is_zeroable: type t. t encoding -> bool = fun e -> | Obj (Opt { kind = `Variable }) -> true (* optional field ommited *) | Obj (Dft { encoding = e }) -> is_zeroable e (* represented as-is *) | Obj _ -> false - | Objs (_, e1, e2) -> is_zeroable e1 && is_zeroable e2 + | Objs { left ; right } -> is_zeroable left && is_zeroable right | Tup e -> is_zeroable e - | Tups (_, e1, e2) -> is_zeroable e1 && is_zeroable e2 - | Union (_, _, _) -> false (* includes a tag *) + | Tups { left ; right } -> is_zeroable left && is_zeroable right + | Union _ -> false (* includes a tag *) (* other recursive cases: truth propagates *) - | Mu (`Dynamic, _, _, _ ,_) -> false (* size prefix *) - | Mu (`Variable, _, _, _, f) -> is_zeroable (f e) + | Mu { kind = `Dynamic } -> false (* size prefix *) + | Mu { kind = `Variable ; fix } -> is_zeroable (fix e) | Conv { encoding } -> is_zeroable encoding | Describe { encoding } -> is_zeroable encoding | Splitted { encoding } -> is_zeroable encoding @@ -362,11 +378,11 @@ let rec is_obj : type a. a t -> bool = fun e -> | Objs _ (* by construction *) -> true | Conv { encoding = e } -> is_obj e | Dynamic_size { encoding = e } -> is_obj e - | Union (_,_,cases) -> + | Union { cases } -> List.for_all (fun (Case { encoding = e }) -> is_obj e) cases | Empty -> true | Ignore -> true - | Mu (_,_,_,_,self) -> is_obj (self e) + | Mu { fix } -> is_obj (fix e) | Splitted { is_obj } -> is_obj | Delayed f -> is_obj (f ()) | Describe { encoding } -> is_obj encoding @@ -378,17 +394,17 @@ let rec is_tup : type a. a t -> bool = fun e -> | Tups _ (* by construction *) -> true | Conv { encoding = e } -> is_tup e | Dynamic_size { encoding = e } -> is_tup e - | Union (_,_,cases) -> + | Union { cases } -> List.for_all (function Case { encoding = e} -> is_tup e) cases - | Mu (_,_,_,_,self) -> is_tup (self e) + | Mu { fix } -> is_tup (fix e) | Splitted { is_tup } -> is_tup | Delayed f -> is_tup (f ()) | Describe { encoding } -> is_tup encoding | _ -> false -let raw_merge_objs e1 e2 = - let kind = Kind.combine "objects" (classify e1) (classify e2) in - make @@ Objs (kind, e1, e2) +let raw_merge_objs left right = + let kind = Kind.combine "objects" (classify left) (classify right) in + make @@ Objs { kind ; left ; right } let obj1 f1 = make @@ Obj f1 let obj2 f2 f1 = @@ -416,9 +432,9 @@ let merge_objs o1 o2 = else invalid_arg "Json_encoding.merge_objs" -let raw_merge_tups e1 e2 = - let kind = Kind.combine "tuples" (classify e1) (classify e2) in - make @@ Tups (kind, e1, e2) +let raw_merge_tups left right = + let kind = Kind.combine "tuples" (classify left) (classify right) in + make @@ Tups { kind ; left ; right } let tup1 e1 = make @@ Tup e1 let tup2 e2 e1 = @@ -540,7 +556,7 @@ let union ?(tag_size = `Uint8) cases = let kinds = List.map (fun (Case { encoding }) -> classify encoding) cases in let kind = Kind.merge_list tag_size kinds in - make @@ Union (kind, tag_size, cases) + make @@ Union { kind ; tag_size ; cases } let case ?name tag encoding proj inj = Case { name ; encoding ; proj ; inj ; tag } let rec is_nullable: type t. t encoding -> bool = fun e -> @@ -571,9 +587,9 @@ let rec is_nullable: type t. t encoding -> bool = fun e -> | Objs _ -> false | Tup _ -> false | Tups _ -> false - | Union (_, _, cases) -> + | Union { cases } -> List.exists (fun (Case { encoding = e }) -> is_nullable e) cases - | Mu (_, _, _, _, f) -> is_nullable (f e) + | Mu { fix } -> is_nullable (fix e) | Conv { encoding = e } -> is_nullable e | Describe { encoding = e } -> is_nullable e | Splitted { json_encoding } -> Json_encoding.is_nullable json_encoding @@ -596,16 +612,20 @@ let option ty = (function None -> Some () | Some _ -> None) (fun () -> None) ; ] -let mu name ?title ?description self = +let mu name ?title ?description fix = let kind = try - match classify (self (make @@ Mu (`Dynamic, name, title, description, self))) with + let precursor = + make @@ Mu { kind = `Dynamic ; name ; title ; description ; fix } in + match classify @@ fix precursor with | `Fixed _ | `Dynamic -> `Dynamic | `Variable -> raise Exit with Exit | _ (* TODO variability error *) -> - ignore @@ classify (self (make @@ Mu (`Variable, name, title, description, self))) ; + let precursor = + make @@ Mu { kind = `Variable ; name ; title ; description ; fix } in + ignore (classify @@ fix precursor) ; `Variable in - make @@ Mu (kind, name, title, description, self) + make @@ Mu { kind ; name ; title ; description ; fix } let result ok_enc error_enc = union diff --git a/src/lib_data_encoding/encoding.mli b/src/lib_data_encoding/encoding.mli index 6e6167fce..e2556a77a 100644 --- a/src/lib_data_encoding/encoding.mli +++ b/src/lib_data_encoding/encoding.mli @@ -45,28 +45,43 @@ type 'a desc = | Array : 'a t -> 'a array desc | List : 'a t -> 'a list desc | Obj : 'a field -> 'a desc - | Objs : Kind.t * 'a t * 'b t -> ('a * 'b) desc + | Objs : { kind: Kind.t ; left: 'a t ; right: 'b t } -> ('a * 'b) desc | Tup : 'a t -> 'a desc - | Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc - | Union : Kind.t * Binary_size.tag_size * 'a case list -> 'a desc - | Mu : Kind.enum * string * string option * string option * ('a t -> 'a t) -> 'a desc + | Tups : { kind: Kind.t ; left: 'a t ; right: 'b t } -> ('a * 'b) desc + | Union : + { kind: Kind.t ; + tag_size: Binary_size.tag_size ; + cases: 'a case list ; + } -> 'a desc + | Mu : + { kind: Kind.enum ; + name: string ; + title: string option ; + description: string option ; + fix: 'a t -> 'a t ; + } -> 'a desc | Conv : { proj : ('a -> 'b) ; inj : ('b -> 'a) ; encoding : 'b t ; - schema : Json_schema.schema option } -> 'a desc + schema : Json_schema.schema option ; + } -> 'a desc | Describe : { id : string ; title : string option ; description : string option ; - encoding : 'a t } -> 'a desc + encoding : 'a t ; + } -> 'a desc | Splitted : { encoding : 'a t ; json_encoding : 'a Json_encoding.encoding ; - is_obj : bool ; is_tup : bool } -> 'a desc + is_obj : bool ; + is_tup : bool ; + } -> 'a desc | Dynamic_size : { kind : Binary_size.unsigned_integer ; - encoding : 'a t } -> 'a desc + encoding : 'a t ; + } -> 'a desc | Check_size : { limit : int ; encoding : 'a t } -> 'a desc | Delayed : (unit -> 'a t) -> 'a desc @@ -94,7 +109,8 @@ and 'a case = encoding : 'a t ; proj : ('t -> 'a option) ; inj : ('a -> 't) ; - tag : case_tag } -> 't case + tag : case_tag ; + } -> 't case and 'a t = { encoding: 'a desc ; diff --git a/src/lib_data_encoding/json.ml b/src/lib_data_encoding/json.ml index c238312f0..d418ef505 100644 --- a/src/lib_data_encoding/json.ml +++ b/src/lib_data_encoding/json.ml @@ -75,13 +75,13 @@ let bytes_jsont = create { title = None ; description = None ; - default = None; - enum = None; + default = None ; + enum = None ; kind = String { - pattern = Some "^[a-zA-Z0-9]+$"; - min_length = 0; - max_length = None; - }; + pattern = Some "^[a-zA-Z0-9]+$" ; + min_length = 0 ; + max_length = None ; + } ; format = None ; id = None } in conv ~schema @@ -97,27 +97,27 @@ let rec lift_union : type a. a Encoding.t -> a Encoding.t = fun e -> match e.encoding with | Conv { proj ; inj ; encoding = e ; schema } -> begin match lift_union e with - | { encoding = Union (kind, tag, cases) } -> - make @@ - Union (kind, tag, - List.map - (fun (Case { name ; encoding ; proj = proj' ; inj = inj' ; tag }) -> - Case { encoding ; - name ; - proj = (fun x -> proj' (proj x)); - inj = (fun x -> inj (inj' x)) ; - tag }) - cases) + | { encoding = Union { kind ; tag_size ; cases } } -> + let cases = + List.map + (fun (Case { name ; encoding ; proj = proj' ; inj = inj' ; tag }) -> + Case { encoding ; + name ; + proj = (fun x -> proj' (proj x)) ; + inj = (fun x -> inj (inj' x)) ; + tag }) + cases in + make @@ Union { kind ; tag_size ; cases } | e -> make @@ Conv { proj ; inj ; encoding = e ; schema } end - | Objs (p, e1, e2) -> + | Objs { kind ; left ; right } -> lift_union_in_pair - { build = fun p e1 e2 -> make @@ Objs (p, e1, e2) } - p e1 e2 - | Tups (p, e1, e2) -> + { build = fun kind left right -> make @@ Objs { kind ; left ; right } } + kind left right + | Tups { kind ; left ; right } -> lift_union_in_pair - { build = fun p e1 e2 -> make @@ Tups (p, e1, e2) } - p e1 e2 + { build = fun kind left right -> make @@ Tups { kind ; left ; right } } + kind left right | _ -> e and lift_union_in_pair @@ -125,34 +125,34 @@ and lift_union_in_pair = fun b p e1 e2 -> let open Encoding in match lift_union e1, lift_union e2 with - | e1, { encoding = Union (_kind, tag, cases) } -> - make @@ - Union (`Dynamic (* ignored *), tag, - List.map - (fun (Case { name ; encoding = e2 ; proj ; inj ; tag }) -> - Case { encoding = lift_union_in_pair b p e1 e2 ; - name ; - proj = (fun (x, y) -> - match proj y with - | None -> None - | Some y -> Some (x, y)) ; - inj = (fun (x, y) -> (x, inj y)) ; - tag }) - cases) - | { encoding = Union (_kind, tag, cases) }, e2 -> - make @@ - Union (`Dynamic (* ignored *), tag, - List.map - (fun (Case { name ; encoding = e1 ; proj ; inj ; tag }) -> - Case { encoding = lift_union_in_pair b p e1 e2 ; - name ; - proj = (fun (x, y) -> - match proj x with - | None -> None - | Some x -> Some (x, y)) ; - inj = (fun (x, y) -> (inj x, y)) ; - tag }) - cases) + | e1, { encoding = Union { tag_size ; cases } } -> + let cases = + List.map + (fun (Case { name ; encoding = e2 ; proj ; inj ; tag }) -> + Case { encoding = lift_union_in_pair b p e1 e2 ; + name ; + proj = (fun (x, y) -> + match proj y with + | None -> None + | Some y -> Some (x, y)) ; + inj = (fun (x, y) -> (x, inj y)) ; + tag }) + cases in + make @@ Union { kind = `Dynamic (* ignored *) ; tag_size ; cases } + | { encoding = Union { tag_size ; cases } }, e2 -> + let cases = + List.map + (fun (Case { name ; encoding = e1 ; proj ; inj ; tag }) -> + Case { encoding = lift_union_in_pair b p e1 e2 ; + name ; + proj = (fun (x, y) -> + match proj x with + | None -> None + | Some x -> Some (x, y)) ; + inj = (fun (x, y) -> (inj x, y)) ; + tag }) + cases in + make @@ Union { kind = `Dynamic (* ignored *) ; tag_size ; cases } | e1, e2 -> b.build p e1 e2 let rec json : type a. a Encoding.desc -> a Json_encoding.encoding = @@ -175,7 +175,7 @@ let rec json : type a. a Encoding.desc -> a Json_encoding.encoding = | Z -> z_encoding | Bool -> bool | Float -> float - | RangedFloat { minimum; maximum } -> ranged_float ~minimum ~maximum "rangedFloat" + | RangedFloat { minimum ; maximum } -> ranged_float ~minimum ~maximum "rangedFloat" | String (`Fixed expected) -> let check s = let found = String.length s in @@ -202,17 +202,17 @@ let rec json : type a. a Encoding.desc -> a Json_encoding.encoding = | Array e -> array (get_json e) | List e -> list (get_json e) | Obj f -> obj1 (field_json f) - | Objs (_, e1, e2) -> - merge_objs (get_json e1) (get_json e2) + | Objs { left ; right } -> + merge_objs (get_json left) (get_json right) | Tup e -> tup1 (get_json e) - | Tups (_, e1, e2) -> - merge_tups (get_json e1) (get_json e2) + | Tups { left ; right } -> + merge_tups (get_json left) (get_json right) | Conv { proj ; inj ; encoding = e ; schema } -> conv ?schema proj inj (get_json e) | Describe { id ; title ; description ; encoding = e } -> def id ?title ?description (get_json e) - | Mu (_, name, _, _, self) as ty -> - mu name (fun json_encoding -> get_json @@ self (make ~json_encoding ty)) - | Union (_tag_size, _, cases) -> union (List.map case_json cases) + | Mu { name ; fix } as ty -> + mu name (fun json_encoding -> get_json @@ fix (make ~json_encoding ty)) + | Union { cases } -> union (List.map case_json cases) | Splitted { json_encoding } -> json_encoding | Dynamic_size { encoding = e } -> get_json e | Check_size { encoding } -> get_json encoding