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 `Fixed n -> n
| String_enum (_, arr) -> | String_enum (_, arr) ->
Binary_size.integer_to_size @@ Binary_size.enum_size arr Binary_size.integer_to_size @@ Binary_size.enum_size arr
| Objs (`Fixed n, _, _) -> n | Objs { kind = `Fixed n } -> n
| Tups (`Fixed n, _, _) -> n | Tups { kind = `Fixed n } -> n
| Union (`Fixed n, _, _) -> n | Union { kind = `Fixed n } -> n
(* Dynamic *) (* Dynamic *)
| Objs (`Dynamic, e1, e2) -> | Objs { kind = `Dynamic ; left ; right } ->
let (v1, v2) = value in let (v1, v2) = value in
length e1 v1 + length e2 v2 length left v1 + length right v2
| Tups (`Dynamic, e1, e2) -> | Tups { kind = `Dynamic ; left ; right } ->
let (v1, v2) = value in let (v1, v2) = value in
length e1 v1 + length e2 v2 length left v1 + length right v2
| Union (`Dynamic, sz, cases) -> | Union { kind = `Dynamic ; tag_size ; cases } ->
let rec length_case = function let rec length_case = function
| [] -> raise (Write_error No_case_matched) | [] -> raise (Write_error No_case_matched)
| Case { tag = Json_only } :: tl -> length_case tl | Case { tag = Json_only } :: tl -> length_case tl
| Case { encoding = e ; proj ; _ } :: tl -> | Case { encoding = e ; proj ; _ } :: tl ->
match proj value with match proj value with
| None -> length_case tl | None -> length_case tl
| Some value -> | Some value -> Binary_size.tag_size tag_size + length e value in
let tag_size = Binary_size.tag_size sz in
tag_size + length e value in
length_case cases length_case cases
| Mu (`Dynamic, _name, _, _, self) -> | Mu { kind = `Dynamic ; fix } -> length (fix e) value
length (self e) value
| Obj (Opt { kind = `Dynamic ; encoding = e }) -> begin | Obj (Opt { kind = `Dynamic ; encoding = e }) -> begin
match value with match value with
| None -> 1 | None -> 1
@ -81,30 +78,27 @@ let rec length : type x. x Encoding.t -> x -> int =
List.fold_left List.fold_left
(fun acc v -> length e v + acc) (fun acc v -> length e v + acc)
0 value 0 value
| Objs (`Variable, e1, e2) -> | Objs { kind = `Variable ; left ; right } ->
let (v1, v2) = value in let (v1, v2) = value in
length e1 v1 + length e2 v2 length left v1 + length right v2
| Tups (`Variable, e1, e2) -> | Tups { kind = `Variable ; left ; right } ->
let (v1, v2) = value in let (v1, v2) = value in
length e1 v1 + length e2 v2 length left v1 + length right v2
| Obj (Opt { kind = `Variable ; encoding = e }) -> begin | Obj (Opt { kind = `Variable ; encoding = e }) -> begin
match value with match value with
| None -> 0 | None -> 0
| Some value -> length e value | Some value -> length e value
end end
| Union (`Variable, sz, cases) -> | Union { kind = `Variable ; tag_size ; cases } ->
let rec length_case = function let rec length_case = function
| [] -> raise (Write_error No_case_matched) | [] -> raise (Write_error No_case_matched)
| Case { tag = Json_only } :: tl -> length_case tl | Case { tag = Json_only } :: tl -> length_case tl
| Case { encoding = e ; proj ; _ } :: tl -> | Case { encoding = e ; proj ; _ } :: tl ->
match proj value with match proj value with
| None -> length_case tl | None -> length_case tl
| Some value -> | Some value -> Binary_size.tag_size tag_size + length e value in
let tag_size = Binary_size.tag_size sz in
tag_size + length e value in
length_case cases length_case cases
| Mu (`Variable, _name, _, _, self) -> | Mu { kind = `Variable ; fix } -> length (fix e) value
length (self e) value
(* Recursive*) (* Recursive*)
| Obj (Req { encoding = e }) -> length e value | Obj (Req { encoding = e }) -> length e value
| Obj (Dft { 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 None
else else
Some (read_rec e state) 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_remaining_bytes state sz : int) ;
ignore (check_allowed_bytes state sz : int option) ; ignore (check_allowed_bytes state sz : int option) ;
let left = read_rec e1 state in let left = read_rec left state in
let right = read_rec e2 state in let right = read_rec right state in
(left, right) (left, right)
| Objs (`Dynamic, e1, e2) -> | Objs { kind = `Dynamic ; left ; right } ->
let left = read_rec e1 state in let left = read_rec left state in
let right = read_rec e2 state in let right = read_rec right state in
(left, right) (left, right)
| (Objs (`Variable, e1, e2)) -> | Objs { kind = `Variable ; left ; right } ->
read_variable_pair e1 e2 state read_variable_pair left right state
| Tup e -> read_rec e 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_remaining_bytes state sz : int) ;
ignore (check_allowed_bytes state sz : int option) ; ignore (check_allowed_bytes state sz : int option) ;
let left = read_rec e1 state in let left = read_rec left state in
let right = read_rec e2 state in let right = read_rec right state in
(left, right) (left, right)
| Tups (`Dynamic, e1, e2) -> | Tups { kind = `Dynamic ; left ; right } ->
let left = read_rec e1 state in let left = read_rec left state in
let right = read_rec e2 state in let right = read_rec right state in
(left, right) (left, right)
| (Tups (`Variable, e1, e2)) -> | Tups { kind = `Variable ; left ; right } ->
read_variable_pair e1 e2 state read_variable_pair left right state
| Conv { inj ; encoding } -> | Conv { inj ; encoding } ->
inj (read_rec encoding state) inj (read_rec encoding state)
| Union (_, sz, cases) -> | Union { tag_size ; cases } ->
let ctag = Atom.tag sz state in let ctag = Atom.tag tag_size state in
let Case { encoding ; inj } = let Case { encoding ; inj } =
try try
List.find List.find
@ -272,7 +272,7 @@ let rec read_rec : type ret. ret Encoding.t -> state -> ret
v v
| Describe { encoding = e } -> read_rec e state | Describe { encoding = e } -> read_rec e state
| Splitted { 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 | 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 else
read_rec e state @@ fun (v, state) -> read_rec e state @@ fun (v, state) ->
k (Some 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_remaining_bytes state sz : int option) ;
ignore (check_allowed_bytes state sz : int option) ; ignore (check_allowed_bytes state sz : int option) ;
read_rec e1 state @@ fun (left, state) -> read_rec left state @@ fun (left, state) ->
read_rec e2 state @@ fun (right, state) -> read_rec right state @@ fun (right, state) ->
k ((left, right), state) k ((left, right), state)
| Objs (`Dynamic, e1, e2) -> | Objs { kind = `Dynamic ; left ; right } ->
read_rec e1 state @@ fun (left, state) -> read_rec left state @@ fun (left, state) ->
read_rec e2 state @@ fun (right, state) -> read_rec right state @@ fun (right, state) ->
k ((left, right), state) k ((left, right), state)
| (Objs (`Variable, e1, e2)) -> | Objs { kind = `Variable ; left ; right } ->
read_variable_pair e1 e2 state k read_variable_pair left right state k
| Tup e -> read_rec e 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_remaining_bytes state sz : int option) ;
ignore (check_allowed_bytes state sz : int option) ; ignore (check_allowed_bytes state sz : int option) ;
read_rec e1 state @@ fun (left, state) -> read_rec left state @@ fun (left, state) ->
read_rec e2 state @@ fun (right, state) -> read_rec right state @@ fun (right, state) ->
k ((left, right), state) k ((left, right), state)
| Tups (`Dynamic, e1, e2) -> | Tups { kind = `Dynamic ; left ; right } ->
read_rec e1 state @@ fun (left, state) -> read_rec left state @@ fun (left, state) ->
read_rec e2 state @@ fun (right, state) -> read_rec right state @@ fun (right, state) ->
k ((left, right), state) k ((left, right), state)
| (Tups (`Variable, e1, e2)) -> | Tups { kind = `Variable ; left ; right } ->
read_variable_pair e1 e2 state k read_variable_pair left right state k
| Conv { inj ; encoding } -> | Conv { inj ; encoding } ->
read_rec encoding state @@ fun (v, state) -> read_rec encoding state @@ fun (v, state) ->
k (inj v, state) k (inj v, state)
| Union (_, sz, cases) -> begin | Union { tag_size ; cases } -> begin
Atom.tag sz resume state @@ fun (ctag, state) -> Atom.tag tag_size resume state @@ fun (ctag, state) ->
match match
List.find List.find
(function (function
@ -341,7 +341,7 @@ let rec read_rec
k (v, { state with allowed_bytes }) k (v, { state with allowed_bytes })
| Describe { encoding = e } -> read_rec e state k | Describe { encoding = e } -> read_rec e state k
| Splitted { 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 | Delayed f -> read_rec (f ()) state k
and remaining_bytes { remaining_bytes } = 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 | Some value -> write_rec e state value
end end
| Obj (Dft { encoding = e }) -> write_rec e state value | Obj (Dft { encoding = e }) -> write_rec e state value
| Objs (_, e1, e2) -> | Objs { left ; right } ->
let (v1, v2) = value in let (v1, v2) = value in
write_rec e1 state v1 ; write_rec left state v1 ;
write_rec e2 state v2 write_rec right state v2
| Tup e -> write_rec e state value | Tup e -> write_rec e state value
| Tups (_, e1, e2) -> | Tups { left ; right } ->
let (v1, v2) = value in let (v1, v2) = value in
write_rec e1 state v1 ; write_rec left state v1 ;
write_rec e2 state v2 write_rec right state v2
| Conv { encoding = e ; proj } -> | Conv { encoding = e ; proj } ->
write_rec e state (proj value) write_rec e state (proj value)
| Union (_, sz, cases) -> | Union { tag_size ; cases } ->
let rec write_case = function let rec write_case = function
| [] -> raise No_case_matched | [] -> raise No_case_matched
| Case { tag = Json_only } :: tl -> write_case tl | 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 match proj value with
| None -> write_case tl | None -> write_case tl
| Some value -> | Some value ->
Atom.tag sz state tag ; Atom.tag tag_size state tag ;
write_rec e state value in write_rec e state value in
write_case cases write_case cases
| Dynamic_size { kind ; encoding = e } -> | 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 write_with_limit limit e state value
| Describe { encoding = e } -> write_rec e state value | Describe { encoding = e } -> write_rec e state value
| Splitted { 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 | Delayed f -> write_rec (f ()) state value
and write_with_limit : type a. int -> a Encoding.t -> state -> a -> unit = 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 | Array : 'a t -> 'a array desc
| List : 'a t -> 'a list desc | List : 'a t -> 'a list desc
| Obj : 'a field -> 'a 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 | Tup : 'a t -> 'a desc
| Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc | Tups : { kind: Kind.t ; left: 'a t ; right: 'b t } -> ('a * 'b) desc
| Union : Kind.t * Binary_size.tag_size * 'a case list -> 'a desc | Union :
| Mu : Kind.enum * string * string option * string option * ('a t -> 'a t) -> 'a desc { 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 : | Conv :
{ proj : ('a -> 'b) ; { proj : ('a -> 'b) ;
inj : ('b -> 'a) ; inj : ('b -> 'a) ;
encoding : 'b t ; encoding : 'b t ;
schema : Json_schema.schema option } -> 'a desc schema : Json_schema.schema option ;
} -> 'a desc
| Describe : | Describe :
{ id : string ; { id : string ;
title : string option ; title : string option ;
description : string option ; description : string option ;
encoding : 'a t } -> 'a desc encoding : 'a t ;
} -> 'a desc
| Splitted : | Splitted :
{ encoding : 'a t ; { encoding : 'a t ;
json_encoding : 'a Json_encoding.encoding ; json_encoding : 'a Json_encoding.encoding ;
is_obj : bool ; is_tup : bool } -> 'a desc is_obj : bool ;
is_tup : bool ;
} -> 'a desc
| Dynamic_size : | Dynamic_size :
{ kind : Binary_size.unsigned_integer ; { kind : Binary_size.unsigned_integer ;
encoding : 'a t } -> 'a desc encoding : 'a t ;
} -> 'a desc
| Check_size : { limit : int ; encoding : 'a t } -> 'a desc | Check_size : { limit : int ; encoding : 'a t } -> 'a desc
| Delayed : (unit -> 'a t) -> 'a desc | Delayed : (unit -> 'a t) -> 'a desc
@ -136,7 +151,8 @@ and 'a case =
encoding : 'a t ; encoding : 'a t ;
proj : ('t -> 'a option) ; proj : ('t -> 'a option) ;
inj : ('a -> 't) ; inj : ('a -> 't) ;
tag : case_tag } -> 't case tag : case_tag ;
} -> 't case
and 'a t = { and 'a t = {
encoding: 'a desc ; encoding: 'a desc ;
@ -171,10 +187,10 @@ let rec classify : type a. a t -> Kind.t = fun e ->
| String_enum (_, cases) -> | String_enum (_, cases) ->
`Fixed Binary_size.(integer_to_size @@ enum_size cases) `Fixed Binary_size.(integer_to_size @@ enum_size cases)
| Obj (Opt { kind }) -> (kind :> Kind.t) | Obj (Opt { kind }) -> (kind :> Kind.t)
| Objs (kind, _, _) -> kind | Objs { kind } -> kind
| Tups (kind, _, _) -> kind | Tups { kind } -> kind
| Union (kind, _, _) -> (kind :> Kind.t) | Union { kind } -> (kind :> Kind.t)
| Mu (kind, _, _, _ , _) -> (kind :> Kind.t) | Mu { kind } -> (kind :> Kind.t)
(* Variable *) (* Variable *)
| Ignore -> `Fixed 0 | Ignore -> `Fixed 0
| Array _ -> `Variable | 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 (Opt { kind = `Variable }) -> true (* optional field ommited *)
| Obj (Dft { encoding = e }) -> is_zeroable e (* represented as-is *) | Obj (Dft { encoding = e }) -> is_zeroable e (* represented as-is *)
| Obj _ -> false | 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 | Tup e -> is_zeroable e
| Tups (_, e1, e2) -> is_zeroable e1 && is_zeroable e2 | Tups { left ; right } -> is_zeroable left && is_zeroable right
| Union (_, _, _) -> false (* includes a tag *) | Union _ -> false (* includes a tag *)
(* other recursive cases: truth propagates *) (* other recursive cases: truth propagates *)
| Mu (`Dynamic, _, _, _ ,_) -> false (* size prefix *) | Mu { kind = `Dynamic } -> false (* size prefix *)
| Mu (`Variable, _, _, _, f) -> is_zeroable (f e) | Mu { kind = `Variable ; fix } -> is_zeroable (fix e)
| Conv { encoding } -> is_zeroable encoding | Conv { encoding } -> is_zeroable encoding
| Describe { encoding } -> is_zeroable encoding | Describe { encoding } -> is_zeroable encoding
| Splitted { 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 | Objs _ (* by construction *) -> true
| Conv { encoding = e } -> is_obj e | Conv { encoding = e } -> is_obj e
| Dynamic_size { 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 List.for_all (fun (Case { encoding = e }) -> is_obj e) cases
| Empty -> true | Empty -> true
| Ignore -> true | Ignore -> true
| Mu (_,_,_,_,self) -> is_obj (self e) | Mu { fix } -> is_obj (fix e)
| Splitted { is_obj } -> is_obj | Splitted { is_obj } -> is_obj
| Delayed f -> is_obj (f ()) | Delayed f -> is_obj (f ())
| Describe { encoding } -> is_obj encoding | Describe { encoding } -> is_obj encoding
@ -378,17 +394,17 @@ let rec is_tup : type a. a t -> bool = fun e ->
| Tups _ (* by construction *) -> true | Tups _ (* by construction *) -> true
| Conv { encoding = e } -> is_tup e | Conv { encoding = e } -> is_tup e
| Dynamic_size { 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 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 | Splitted { is_tup } -> is_tup
| Delayed f -> is_tup (f ()) | Delayed f -> is_tup (f ())
| Describe { encoding } -> is_tup encoding | Describe { encoding } -> is_tup encoding
| _ -> false | _ -> false
let raw_merge_objs e1 e2 = let raw_merge_objs left right =
let kind = Kind.combine "objects" (classify e1) (classify e2) in let kind = Kind.combine "objects" (classify left) (classify right) in
make @@ Objs (kind, e1, e2) make @@ Objs { kind ; left ; right }
let obj1 f1 = make @@ Obj f1 let obj1 f1 = make @@ Obj f1
let obj2 f2 f1 = let obj2 f2 f1 =
@ -416,9 +432,9 @@ let merge_objs o1 o2 =
else else
invalid_arg "Json_encoding.merge_objs" invalid_arg "Json_encoding.merge_objs"
let raw_merge_tups e1 e2 = let raw_merge_tups left right =
let kind = Kind.combine "tuples" (classify e1) (classify e2) in let kind = Kind.combine "tuples" (classify left) (classify right) in
make @@ Tups (kind, e1, e2) make @@ Tups { kind ; left ; right }
let tup1 e1 = make @@ Tup e1 let tup1 e1 = make @@ Tup e1
let tup2 e2 e1 = let tup2 e2 e1 =
@ -540,7 +556,7 @@ let union ?(tag_size = `Uint8) cases =
let kinds = let kinds =
List.map (fun (Case { encoding }) -> classify encoding) cases in List.map (fun (Case { encoding }) -> classify encoding) cases in
let kind = Kind.merge_list tag_size kinds 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 case ?name tag encoding proj inj = Case { name ; encoding ; proj ; inj ; tag }
let rec is_nullable: type t. t encoding -> bool = fun e -> 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 | Objs _ -> false
| Tup _ -> false | Tup _ -> false
| Tups _ -> false | Tups _ -> false
| Union (_, _, cases) -> | Union { cases } ->
List.exists (fun (Case { encoding = e }) -> is_nullable e) 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 | Conv { encoding = e } -> is_nullable e
| Describe { encoding = e } -> is_nullable e | Describe { encoding = e } -> is_nullable e
| Splitted { json_encoding } -> Json_encoding.is_nullable json_encoding | Splitted { json_encoding } -> Json_encoding.is_nullable json_encoding
@ -596,16 +612,20 @@ let option ty =
(function None -> Some () | Some _ -> None) (function None -> Some () | Some _ -> None)
(fun () -> None) ; (fun () -> None) ;
] ]
let mu name ?title ?description self = let mu name ?title ?description fix =
let kind = let kind =
try 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 | `Fixed _ | `Dynamic -> `Dynamic
| `Variable -> raise Exit | `Variable -> raise Exit
with Exit | _ (* TODO variability error *) -> 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 `Variable in
make @@ Mu (kind, name, title, description, self) make @@ Mu { kind ; name ; title ; description ; fix }
let result ok_enc error_enc = let result ok_enc error_enc =
union union

34
src/lib_data_encoding/encoding.mli
View File

@ -45,28 +45,43 @@ type 'a desc =
| Array : 'a t -> 'a array desc | Array : 'a t -> 'a array desc
| List : 'a t -> 'a list desc | List : 'a t -> 'a list desc
| Obj : 'a field -> 'a 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 | Tup : 'a t -> 'a desc
| Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc | Tups : { kind: Kind.t ; left: 'a t ; right: 'b t } -> ('a * 'b) desc
| Union : Kind.t * Binary_size.tag_size * 'a case list -> 'a desc | Union :
| Mu : Kind.enum * string * string option * string option * ('a t -> 'a t) -> 'a desc { 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 : | Conv :
{ proj : ('a -> 'b) ; { proj : ('a -> 'b) ;
inj : ('b -> 'a) ; inj : ('b -> 'a) ;
encoding : 'b t ; encoding : 'b t ;
schema : Json_schema.schema option } -> 'a desc schema : Json_schema.schema option ;
} -> 'a desc
| Describe : | Describe :
{ id : string ; { id : string ;
title : string option ; title : string option ;
description : string option ; description : string option ;
encoding : 'a t } -> 'a desc encoding : 'a t ;
} -> 'a desc
| Splitted : | Splitted :
{ encoding : 'a t ; { encoding : 'a t ;
json_encoding : 'a Json_encoding.encoding ; json_encoding : 'a Json_encoding.encoding ;
is_obj : bool ; is_tup : bool } -> 'a desc is_obj : bool ;
is_tup : bool ;
} -> 'a desc
| Dynamic_size : | Dynamic_size :
{ kind : Binary_size.unsigned_integer ; { kind : Binary_size.unsigned_integer ;
encoding : 'a t } -> 'a desc encoding : 'a t ;
} -> 'a desc
| Check_size : { limit : int ; encoding : 'a t } -> 'a desc | Check_size : { limit : int ; encoding : 'a t } -> 'a desc
| Delayed : (unit -> 'a t) -> 'a desc | Delayed : (unit -> 'a t) -> 'a desc
@ -94,7 +109,8 @@ and 'a case =
encoding : 'a t ; encoding : 'a t ;
proj : ('t -> 'a option) ; proj : ('t -> 'a option) ;
inj : ('a -> 't) ; inj : ('a -> 't) ;
tag : case_tag } -> 't case tag : case_tag ;
} -> 't case
and 'a t = { and 'a t = {
encoding: 'a desc ; encoding: 'a desc ;

118
src/lib_data_encoding/json.ml
View File

@ -75,13 +75,13 @@ let bytes_jsont =
create create
{ title = None ; { title = None ;
description = None ; description = None ;
default = None; default = None ;
enum = None; enum = None ;
kind = String { kind = String {
pattern = Some "^[a-zA-Z0-9]+$"; pattern = Some "^[a-zA-Z0-9]+$" ;
min_length = 0; min_length = 0 ;
max_length = None; max_length = None ;
}; } ;
format = None ; format = None ;
id = None } in id = None } in
conv ~schema conv ~schema
@ -97,27 +97,27 @@ let rec lift_union : type a. a Encoding.t -> a Encoding.t = fun e ->
match e.encoding with match e.encoding with
| Conv { proj ; inj ; encoding = e ; schema } -> begin | Conv { proj ; inj ; encoding = e ; schema } -> begin
match lift_union e with match lift_union e with
| { encoding = Union (kind, tag, cases) } -> | { encoding = Union { kind ; tag_size ; cases } } ->
make @@ let cases =
Union (kind, tag, List.map
List.map (fun (Case { name ; encoding ; proj = proj' ; inj = inj' ; tag }) ->
(fun (Case { name ; encoding ; proj = proj' ; inj = inj' ; tag }) -> Case { encoding ;
Case { encoding ; name ;
name ; proj = (fun x -> proj' (proj x)) ;
proj = (fun x -> proj' (proj x)); inj = (fun x -> inj (inj' x)) ;
inj = (fun x -> inj (inj' x)) ; tag })
tag }) cases in
cases) make @@ Union { kind ; tag_size ; cases }
| e -> make @@ Conv { proj ; inj ; encoding = e ; schema } | e -> make @@ Conv { proj ; inj ; encoding = e ; schema }
end end
| Objs (p, e1, e2) -> | Objs { kind ; left ; right } ->
lift_union_in_pair lift_union_in_pair
{ build = fun p e1 e2 -> make @@ Objs (p, e1, e2) } { build = fun kind left right -> make @@ Objs { kind ; left ; right } }
p e1 e2 kind left right
| Tups (p, e1, e2) -> | Tups { kind ; left ; right } ->
lift_union_in_pair lift_union_in_pair
{ build = fun p e1 e2 -> make @@ Tups (p, e1, e2) } { build = fun kind left right -> make @@ Tups { kind ; left ; right } }
p e1 e2 kind left right
| _ -> e | _ -> e
and lift_union_in_pair and lift_union_in_pair
@ -125,34 +125,34 @@ and lift_union_in_pair
= fun b p e1 e2 -> = fun b p e1 e2 ->
let open Encoding in let open Encoding in
match lift_union e1, lift_union e2 with match lift_union e1, lift_union e2 with
| e1, { encoding = Union (_kind, tag, cases) } -> | e1, { encoding = Union { tag_size ; cases } } ->
make @@ let cases =
Union (`Dynamic (* ignored *), tag, List.map
List.map (fun (Case { name ; encoding = e2 ; proj ; inj ; tag }) ->
(fun (Case { name ; encoding = e2 ; proj ; inj ; tag }) -> Case { encoding = lift_union_in_pair b p e1 e2 ;
Case { encoding = lift_union_in_pair b p e1 e2 ; name ;
name ; proj = (fun (x, y) ->
proj = (fun (x, y) -> match proj y with
match proj y with | None -> None
| None -> None | Some y -> Some (x, y)) ;
| Some y -> Some (x, y)) ; inj = (fun (x, y) -> (x, inj y)) ;
inj = (fun (x, y) -> (x, inj y)) ; tag })
tag }) cases in
cases) make @@ Union { kind = `Dynamic (* ignored *) ; tag_size ; cases }
| { encoding = Union (_kind, tag, cases) }, e2 -> | { encoding = Union { tag_size ; cases } }, e2 ->
make @@ let cases =
Union (`Dynamic (* ignored *), tag, List.map
List.map (fun (Case { name ; encoding = e1 ; proj ; inj ; tag }) ->
(fun (Case { name ; encoding = e1 ; proj ; inj ; tag }) -> Case { encoding = lift_union_in_pair b p e1 e2 ;
Case { encoding = lift_union_in_pair b p e1 e2 ; name ;
name ; proj = (fun (x, y) ->
proj = (fun (x, y) -> match proj x with
match proj x with | None -> None
| None -> None | Some x -> Some (x, y)) ;
| Some x -> Some (x, y)) ; inj = (fun (x, y) -> (inj x, y)) ;
inj = (fun (x, y) -> (inj x, y)) ; tag })
tag }) cases in
cases) make @@ Union { kind = `Dynamic (* ignored *) ; tag_size ; cases }
| e1, e2 -> b.build p e1 e2 | e1, e2 -> b.build p e1 e2
let rec json : type a. a Encoding.desc -> a Json_encoding.encoding = 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 | Z -> z_encoding
| Bool -> bool | Bool -> bool
| Float -> float | Float -> float
| RangedFloat { minimum; maximum } -> ranged_float ~minimum ~maximum "rangedFloat" | RangedFloat { minimum ; maximum } -> ranged_float ~minimum ~maximum "rangedFloat"
| String (`Fixed expected) -> | String (`Fixed expected) ->
let check s = let check s =
let found = String.length s in 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) | Array e -> array (get_json e)
| List e -> list (get_json e) | List e -> list (get_json e)
| Obj f -> obj1 (field_json f) | Obj f -> obj1 (field_json f)
| Objs (_, e1, e2) -> | Objs { left ; right } ->
merge_objs (get_json e1) (get_json e2) merge_objs (get_json left) (get_json right)
| Tup e -> tup1 (get_json e) | Tup e -> tup1 (get_json e)
| Tups (_, e1, e2) -> | Tups { left ; right } ->
merge_tups (get_json e1) (get_json e2) merge_tups (get_json left) (get_json right)
| Conv { proj ; inj ; encoding = e ; schema } -> conv ?schema proj inj (get_json e) | Conv { proj ; inj ; encoding = e ; schema } -> conv ?schema proj inj (get_json e)
| Describe { id ; title ; description ; encoding = e } -> | Describe { id ; title ; description ; encoding = e } ->
def id ?title ?description (get_json e) def id ?title ?description (get_json e)
| Mu (_, name, _, _, self) as ty -> | Mu { name ; fix } as ty ->
mu name (fun json_encoding -> get_json @@ self (make ~json_encoding ty)) mu name (fun json_encoding -> get_json @@ fix (make ~json_encoding ty))
| Union (_tag_size, _, cases) -> union (List.map case_json cases) | Union { cases } -> union (List.map case_json cases)
| Splitted { json_encoding } -> json_encoding | Splitted { json_encoding } -> json_encoding
| Dynamic_size { encoding = e } -> get_json e | Dynamic_size { encoding = e } -> get_json e
| Check_size { encoding } -> get_json encoding | Check_size { encoding } -> get_json encoding