balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Data_encoding: use more inline records in sums

Browse Source
This commit is contained in:
Raphaël Proust 2018-06-04 09:21:04 +08:00 committed by Grégoire Henry
parent f647404739
commit ad90fadf5e
7 changed files with 203 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
src/lib_data_encoding/binary_length.ml
View File

@ -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

38
src/lib_data_encoding/binary_reader.ml
View File

@ -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

38
src/lib_data_encoding/binary_stream_reader.ml
View File

@ -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 } =

18
src/lib_data_encoding/binary_writer.ml
View File

@ -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 =

90
src/lib_data_encoding/encoding.ml
View File

@ -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

34
src/lib_data_encoding/encoding.mli
View File

@ -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 ;

118
src/lib_data_encoding/json.ml
View File

@ -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