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

Data_encoding: Make tags on unions mandatory

Browse Source
This commit is contained in:
Milo Davis 2017-11-24 17:19:38 +01:00 committed by Benjamin Canou
parent abd5bb22a8
commit dc7a023e22
30 changed files with 361 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
lib_base/test_network_status.ml
View File

@ -23,11 +23,11 @@ type t =
let encoding = let encoding =
let open Data_encoding in let open Data_encoding in
union [ union [
case ~tag:0 case (Tag 0)
(obj1 (req "status" (constant "not_running"))) (obj1 (req "status" (constant "not_running")))
(function Not_running -> Some () | _ -> None) (function Not_running -> Some () | _ -> None)
(fun () -> Not_running) ; (fun () -> Not_running) ;
case ~tag:1 case (Tag 1)
(obj3 (obj3
(req "status" (constant "forking")) (req "status" (constant "forking"))
(req "protocol" Protocol_hash.encoding) (req "protocol" Protocol_hash.encoding)
@ -38,7 +38,7 @@ let encoding =
| _ -> None) | _ -> None)
(fun ((), protocol, expiration) -> (fun ((), protocol, expiration) ->
Forking { protocol ; expiration }) ; Forking { protocol ; expiration }) ;
case ~tag:2 case (Tag 2)
(obj5 (obj5
(req "status" (constant "running")) (req "status" (constant "running"))
(req "net_id" Net_id.encoding) (req "net_id" Net_id.encoding)

4
lib_base/time.ml
View File

@ -98,11 +98,11 @@ module T = struct
~binary: int64 ~binary: int64
~json: ~json:
(union [ (union [
case case Json_only
rfc_encoding rfc_encoding
(fun i -> Some i) (fun i -> Some i)
(fun i -> i) ; (fun i -> i) ;
case case Json_only
int64 int64
(fun _ -> None) (fun _ -> None)
(fun i -> i) ; (fun i -> i) ;

6
lib_crypto/blake2B.ml
View File

@ -321,19 +321,19 @@ module Generic_Merkle_tree (H : sig
mu "path" mu "path"
(fun path_encoding -> (fun path_encoding ->
union [ union [
case ~tag:240 case (Tag 240)
(obj2 (obj2
(req "path" path_encoding) (req "path" path_encoding)
(req "right" H.encoding)) (req "right" H.encoding))
(function Left (p, r) -> Some (p, r) | _ -> None) (function Left (p, r) -> Some (p, r) | _ -> None)
(fun (p, r) -> Left (p, r)) ; (fun (p, r) -> Left (p, r)) ;
case ~tag:15 case (Tag 15)
(obj2 (obj2
(req "left" H.encoding) (req "left" H.encoding)
(req "path" path_encoding)) (req "path" path_encoding))
(function Right (r, p) -> Some (r, p) | _ -> None) (function Right (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Right (r, p)) ; (fun (r, p) -> Right (r, p)) ;
case ~tag:0 case (Tag 0)
unit unit
(function Op -> Some () | _ -> None) (function Op -> Some () | _ -> None)
(fun () -> Op) (fun () -> Op)

78
lib_data_encoding/data_encoding.ml
View File

@ -25,9 +25,9 @@ exception Invalid_tag of int * [ `Uint8 | `Uint16 ]
exception Unexpected_enum of string * string list exception Unexpected_enum of string * string list
exception Invalid_size of int exception Invalid_size of int
let apply fs v = let apply ?(error=No_case_matched) fs v =
let rec loop = function let rec loop = function
| [] -> raise No_case_matched | [] -> raise error
| f :: fs -> | f :: fs ->
match f v with match f v with
| Some l -> l | Some l -> l
@ -107,6 +107,8 @@ module Kind = struct
end end
type case_tag = Tag of int | Json_only
type 'a desc = type 'a desc =
| Null : unit desc | Null : unit desc
| Empty : unit desc | Empty : unit desc
@ -158,7 +160,7 @@ and 'a case =
| Case : { encoding : 'a t ; | Case : { encoding : 'a t ;
proj : ('t -> 'a option) ; proj : ('t -> 'a option) ;
inj : ('a -> 't) ; inj : ('a -> 't) ;
tag : int option } -> 't case tag : case_tag } -> 't case
and 'a t = { and 'a t = {
encoding: 'a desc ; encoding: 'a desc ;
@ -685,8 +687,8 @@ module Encoding = struct
List.fold_left List.fold_left
(fun others (Case { tag }) -> (fun others (Case { tag }) ->
match tag with match tag with
| None -> others | Json_only -> others
| Some tag -> | Tag tag ->
if List.mem tag others then raise (Duplicated_tag tag) ; if List.mem tag others then raise (Duplicated_tag tag) ;
if tag < 0 || max_tag <= tag then if tag < 0 || max_tag <= tag then
raise (Invalid_tag (tag, tag_size)) ; raise (Invalid_tag (tag, tag_size)) ;
@ -700,14 +702,14 @@ module Encoding = struct
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 ?tag encoding proj inj = Case { encoding ; proj ; inj ; tag } let case tag encoding proj inj = Case { encoding ; proj ; inj ; tag }
let option ty = let option ty =
union union
~tag_size:`Uint8 ~tag_size:`Uint8
[ case ~tag:1 ty [ case (Tag 1) ty
(fun x -> x) (fun x -> x)
(fun x -> Some x) ; (fun x -> Some x) ;
case ~tag:0 empty case (Tag 0) empty
(function None -> Some () | Some _ -> None) (function None -> Some () | Some _ -> None)
(fun () -> None) ; (fun () -> None) ;
] ]
@ -725,10 +727,10 @@ module Encoding = struct
let result ok_enc error_enc = let result ok_enc error_enc =
union union
~tag_size:`Uint8 ~tag_size:`Uint8
[ case ~tag:1 ok_enc [ case (Tag 1) ok_enc
(function Ok x -> Some x | Error _ -> None) (function Ok x -> Some x | Error _ -> None)
(fun x -> Ok x) ; (fun x -> Ok x) ;
case ~tag:0 error_enc case (Tag 0) error_enc
(function Ok _ -> None | Error x -> Some x) (function Ok _ -> None | Error x -> Some x)
(fun x -> Error x) ; (fun x -> Error x) ;
] ]
@ -782,12 +784,10 @@ module Binary = struct
let length2 = length e2 in let length2 = length e2 in
fun (v1, v2) -> length1 v1 + length2 v2 fun (v1, v2) -> length1 v1 + length2 v2
| Union (`Dynamic, sz, cases) -> | Union (`Dynamic, sz, cases) ->
let case_length = function let case_length (Case { encoding = e ; proj }) =
| Case { tag = None } -> None let length v = tag_size sz + length e v in
| Case { encoding = e ; proj ; tag = Some _ } -> fun v -> Option.map ~f:length (proj v) in
let length v = tag_size sz + length e v in apply (List.map case_length cases)
Some (fun v -> Option.map ~f:length (proj v)) in
apply (TzList.filter_map case_length cases)
| Mu (`Dynamic, _name, self) -> | Mu (`Dynamic, _name, self) ->
fun v -> length (self e) v fun v -> length (self e) v
| Obj (Opt (`Dynamic, _, e)) -> | Obj (Opt (`Dynamic, _, e)) ->
@ -828,15 +828,24 @@ module Binary = struct
let length = length e in let length = length e in
(function None -> 0 | Some x -> length x) (function None -> 0 | Some x -> length x)
| Union (`Variable, sz, cases) -> | Union (`Variable, sz, cases) ->
let case_length = function let rec case_lengths json_only_cases acc = function
| Case { tag = None } -> None | [] -> (List.rev acc, json_only_cases)
| Case { encoding = e ; proj ; tag = Some _ } -> | Case { tag = Json_only } :: tl -> case_lengths true acc tl
| Case { encoding = e ; proj ; tag = Tag _ } :: tl ->
let length v = tag_size sz + length e v in let length v = tag_size sz + length e v in
Some (fun v -> case_lengths
match proj v with json_only_cases
| None -> None ((fun v ->
| Some v -> Some (length v)) in match proj v with
apply (TzList.filter_map case_length cases) | None -> None
| Some v -> Some (length v)) :: acc)
tl in
let cases, json_only = case_lengths false [] cases in
apply
~error:(if json_only
then Failure "No case matched, but JSON only cases were present in union"
else No_case_matched)
cases
| Mu (`Variable, _name, self) -> | Mu (`Variable, _name, self) ->
fun v -> length (self e) v fun v -> length (self e) v
(* Recursive*) (* Recursive*)
@ -944,17 +953,16 @@ module Binary = struct
let union w sz cases = let union w sz cases =
let writes_case = function let writes_case = function
| Case { tag = None } -> | Case { tag = Json_only } -> None
(fun _ -> None) | Case { encoding = e ; proj ; tag = Tag tag } ->
| Case { encoding = e ; proj ; tag = Some tag } ->
let write = w.write e in let write = w.write e in
let write v buf ofs = let write v buf ofs =
write_tag sz tag buf ofs |> write v buf in write_tag sz tag buf ofs |> write v buf in
fun v -> Some (fun v ->
match proj v with match proj v with
| None -> None | None -> None
| Some v -> Some (write v) in | Some v -> Some (write v)) in
apply (List.map writes_case cases) apply (TzList.filter_map writes_case cases)
end end
@ -1150,8 +1158,8 @@ module Binary = struct
let read_cases = let read_cases =
TzList.filter_map TzList.filter_map
(function (function
| (Case { tag = None }) -> None | (Case { tag = Json_only }) -> None
| (Case { encoding = e ; inj ; tag = Some tag }) -> | (Case { encoding = e ; inj ; tag = Tag tag }) ->
let read = r.read e in let read = r.read e in
Some (tag, fun len buf ofs -> Some (tag, fun len buf ofs ->
let ofs, v = read len buf ofs in let ofs, v = read len buf ofs in
@ -1510,7 +1518,7 @@ module Binary = struct
let opt = let opt =
List.fold_left List.fold_left
(fun acc c -> match c with (fun acc c -> match c with
| (Case { encoding ; tag = Some tag }) | (Case { encoding ; tag = Tag tag })
when tag == ctag -> when tag == ctag ->
assert (acc == None) ; assert (acc == None) ;
Some (data_checker path encoding buf) Some (data_checker path encoding buf)

4
lib_data_encoding/data_encoding.mli
View File

@ -335,6 +335,8 @@ val assoc : 'a encoding -> (string * 'a) list encoding
the union type. *) the union type. *)
type 't case type 't case
type case_tag = Tag of int | Json_only
(** Encodes a variant constructor. Takes the encoding for the specific (** Encodes a variant constructor. Takes the encoding for the specific
parameters, a recognizer function that will extract the parameters parameters, a recognizer function that will extract the parameters
in case the expected case of the variant is being serialized, and in case the expected case of the variant is being serialized, and
@ -346,7 +348,7 @@ type 't case
If no tag is specified, tags are assigned by the union combinator. *) If no tag is specified, tags are assigned by the union combinator. *)
val case : val case :
?tag:int -> case_tag ->
'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
(** Create a single encoding from a series of cases. (** Create a single encoding from a series of cases.

4
lib_embedded_protocol_alpha/src/contract_repr.ml
View File

@ -46,10 +46,10 @@ let encoding =
splitted splitted
~binary: ~binary:
(union ~tag_size:`Uint8 [ (union ~tag_size:`Uint8 [
case ~tag:0 Ed25519.Public_key_hash.encoding case (Tag 0) Ed25519.Public_key_hash.encoding
(function Default k -> Some k | _ -> None) (function Default k -> Some k | _ -> None)
(fun k -> Default k) ; (fun k -> Default k) ;
case ~tag:1 Contract_hash.encoding case (Tag 1) Contract_hash.encoding
(function Originated k -> Some k | _ -> None) (function Originated k -> Some k | _ -> None)
(fun k -> Originated k) ; (fun k -> Originated k) ;
]) ])

8
lib_embedded_protocol_alpha/src/manager_repr.ml
View File

@ -18,14 +18,14 @@ type t = manager_key
open Data_encoding open Data_encoding
let hash_case tag = let hash_case tag =
case ~tag Ed25519.Public_key_hash.encoding case tag Ed25519.Public_key_hash.encoding
(function (function
| Hash hash -> Some hash | Hash hash -> Some hash
| _ -> None) | _ -> None)
(fun hash -> Hash hash) (fun hash -> Hash hash)
let pubkey_case tag = let pubkey_case tag =
case ~tag Ed25519.Public_key.encoding case tag Ed25519.Public_key.encoding
(function (function
| Public_key hash -> Some hash | Public_key hash -> Some hash
| _ -> None) | _ -> None)
@ -34,7 +34,7 @@ let pubkey_case tag =
let encoding = let encoding =
union [ union [
hash_case 0 ; hash_case (Tag 0) ;
pubkey_case 1 ; pubkey_case (Tag 1) ;
] ]

56
lib_embedded_protocol_alpha/src/operation_repr.ml
View File

@ -100,7 +100,7 @@ module Encoding = struct
(opt "parameters" Script_repr.expr_encoding)) (opt "parameters" Script_repr.expr_encoding))
let transaction_case tag = let transaction_case tag =
case ~tag transaction_encoding case tag transaction_encoding
(function (function
| Transaction { amount ; destination ; parameters } -> | Transaction { amount ; destination ; parameters } ->
Some ((), amount, destination, parameters) Some ((), amount, destination, parameters)
@ -119,7 +119,7 @@ module Encoding = struct
(opt "script" Script_repr.encoding)) (opt "script" Script_repr.encoding))
let origination_case tag = let origination_case tag =
case ~tag origination_encoding case tag origination_encoding
(function (function
| Origination { manager ; credit ; spendable ; | Origination { manager ; credit ; spendable ;
delegatable ; delegate ; script } -> delegatable ; delegate ; script } ->
@ -140,7 +140,7 @@ module Encoding = struct
(opt "delegate" Ed25519.Public_key_hash.encoding)) (opt "delegate" Ed25519.Public_key_hash.encoding))
let delegation_case tag = let delegation_case tag =
case ~tag delegation_encoding case tag delegation_encoding
(function Delegation key -> Some ((), key) | _ -> None) (function Delegation key -> Some ((), key) | _ -> None)
(fun ((), key) -> Delegation key) (fun ((), key) -> Delegation key)
@ -152,13 +152,13 @@ module Encoding = struct
(req "counter" int32) (req "counter" int32)
(req "operations" (req "operations"
(list (union ~tag_size:`Uint8 [ (list (union ~tag_size:`Uint8 [
transaction_case 0 ; transaction_case (Tag 0) ;
origination_case 1 ; origination_case (Tag 1) ;
delegation_case 2 ; delegation_case (Tag 2) ;
])))) ]))))
let manager_kind_case tag = let manager_kind_case tag =
case ~tag manager_kind_encoding case tag manager_kind_encoding
(function (function
| Manager_operations { source; public_key ; fee ; counter ;operations } -> | Manager_operations { source; public_key ; fee ; counter ;operations } ->
Some (source, public_key, fee, counter, operations) Some (source, public_key, fee, counter, operations)
@ -173,7 +173,7 @@ module Encoding = struct
(req "slot" int31)) (req "slot" int31))
let endorsement_case tag = let endorsement_case tag =
case ~tag endorsement_encoding case tag endorsement_encoding
(function (function
| Endorsement { block ; slot } -> | Endorsement { block ; slot } ->
Some ((), block, slot) Some ((), block, slot)
@ -188,7 +188,7 @@ module Encoding = struct
(req "proposals" (list Protocol_hash.encoding))) (req "proposals" (list Protocol_hash.encoding)))
let proposal_case tag = let proposal_case tag =
case ~tag proposal_encoding case tag proposal_encoding
(function (function
| Proposals { period ; proposals } -> | Proposals { period ; proposals } ->
Some ((), period, proposals) Some ((), period, proposals)
@ -204,7 +204,7 @@ module Encoding = struct
(req "ballot" Vote_repr.ballot_encoding)) (req "ballot" Vote_repr.ballot_encoding))
let ballot_case tag = let ballot_case tag =
case ~tag ballot_encoding case tag ballot_encoding
(function (function
| Ballot { period ; proposal ; ballot } -> | Ballot { period ; proposal ; ballot } ->
Some ((), period, proposal, ballot) Some ((), period, proposal, ballot)
@ -217,13 +217,13 @@ module Encoding = struct
(req "source" Ed25519.Public_key.encoding) (req "source" Ed25519.Public_key.encoding)
(req "operations" (req "operations"
(list (union [ (list (union [
endorsement_case 0 ; endorsement_case (Tag 0) ;
proposal_case 1 ; proposal_case (Tag 1) ;
ballot_case 2 ; ballot_case (Tag 2) ;
])))) ]))))
let delegate_kind_case tag = let delegate_kind_case tag =
case ~tag delegate_kind_encoding case tag delegate_kind_encoding
(function (function
| Delegate_operations { source ; operations } -> | Delegate_operations { source ; operations } ->
Some (source, operations) Some (source, operations)
@ -241,12 +241,12 @@ module Encoding = struct
args) in args) in
let open Data_encoding in let open Data_encoding in
union ~tag_size:`Uint8 [ union ~tag_size:`Uint8 [
case ~tag:0 case (Tag 0)
(mk_case "activate" (mk_case "activate"
(obj1 (req "hash" Protocol_hash.encoding))) (obj1 (req "hash" Protocol_hash.encoding)))
(function (Activate hash) -> Some hash | _ -> None) (function (Activate hash) -> Some hash | _ -> None)
(fun hash -> Activate hash) ; (fun hash -> Activate hash) ;
case ~tag:1 case (Tag 1)
(mk_case "activate_testnet" (mk_case "activate_testnet"
(obj1 (req "hash" Protocol_hash.encoding))) (obj1 (req "hash" Protocol_hash.encoding)))
(function (Activate_testnet hash) -> Some hash | _ -> None) (function (Activate_testnet hash) -> Some hash | _ -> None)
@ -254,16 +254,16 @@ module Encoding = struct
] ]
let dictator_kind_case tag = let dictator_kind_case tag =
case ~tag dictator_kind_encoding case tag dictator_kind_encoding
(function Dictator_operation op -> Some op | _ -> None) (function Dictator_operation op -> Some op | _ -> None)
(fun op -> Dictator_operation op) (fun op -> Dictator_operation op)
let signed_operations_case tag = let signed_operations_case tag =
case ~tag case tag
(union [ (union [
manager_kind_case 0 ; manager_kind_case (Tag 0) ;
delegate_kind_case 1 ; delegate_kind_case (Tag 1) ;
dictator_kind_case 2 ; dictator_kind_case (Tag 2) ;
]) ])
(function Sourced_operations ops -> Some ops | _ -> None) (function Sourced_operations ops -> Some ops | _ -> None)
(fun ops -> Sourced_operations ops) (fun ops -> Sourced_operations ops)
@ -275,7 +275,7 @@ module Encoding = struct
(req "nonce" Seed_repr.nonce_encoding)) (req "nonce" Seed_repr.nonce_encoding))
let seed_nonce_revelation_case tag = let seed_nonce_revelation_case tag =
case ~tag seed_nonce_revelation_encoding case tag seed_nonce_revelation_encoding
(function (function
| Seed_nonce_revelation { level ; nonce } -> Some ((), level, nonce) | Seed_nonce_revelation { level ; nonce } -> Some ((), level, nonce)
| _ -> None | _ -> None
@ -289,7 +289,7 @@ module Encoding = struct
(req "nonce" (Fixed.bytes 16))) (req "nonce" (Fixed.bytes 16)))
let faucet_case tag = let faucet_case tag =
case ~tag faucet_encoding case tag faucet_encoding
(function (function
| Faucet { id ; nonce } -> Some ((), id, nonce) | Faucet { id ; nonce } -> Some ((), id, nonce)
| _ -> None | _ -> None
@ -297,21 +297,21 @@ module Encoding = struct
(fun ((), id, nonce) -> Faucet { id ; nonce }) (fun ((), id, nonce) -> Faucet { id ; nonce })
let unsigned_operation_case tag = let unsigned_operation_case tag =
case ~tag case tag
(obj1 (obj1
(req "operations" (req "operations"
(list (list
(union [ (union [
seed_nonce_revelation_case 0 ; seed_nonce_revelation_case (Tag 0) ;
faucet_case 1 ; faucet_case (Tag 1) ;
])))) ]))))
(function Anonymous_operations ops -> Some ops | _ -> None) (function Anonymous_operations ops -> Some ops | _ -> None)
(fun ops -> Anonymous_operations ops) (fun ops -> Anonymous_operations ops)
let proto_operation_encoding = let proto_operation_encoding =
union [ union [
signed_operations_case 0 ; signed_operations_case (Tag 0) ;
unsigned_operation_case 1 ; unsigned_operation_case (Tag 1) ;
] ]
let unsigned_operation_encoding = let unsigned_operation_encoding =

8
lib_embedded_protocol_alpha/src/raw_context.ml
View File

@ -48,21 +48,21 @@ type storage_error =
let storage_error_encoding = let storage_error_encoding =
let open Data_encoding in let open Data_encoding in
union [ union [
case ~tag:0 case (Tag 0)
(obj1 (req "incompatible_protocol_version" string)) (obj1 (req "incompatible_protocol_version" string))
(function Incompatible_protocol_version arg -> Some arg | _ -> None) (function Incompatible_protocol_version arg -> Some arg | _ -> None)
(fun arg -> Incompatible_protocol_version arg) ; (fun arg -> Incompatible_protocol_version arg) ;
case ~tag:1 case (Tag 1)
(obj2 (obj2
(req "missing_key" (list string)) (req "missing_key" (list string))
(req "function" (string_enum ["get", `Get ; "set", `Set]))) (req "function" (string_enum ["get", `Get ; "set", `Set])))
(function Missing_key (key, f) -> Some (key, f) | _ -> None) (function Missing_key (key, f) -> Some (key, f) | _ -> None)
(fun (key, f) -> Missing_key (key, f)) ; (fun (key, f) -> Missing_key (key, f)) ;
case ~tag:2 case (Tag 2)
(obj1 (req "existing_key" (list string))) (obj1 (req "existing_key" (list string)))
(function Existing_key key -> Some key | _ -> None) (function Existing_key key -> Some key | _ -> None)
(fun key -> Existing_key key) ; (fun key -> Existing_key key) ;
case ~tag:3 case (Tag 3)
(obj1 (req "corrupted_data" (list string))) (obj1 (req "corrupted_data" (list string)))
(function Corrupted_data key -> Some key | _ -> None) (function Corrupted_data key -> Some key | _ -> None)
(fun key -> Corrupted_data key) ; (fun key -> Corrupted_data key) ;

10
lib_embedded_protocol_alpha/src/services.ml
View File

@ -24,11 +24,11 @@ let error_encoding =
let wrap_tzerror encoding = let wrap_tzerror encoding =
let open Data_encoding in let open Data_encoding in
union [ union [
case case (Tag 0)
(obj1 (req "ok" encoding)) (obj1 (req "ok" encoding))
(function Ok x -> Some x | _ -> None) (function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ; (fun x -> Ok x) ;
case case (Tag 1)
(obj1 (req "error" error_encoding)) (obj1 (req "error" error_encoding))
(function Error x -> Some x | _ -> None) (function Error x -> Some x | _ -> None)
(fun x -> Error x) ; (fun x -> Error x) ;
@ -229,15 +229,15 @@ module Context = struct
let nonce_encoding = let nonce_encoding =
union [ union [
case case (Tag 0)
(obj1 (req "nonce" Nonce.encoding)) (obj1 (req "nonce" Nonce.encoding))
(function Revealed nonce -> Some nonce | _ -> None) (function Revealed nonce -> Some nonce | _ -> None)
(fun nonce -> Revealed nonce) ; (fun nonce -> Revealed nonce) ;
case case (Tag 1)
(obj1 (req "hash" Nonce_hash.encoding)) (obj1 (req "hash" Nonce_hash.encoding))
(function Missing nonce -> Some nonce | _ -> None) (function Missing nonce -> Some nonce | _ -> None)
(fun nonce -> Missing nonce) ; (fun nonce -> Missing nonce) ;
case case (Tag 2)
empty empty
(function Forgotten -> Some () | _ -> None) (function Forgotten -> Some () | _ -> None)
(fun () -> Forgotten) ; (fun () -> Forgotten) ;

4
lib_embedded_protocol_alpha/src/storage.ml
View File

@ -142,7 +142,7 @@ module Cycle = struct
let nonce_status_encoding = let nonce_status_encoding =
let open Data_encoding in let open Data_encoding in
union [ union [
case ~tag:0 case (Tag 0)
(tup3 (tup3
Nonce_hash.encoding Nonce_hash.encoding
Ed25519.Public_key_hash.encoding Ed25519.Public_key_hash.encoding
@ -153,7 +153,7 @@ module Cycle = struct
| _ -> None) | _ -> None)
(fun (nonce_hash, delegate_to_reward, reward_amount) -> (fun (nonce_hash, delegate_to_reward, reward_amount) ->
Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount }) ; Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount }) ;
case ~tag:1 case (Tag 1)
Seed_repr.nonce_encoding Seed_repr.nonce_encoding
(function (function
| Revealed nonce -> Some nonce | Revealed nonce -> Some nonce

8
lib_embedded_protocol_alpha/src/voting_period_repr.ml
View File

@ -43,19 +43,19 @@ type kind =
let kind_encoding = let kind_encoding =
let open Data_encoding in let open Data_encoding in
union ~tag_size:`Uint8 [ union ~tag_size:`Uint8 [
case ~tag:0 case (Tag 0)
(constant "proposal") (constant "proposal")
(function Proposal -> Some () | _ -> None) (function Proposal -> Some () | _ -> None)
(fun () -> Proposal) ; (fun () -> Proposal) ;
case ~tag:1 case (Tag 1)
(constant "testing_vote") (constant "testing_vote")
(function Testing_vote -> Some () | _ -> None) (function Testing_vote -> Some () | _ -> None)
(fun () -> Testing_vote) ; (fun () -> Testing_vote) ;
case ~tag:2 case (Tag 2)
(constant "testing") (constant "testing")
(function Testing -> Some () | _ -> None) (function Testing -> Some () | _ -> None)
(fun () -> Testing) ; (fun () -> Testing) ;
case ~tag:3 case (Tag 3)
(constant "promotion_vote") (constant "promotion_vote")
(function Promotion_vote -> Some () | _ -> None) (function Promotion_vote -> Some () | _ -> None)
(fun () -> Promotion_vote) ; (fun () -> Promotion_vote) ;

4
lib_embedded_protocol_demo/src/services.ml
View File

@ -21,11 +21,11 @@ let error_encoding =
let wrap_tzerror encoding = let wrap_tzerror encoding =
let open Data_encoding in let open Data_encoding in
union [ union [
case case (Tag 0)
(obj1 (req "ok" encoding)) (obj1 (req "ok" encoding))
(function Ok x -> Some x | _ -> None) (function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ; (fun x -> Ok x) ;
case case (Tag 1)
(obj1 (req "error" error_encoding)) (obj1 (req "error" error_encoding))
(function Error x -> Some x | _ -> None) (function Error x -> Some x | _ -> None)
(fun x -> Error x) ; (fun x -> Error x) ;

4
lib_embedded_protocol_genesis/src/data.ml
View File

@ -35,7 +35,7 @@ module Command = struct
let encoding = let encoding =
let open Data_encoding in let open Data_encoding in
union ~tag_size:`Uint8 [ union ~tag_size:`Uint8 [
case ~tag:0 case (Tag 0)
(mk_case "activate" (mk_case "activate"
(obj2 (obj2
(req "hash" Protocol_hash.encoding) (req "hash" Protocol_hash.encoding)
@ -47,7 +47,7 @@ module Command = struct
| _ -> None) | _ -> None)
(fun (protocol, validation_passes) -> (fun (protocol, validation_passes) ->
Activate { protocol ; validation_passes }) ; Activate { protocol ; validation_passes }) ;
case ~tag:1 case (Tag 1)
(mk_case "activate_testnet" (mk_case "activate_testnet"
(obj3 (obj3
(req "hash" Protocol_hash.encoding) (req "hash" Protocol_hash.encoding)

4
lib_embedded_protocol_genesis/src/services.ml
View File

@ -21,11 +21,11 @@ let error_encoding =
let wrap_tzerror encoding = let wrap_tzerror encoding =
let open Data_encoding in let open Data_encoding in
union [ union [
case case (Tag 0)
(obj1 (req "ok" encoding)) (obj1 (req "ok" encoding))
(function Ok x -> Some x | _ -> None) (function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ; (fun x -> Ok x) ;
case case (Tag 1)
(obj1 (req "error" error_encoding)) (obj1 (req "error" error_encoding))
(function Error x -> Some x | _ -> None) (function Error x -> Some x | _ -> None)
(fun x -> Error x) ; (fun x -> Error x) ;

12
lib_error_monad/error_monad.ml
View File

@ -67,7 +67,7 @@ module Make() = struct
name) ; name) ;
let encoding_case = let encoding_case =
let open Data_encoding in let open Data_encoding in
case case Json_only
(describe ~title ~description @@ (describe ~title ~description @@
conv (fun x -> (((), ()), x)) (fun (((),()), x) -> x) @@ conv (fun x -> (((), ()), x)) (fun (((),()), x) -> x) @@
merge_objs merge_objs
@ -175,10 +175,10 @@ module Make() = struct
obj1 (req "result" t_encoding) in obj1 (req "result" t_encoding) in
union union
~tag_size:`Uint8 ~tag_size:`Uint8
[ case ~tag:0 t_encoding [ case (Tag 0) t_encoding
(function Ok x -> Some x | _ -> None) (function Ok x -> Some x | _ -> None)
(function res -> Ok res) ; (function res -> Ok res) ;
case ~tag:1 errors_encoding case (Tag 1) errors_encoding
(function Error x -> Some x | _ -> None) (function Error x -> Some x | _ -> None)
(fun errs -> Error errs) ] (fun errs -> Error errs) ]
@ -417,7 +417,7 @@ module Make() = struct
let description = "An unclassified error" in let description = "An unclassified error" in
let encoding_case = let encoding_case =
let open Data_encoding in let open Data_encoding in
case case Json_only
(describe ~title ~description @@ (describe ~title ~description @@
conv (fun x -> ((), x)) (fun ((), x) -> x) @@ conv (fun x -> ((), x)) (fun ((), x) -> x) @@
(obj2 (obj2
@ -426,7 +426,7 @@ module Make() = struct
from_error to_error in from_error to_error in
let pp = Format.pp_print_string in let pp = Format.pp_print_string in
error_kinds := error_kinds :=
Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds Error_kind { id ; from_error ; category ; encoding_case ; pp } :: !error_kinds
type error += Assert_error of string * string type error += Assert_error of string * string
@ -441,7 +441,7 @@ module Make() = struct
let description = "An fatal assertion" in let description = "An fatal assertion" in
let encoding_case = let encoding_case =
let open Data_encoding in let open Data_encoding in
case case Json_only
(describe ~title ~description @@ (describe ~title ~description @@
conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y)) @@ conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y)) @@
(obj3 (obj3

8
lib_micheline/micheline.ml
View File

@ -127,18 +127,18 @@ let canonical_encoding prim_encoding =
describe describe
~title: "Script expression (data, type or code)" @@ ~title: "Script expression (data, type or code)" @@
union ~tag_size:`Uint8 union ~tag_size:`Uint8
[ case ~tag:0 int_encoding [ case (Tag 0) int_encoding
(function Int (_, v) -> Some v | _ -> None) (function Int (_, v) -> Some v | _ -> None)
(fun v -> Int (0, v)) ; (fun v -> Int (0, v)) ;
case ~tag:1 string_encoding case (Tag 1) string_encoding
(function String (_, v) -> Some v | _ -> None) (function String (_, v) -> Some v | _ -> None)
(fun v -> String (0, v)) ; (fun v -> String (0, v)) ;
case ~tag:2 (application_encoding expr_encoding) case (Tag 2) (application_encoding expr_encoding)
(function (function
| Prim (_, v, args, annot) -> Some (v, args, annot) | Prim (_, v, args, annot) -> Some (v, args, annot)
| _ -> None) | _ -> None)
(function (prim, args, annot) -> Prim (0, prim, args, annot)) ; (function (prim, args, annot) -> Prim (0, prim, args, annot)) ;
case ~tag:3 (seq_encoding expr_encoding) case (Tag 3) (seq_encoding expr_encoding)
(function Seq (_, v, _annot) -> Some v | _ -> None) (function Seq (_, v, _annot) -> Some v | _ -> None)
(fun args -> Seq (0, args, None)) ]) in (fun args -> Seq (0, args, None)) ]) in
conv conv

10
lib_micheline/micheline_parser.ml
View File

@ -65,23 +65,23 @@ type token_value =
let token_value_encoding = let token_value_encoding =
let open Data_encoding in let open Data_encoding in
union union
[ case (obj1 (req "string" string)) [ case (Tag 0) (obj1 (req "string" string))
(function String s -> Some s | _ -> None) (function String s -> Some s | _ -> None)
(fun s -> String s) ; (fun s -> String s) ;
case (obj1 (req "int" string)) case (Tag 1) (obj1 (req "int" string))
(function Int s -> Some s | _ -> None) (function Int s -> Some s | _ -> None)
(fun s -> Int s) ; (fun s -> Int s) ;
case (obj1 (req "annot" string)) case (Tag 2) (obj1 (req "annot" string))
(function Annot s -> Some s | _ -> None) (function Annot s -> Some s | _ -> None)
(fun s -> Annot s) ; (fun s -> Annot s) ;
case (obj2 (req "comment" string) (dft "end_of_line" bool false)) case (Tag 3) (obj2 (req "comment" string) (dft "end_of_line" bool false))
(function (function
| Comment s -> Some (s, false) | Comment s -> Some (s, false)
| Eol_comment s -> Some (s, true) | _ -> None) | Eol_comment s -> Some (s, true) | _ -> None)
(function (function
| (s, false) -> Comment s | (s, false) -> Comment s
| (s, true) -> Eol_comment s) ; | (s, true) -> Eol_comment s) ;
case case (Tag 4)
(obj1 (req "punctuation" (string_enum [ (obj1 (req "punctuation" (string_enum [
"(", Open_paren ; "(", Open_paren ;
")", Close_paren ; ")", Close_paren ;

12
lib_node_p2p/p2p_connection_pool.ml
View File

@ -42,21 +42,21 @@ module Message = struct
let open Data_encoding in let open Data_encoding in
dynamic_size @@ dynamic_size @@
union ~tag_size:`Uint16 union ~tag_size:`Uint16
([ case ~tag:0x01 null ([ case (Tag 0x01) null
(function Disconnect -> Some () | _ -> None) (function Disconnect -> Some () | _ -> None)
(fun () -> Disconnect); (fun () -> Disconnect);
case ~tag:0x02 null case (Tag 0x02) null
(function Bootstrap -> Some () | _ -> None) (function Bootstrap -> Some () | _ -> None)
(fun () -> Bootstrap); (fun () -> Bootstrap);
case ~tag:0x03 (Variable.list Point.encoding) case (Tag 0x03) (Variable.list Point.encoding)
(function Advertise points -> Some points | _ -> None) (function Advertise points -> Some points | _ -> None)
(fun points -> Advertise points); (fun points -> Advertise points);
case ~tag:0x04 (tup2 Point.encoding Peer_id.encoding) case (Tag 0x04) (tup2 Point.encoding Peer_id.encoding)
(function (function
| Swap_request (point, peer_id) -> Some (point, peer_id) | Swap_request (point, peer_id) -> Some (point, peer_id)
| _ -> None) | _ -> None)
(fun (point, peer_id) -> Swap_request (point, peer_id)) ; (fun (point, peer_id) -> Swap_request (point, peer_id)) ;
case ~tag:0x05 (tup2 Point.encoding Peer_id.encoding) case (Tag 0x05) (tup2 Point.encoding Peer_id.encoding)
(function (function
| Swap_ack (point, peer_id) -> Some (point, peer_id) | Swap_ack (point, peer_id) -> Some (point, peer_id)
| _ -> None) | _ -> None)
@ -64,7 +64,7 @@ module Message = struct
] @ ] @
ListLabels.map msg_encoding ListLabels.map msg_encoding
~f:(function Encoding { tag ; encoding ; wrap ; unwrap } -> ~f:(function Encoding { tag ; encoding ; wrap ; unwrap } ->
case ~tag encoding case (Tag tag) encoding
(function Message msg -> unwrap msg | _ -> None) (function Message msg -> unwrap msg | _ -> None)
(fun msg -> Message (wrap msg)))) (fun msg -> Message (wrap msg))))

26
lib_node_p2p_base/p2p_connection_pool_types.ml
View File

@ -37,31 +37,31 @@ module Point_info = struct
(merge_objs (merge_objs
(obj1 (req "event_kind" (constant name))) obj) in (obj1 (req "event_kind" (constant name))) obj) in
union ~tag_size:`Uint8 [ union ~tag_size:`Uint8 [
case ~tag:0 (branch_encoding "outgoing_request" empty) case (Tag 0) (branch_encoding "outgoing_request" empty)
(function Outgoing_request -> Some () | _ -> None) (function Outgoing_request -> Some () | _ -> None)
(fun () -> Outgoing_request) ; (fun () -> Outgoing_request) ;
case ~tag:1 (branch_encoding "accepting_request" case (Tag 1) (branch_encoding "accepting_request"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function Accepting_request peer_id -> Some peer_id | _ -> None) (function Accepting_request peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Accepting_request peer_id) ; (fun peer_id -> Accepting_request peer_id) ;
case ~tag:2 (branch_encoding "rejecting_request" case (Tag 2) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function Rejecting_request peer_id -> Some peer_id | _ -> None) (function Rejecting_request peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Rejecting_request peer_id) ; (fun peer_id -> Rejecting_request peer_id) ;
case ~tag:3 (branch_encoding "request_rejected" case (Tag 3) (branch_encoding "request_rejected"
(obj1 (opt "peer_id" Peer_id.encoding))) (obj1 (opt "peer_id" Peer_id.encoding)))
(function Request_rejected peer_id -> Some peer_id | _ -> None) (function Request_rejected peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Request_rejected peer_id) ; (fun peer_id -> Request_rejected peer_id) ;
case ~tag:4 (branch_encoding "rejecting_request" case (Tag 4) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function Connection_established peer_id -> Some peer_id | _ -> None) (function Connection_established peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Connection_established peer_id) ; (fun peer_id -> Connection_established peer_id) ;
case ~tag:5 (branch_encoding "rejecting_request" case (Tag 5) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function Disconnection peer_id -> Some peer_id | _ -> None) (function Disconnection peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Disconnection peer_id) ; (fun peer_id -> Disconnection peer_id) ;
case ~tag:6 (branch_encoding "rejecting_request" case (Tag 6) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function External_disconnection peer_id -> Some peer_id | _ -> None) (function External_disconnection peer_id -> Some peer_id | _ -> None)
(fun peer_id -> External_disconnection peer_id) ; (fun peer_id -> External_disconnection peer_id) ;
] ]

114
lib_node_p2p_base/p2p_types.ml
View File

@ -382,18 +382,18 @@ module Point_state = struct
(merge_objs (merge_objs
(obj1 (req "event_kind" (constant name))) obj) in (obj1 (req "event_kind" (constant name))) obj) in
union ~tag_size:`Uint8 [ union ~tag_size:`Uint8 [
case ~tag:0 (branch_encoding "requested" empty) case (Tag 0) (branch_encoding "requested" empty)
(function Requested -> Some () | _ -> None) (function Requested -> Some () | _ -> None)
(fun () -> Requested) ; (fun () -> Requested) ;
case ~tag:1 (branch_encoding "accepted" case (Tag 1) (branch_encoding "accepted"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function Accepted peer_id -> Some peer_id | _ -> None) (function Accepted peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Accepted peer_id) ; (fun peer_id -> Accepted peer_id) ;
case ~tag:2 (branch_encoding "running" case (Tag 2) (branch_encoding "running"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function Running peer_id -> Some peer_id | _ -> None) (function Running peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Running peer_id) ; (fun peer_id -> Running peer_id) ;
case ~tag:3 (branch_encoding "disconnected" empty) case (Tag 3) (branch_encoding "disconnected" empty)
(function Disconnected -> Some () | _ -> None) (function Disconnected -> Some () | _ -> None)
(fun () -> Disconnected) ; (fun () -> Disconnected) ;
] ]
@ -600,114 +600,114 @@ module Connection_pool_log_event = struct
(merge_objs (merge_objs
(obj1 (req "event" (constant name))) obj) in (obj1 (req "event" (constant name))) obj) in
union ~tag_size:`Uint8 [ union ~tag_size:`Uint8 [
case ~tag:0 (branch_encoding "too_few_connections" empty) case (Tag 0) (branch_encoding "too_few_connections" empty)
(function Too_few_connections -> Some () | _ -> None) (function Too_few_connections -> Some () | _ -> None)
(fun () -> Too_few_connections) ; (fun () -> Too_few_connections) ;
case ~tag:1 (branch_encoding "too_many_connections" empty) case (Tag 1) (branch_encoding "too_many_connections" empty)
(function Too_many_connections -> Some () | _ -> None) (function Too_many_connections -> Some () | _ -> None)
(fun () -> Too_many_connections) ; (fun () -> Too_many_connections) ;
case ~tag:2 (branch_encoding "new_point" case (Tag 2) (branch_encoding "new_point"
(obj1 (req "point" Point.encoding))) (obj1 (req "point" Point.encoding)))
(function New_point p -> Some p | _ -> None) (function New_point p -> Some p | _ -> None)
(fun p -> New_point p) ; (fun p -> New_point p) ;
case ~tag:3 (branch_encoding "new_peer" case (Tag 3) (branch_encoding "new_peer"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function New_peer p -> Some p | _ -> None) (function New_peer p -> Some p | _ -> None)
(fun p -> New_peer p) ; (fun p -> New_peer p) ;
case ~tag:4 (branch_encoding "incoming_connection" case (Tag 4) (branch_encoding "incoming_connection"
(obj1 (req "point" Point.encoding))) (obj1 (req "point" Point.encoding)))
(function Incoming_connection p -> Some p | _ -> None) (function Incoming_connection p -> Some p | _ -> None)
(fun p -> Incoming_connection p) ; (fun p -> Incoming_connection p) ;
case ~tag:5 (branch_encoding "outgoing_connection" case (Tag 5) (branch_encoding "outgoing_connection"
(obj1 (req "point" Point.encoding))) (obj1 (req "point" Point.encoding)))
(function Outgoing_connection p -> Some p | _ -> None) (function Outgoing_connection p -> Some p | _ -> None)
(fun p -> Outgoing_connection p) ; (fun p -> Outgoing_connection p) ;
case ~tag:6 (branch_encoding "authentication_failed" case (Tag 6) (branch_encoding "authentication_failed"
(obj1 (req "point" Point.encoding))) (obj1 (req "point" Point.encoding)))
(function Authentication_failed p -> Some p | _ -> None) (function Authentication_failed p -> Some p | _ -> None)
(fun p -> Authentication_failed p) ; (fun p -> Authentication_failed p) ;
case ~tag:7 (branch_encoding "accepting_request" case (Tag 7) (branch_encoding "accepting_request"
(obj3 (obj3
(req "point" Point.encoding) (req "point" Point.encoding)
(req "id_point" Id_point.encoding) (req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding))) (req "peer_id" Peer_id.encoding)))
(function Accepting_request (p, id_p, g) -> (function Accepting_request (p, id_p, g) ->
Some (p, id_p, g) | _ -> None) Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ; (fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ;
case ~tag:8 (branch_encoding "rejecting_request" case (Tag 8) (branch_encoding "rejecting_request"
(obj3 (obj3
(req "point" Point.encoding) (req "point" Point.encoding)
(req "id_point" Id_point.encoding) (req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding))) (req "peer_id" Peer_id.encoding)))
(function Rejecting_request (p, id_p, g) -> (function Rejecting_request (p, id_p, g) ->
Some (p, id_p, g) | _ -> None) Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ; (fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ;
case ~tag:9 (branch_encoding "request_rejected" case (Tag 9) (branch_encoding "request_rejected"
(obj2 (obj2
(req "point" Point.encoding) (req "point" Point.encoding)
(opt "identity" (opt "identity"
(tup2 Id_point.encoding Peer_id.encoding)))) (tup2 Id_point.encoding Peer_id.encoding))))
(function Request_rejected (p, id) -> Some (p, id) | _ -> None) (function Request_rejected (p, id) -> Some (p, id) | _ -> None)
(fun (p, id) -> Request_rejected (p, id)) ; (fun (p, id) -> Request_rejected (p, id)) ;
case ~tag:10 (branch_encoding "connection_established" case (Tag 10) (branch_encoding "connection_established"
(obj2 (obj2
(req "id_point" Id_point.encoding) (req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding))) (req "peer_id" Peer_id.encoding)))
(function Connection_established (id_p, g) -> (function Connection_established (id_p, g) ->
Some (id_p, g) | _ -> None) Some (id_p, g) | _ -> None)
(fun (id_p, g) -> Connection_established (id_p, g)) ; (fun (id_p, g) -> Connection_established (id_p, g)) ;
case ~tag:11 (branch_encoding "disconnection" case (Tag 11) (branch_encoding "disconnection"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function Disconnection g -> Some g | _ -> None) (function Disconnection g -> Some g | _ -> None)
(fun g -> Disconnection g) ; (fun g -> Disconnection g) ;
case ~tag:12 (branch_encoding "external_disconnection" case (Tag 12) (branch_encoding "external_disconnection"
(obj1 (req "peer_id" Peer_id.encoding))) (obj1 (req "peer_id" Peer_id.encoding)))
(function External_disconnection g -> Some g | _ -> None) (function External_disconnection g -> Some g | _ -> None)
(fun g -> External_disconnection g) ; (fun g -> External_disconnection g) ;
case ~tag:13 (branch_encoding "gc_points" empty) case (Tag 13) (branch_encoding "gc_points" empty)
(function Gc_points -> Some () | _ -> None) (function Gc_points -> Some () | _ -> None)
(fun () -> Gc_points) ; (fun () -> Gc_points) ;
case ~tag:14 (branch_encoding "gc_peer_ids" empty) case (Tag 14) (branch_encoding "gc_peer_ids" empty)
(function Gc_peer_ids -> Some () | _ -> None) (function Gc_peer_ids -> Some () | _ -> None)
(fun () -> Gc_peer_ids) ; (fun () -> Gc_peer_ids) ;
case ~tag:15 (branch_encoding "swap_request_received" case (Tag 15) (branch_encoding "swap_request_received"
(obj1 (req "source" Peer_id.encoding))) (obj1 (req "source" Peer_id.encoding)))
(function (function
| Swap_request_received { source } -> Some source | Swap_request_received { source } -> Some source
| _ -> None) | _ -> None)
(fun source -> Swap_request_received { source }) ; (fun source -> Swap_request_received { source }) ;
case ~tag:16 (branch_encoding "swap_ack_received" case (Tag 16) (branch_encoding "swap_ack_received"
(obj1 (req "source" Peer_id.encoding))) (obj1 (req "source" Peer_id.encoding)))
(function (function
| Swap_ack_received { source } -> Some source | Swap_ack_received { source } -> Some source
| _ -> None) | _ -> None)
(fun source -> Swap_ack_received { source }) ; (fun source -> Swap_ack_received { source }) ;
case ~tag:17 (branch_encoding "swap_request_sent" case (Tag 17) (branch_encoding "swap_request_sent"
(obj1 (req "source" Peer_id.encoding))) (obj1 (req "source" Peer_id.encoding)))
(function (function
| Swap_request_sent { source } -> Some source | Swap_request_sent { source } -> Some source
| _ -> None) | _ -> None)
(fun source -> Swap_request_sent { source }) ; (fun source -> Swap_request_sent { source }) ;
case ~tag:18 (branch_encoding "swap_ack_sent" case (Tag 18) (branch_encoding "swap_ack_sent"
(obj1 (req "source" Peer_id.encoding))) (obj1 (req "source" Peer_id.encoding)))
(function (function
| Swap_ack_sent { source } -> Some source | Swap_ack_sent { source } -> Some source
| _ -> None) | _ -> None)
(fun source -> Swap_ack_sent { source }) ; (fun source -> Swap_ack_sent { source }) ;
case ~tag:19 (branch_encoding "swap_request_ignored" case (Tag 19) (branch_encoding "swap_request_ignored"
(obj1 (req "source" Peer_id.encoding))) (obj1 (req "source" Peer_id.encoding)))
(function (function
| Swap_request_ignored { source } -> Some source | Swap_request_ignored { source } -> Some source
| _ -> None) | _ -> None)
(fun source -> Swap_request_ignored { source }) ; (fun source -> Swap_request_ignored { source }) ;
case ~tag:20 (branch_encoding "swap_success" case (Tag 20) (branch_encoding "swap_success"
(obj1 (req "source" Peer_id.encoding))) (obj1 (req "source" Peer_id.encoding)))
(function (function
| Swap_success { source } -> Some source | Swap_success { source } -> Some source
| _ -> None) | _ -> None)
(fun source -> Swap_success { source }) ; (fun source -> Swap_success { source }) ;
case ~tag:21 (branch_encoding "swap_failure" case (Tag 21) (branch_encoding "swap_failure"
(obj1 (req "source" Peer_id.encoding))) (obj1 (req "source" Peer_id.encoding)))
(function (function
| Swap_failure { source } -> Some source | Swap_failure { source } -> Some source
| _ -> None) | _ -> None)

4
lib_node_services/node_rpc_services.ml
View File

@ -37,11 +37,11 @@ module Error = struct
let wrap param_encoding = let wrap param_encoding =
union [ union [
case case (Tag 0)
(obj1 (req "ok" param_encoding)) (obj1 (req "ok" param_encoding))
(function Ok x -> Some x | _ -> None) (function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ; (fun x -> Ok x) ;
case case (Tag 1)
(obj1 (req "error" encoding)) (obj1 (req "error" encoding))
(function Error x -> Some x | _ -> None) (function Error x -> Some x | _ -> None)
(fun x -> Error x) ; (fun x -> Error x) ;

22
lib_node_shell/block_validator.ml
View File

@ -57,14 +57,14 @@ let block_error_encoding =
let open Data_encoding in let open Data_encoding in
union union
[ [
case case (Tag 0)
(obj2 (obj2
(req "error" (constant "cannot_parse_operation")) (req "error" (constant "cannot_parse_operation"))
(req "operation" Operation_hash.encoding)) (req "operation" Operation_hash.encoding))
(function Cannot_parse_operation operation -> Some ((), operation) (function Cannot_parse_operation operation -> Some ((), operation)
| _ -> None) | _ -> None)
(fun ((), operation) -> Cannot_parse_operation operation) ; (fun ((), operation) -> Cannot_parse_operation operation) ;
case case (Tag 1)
(obj3 (obj3
(req "error" (constant "invalid_fitness")) (req "error" (constant "invalid_fitness"))
(req "expected" Fitness.encoding) (req "expected" Fitness.encoding)
@ -74,19 +74,19 @@ let block_error_encoding =
Some ((), expected, found) Some ((), expected, found)
| _ -> None) | _ -> None)
(fun ((), expected, found) -> Invalid_fitness { expected ; found }) ; (fun ((), expected, found) -> Invalid_fitness { expected ; found }) ;
case case (Tag 2)
(obj1 (obj1
(req "error" (constant "non_increasing_timestamp"))) (req "error" (constant "non_increasing_timestamp")))
(function Non_increasing_timestamp -> Some () (function Non_increasing_timestamp -> Some ()
| _ -> None) | _ -> None)
(fun () -> Non_increasing_timestamp) ; (fun () -> Non_increasing_timestamp) ;
case case (Tag 3)
(obj1 (obj1
(req "error" (constant "non_increasing_fitness"))) (req "error" (constant "non_increasing_fitness")))
(function Non_increasing_fitness -> Some () (function Non_increasing_fitness -> Some ()
| _ -> None) | _ -> None)
(fun () -> Non_increasing_fitness) ; (fun () -> Non_increasing_fitness) ;
case case (Tag 4)
(obj3 (obj3
(req "error" (constant "invalid_level")) (req "error" (constant "invalid_level"))
(req "expected" int32) (req "expected" int32)
@ -96,7 +96,7 @@ let block_error_encoding =
Some ((), expected, found) Some ((), expected, found)
| _ -> None) | _ -> None)
(fun ((), expected, found) -> Invalid_level { expected ; found }) ; (fun ((), expected, found) -> Invalid_level { expected ; found }) ;
case case (Tag 5)
(obj3 (obj3
(req "error" (constant "invalid_proto_level")) (req "error" (constant "invalid_proto_level"))
(req "expected" uint8) (req "expected" uint8)
@ -107,14 +107,14 @@ let block_error_encoding =
| _ -> None) | _ -> None)
(fun ((), expected, found) -> (fun ((), expected, found) ->
Invalid_proto_level { expected ; found }) ; Invalid_proto_level { expected ; found }) ;
case case (Tag 6)
(obj2 (obj2
(req "error" (constant "replayed_operation")) (req "error" (constant "replayed_operation"))
(req "operation" Operation_hash.encoding)) (req "operation" Operation_hash.encoding))
(function Replayed_operation operation -> Some ((), operation) (function Replayed_operation operation -> Some ((), operation)
| _ -> None) | _ -> None)
(fun ((), operation) -> Replayed_operation operation) ; (fun ((), operation) -> Replayed_operation operation) ;
case case (Tag 7)
(obj3 (obj3
(req "error" (constant "outdated_operation")) (req "error" (constant "outdated_operation"))
(req "operation" Operation_hash.encoding) (req "operation" Operation_hash.encoding)
@ -125,7 +125,7 @@ let block_error_encoding =
| _ -> None) | _ -> None)
(fun ((), operation, originating_block) -> (fun ((), operation, originating_block) ->
Outdated_operation { operation ; originating_block }) ; Outdated_operation { operation ; originating_block }) ;
case case (Tag 8)
(obj2 (obj2
(req "error" (constant "unexpected_number_of_passes")) (req "error" (constant "unexpected_number_of_passes"))
(req "found" uint8)) (req "found" uint8))
@ -133,7 +133,7 @@ let block_error_encoding =
| Unexpected_number_of_validation_passes n -> Some ((), n) | Unexpected_number_of_validation_passes n -> Some ((), n)
| _ -> None) | _ -> None)
(fun ((), n) -> Unexpected_number_of_validation_passes n) ; (fun ((), n) -> Unexpected_number_of_validation_passes n) ;
case case (Tag 9)
(obj4 (obj4
(req "error" (constant "too_many_operations")) (req "error" (constant "too_many_operations"))
(req "validation_pass" uint8) (req "validation_pass" uint8)
@ -145,7 +145,7 @@ let block_error_encoding =
| _ -> None) | _ -> None)
(fun ((), pass, found, max) -> (fun ((), pass, found, max) ->
Too_many_operations { pass ; found ; max }) ; Too_many_operations { pass ; found ; max }) ;
case case (Tag 10)
(obj4 (obj4
(req "error" (constant "oversized_operation")) (req "error" (constant "oversized_operation"))
(req "operation" Operation_hash.encoding) (req "operation" Operation_hash.encoding)

4
lib_node_shell/protocol_validator.ml
View File

@ -34,13 +34,13 @@ let protocol_error_encoding =
let open Data_encoding in let open Data_encoding in
union union
[ [
case case (Tag 0)
(obj1 (obj1
(req "error" (constant "compilation_failed"))) (req "error" (constant "compilation_failed")))
(function Compilation_failed -> Some () (function Compilation_failed -> Some ()
| _ -> None) | _ -> None)
(fun () -> Compilation_failed) ; (fun () -> Compilation_failed) ;
case case (Tag 1)
(obj1 (obj1
(req "error" (constant "dynlinking_failed"))) (req "error" (constant "dynlinking_failed")))
(function Dynlinking_failed -> Some () (function Dynlinking_failed -> Some ()

4
lib_protocol_environment_sigs/v1/data_encoding.mli
View File

@ -160,9 +160,11 @@ val list : 'a encoding -> 'a list encoding
val assoc : 'a encoding -> (string * 'a) list encoding val assoc : 'a encoding -> (string * 'a) list encoding
type case_tag = Tag of int | Json_only
type 't case type 't case
val case : val case :
?tag:int -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case case_tag -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
val union : val union :
?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding ?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding

20
lib_rpc-base/RPC_encoding.ml
View File

@ -36,10 +36,10 @@ let meth_encoding =
let path_item_encoding = let path_item_encoding =
let open Data_encoding in let open Data_encoding in
union [ union [
case ~tag:0 string case (Tag 0) string
(function PStatic s -> Some s | _ -> None) (function PStatic s -> Some s | _ -> None)
(fun s -> PStatic s) ; (fun s -> PStatic s) ;
case ~tag:1 arg_encoding case (Tag 1) arg_encoding
(function PDynamic s -> Some s | _ -> None) (function PDynamic s -> Some s | _ -> None)
(fun s -> PDynamic s) ; (fun s -> PDynamic s) ;
] ]
@ -47,19 +47,19 @@ let path_item_encoding =
let query_kind_encoding = let query_kind_encoding =
let open Data_encoding in let open Data_encoding in
union [ union [
case ~tag:0 case (Tag 0)
(obj1 (req "single" arg_encoding)) (obj1 (req "single" arg_encoding))
(function Single s -> Some s | _ -> None) (function Single s -> Some s | _ -> None)
(fun s -> Single s) ; (fun s -> Single s) ;
case ~tag:1 case (Tag 1)
(obj1 (req "optional" arg_encoding)) (obj1 (req "optional" arg_encoding))
(function Optional s -> Some s | _ -> None) (function Optional s -> Some s | _ -> None)
(fun s -> Optional s) ; (fun s -> Optional s) ;
case ~tag:2 case (Tag 2)
(obj1 (req "flag" empty)) (obj1 (req "flag" empty))
(function Flag -> Some () | _ -> None) (function Flag -> Some () | _ -> None)
(fun () -> Flag) ; (fun () -> Flag) ;
case ~tag:3 case (Tag 3)
(obj1 (req "multi" arg_encoding)) (obj1 (req "multi" arg_encoding))
(function Multi s -> Some s | _ -> None) (function Multi s -> Some s | _ -> None)
(fun s -> Multi s) ; (fun s -> Multi s) ;
@ -96,7 +96,7 @@ let directory_descr_encoding =
mu "service_tree" @@ fun directory_descr_encoding -> mu "service_tree" @@ fun directory_descr_encoding ->
let static_subdirectories_descr_encoding = let static_subdirectories_descr_encoding =
union [ union [
case ~tag:0 (obj1 (req "suffixes" case (Tag 0) (obj1 (req "suffixes"
(list (obj2 (req "name" string) (list (obj2 (req "name" string)
(req "tree" directory_descr_encoding))))) (req "tree" directory_descr_encoding)))))
(function Suffixes map -> (function Suffixes map ->
@ -104,7 +104,7 @@ let directory_descr_encoding =
(fun m -> (fun m ->
let add acc (n,t) = StringMap.add n t acc in let add acc (n,t) = StringMap.add n t acc in
Suffixes (List.fold_left add StringMap.empty m)) ; Suffixes (List.fold_left add StringMap.empty m)) ;
case ~tag:1 (obj1 (req "dynamic_dispatch" case (Tag 1) (obj1 (req "dynamic_dispatch"
(obj2 (obj2
(req "arg" arg_encoding) (req "arg" arg_encoding)
(req "tree" directory_descr_encoding)))) (req "tree" directory_descr_encoding))))
@ -140,10 +140,10 @@ let directory_descr_encoding =
(opt "patch_service" service_descr_encoding) (opt "patch_service" service_descr_encoding)
(opt "subdirs" static_subdirectories_descr_encoding)) in (opt "subdirs" static_subdirectories_descr_encoding)) in
union [ union [
case ~tag:0 (obj1 (req "static" static_directory_descr_encoding)) case (Tag 0) (obj1 (req "static" static_directory_descr_encoding))
(function Static descr -> Some descr | _ -> None) (function Static descr -> Some descr | _ -> None)
(fun descr -> Static descr) ; (fun descr -> Static descr) ;
case ~tag:1 (obj1 (req "dynamic" (option string))) case (Tag 1) (obj1 (req "dynamic" (option string)))
(function Dynamic descr -> Some descr | _ -> None) (function Dynamic descr -> Some descr | _ -> None)
(fun descr -> Dynamic descr) ; (fun descr -> Dynamic descr) ;
] ]

18
lib_rpc-http/RPC_client.ml
View File

@ -48,36 +48,36 @@ type rest_error =
let rest_error_encoding = let rest_error_encoding =
let open Data_encoding in let open Data_encoding in
union union
[ case ~tag: 0 [ case (Tag 0)
(obj1 (obj1
(req "kind" (constant "empty_answer"))) (req "kind" (constant "empty_answer")))
(function Empty_answer -> Some () | _ -> None) (function Empty_answer -> Some () | _ -> None)
(fun () -> Empty_answer) ; (fun () -> Empty_answer) ;
case ~tag: 1 case (Tag 1)
(obj2 (obj2
(req "kind" (constant "connection_failed")) (req "kind" (constant "connection_failed"))
(req "message" string)) (req "message" string))
(function Connection_failed msg -> Some ((), msg) | _ -> None) (function Connection_failed msg -> Some ((), msg) | _ -> None)
(function (), msg -> Connection_failed msg) ; (function (), msg -> Connection_failed msg) ;
case ~tag: 2 case (Tag 2)
(obj2 (obj2
(req "kind" (constant "bad_request")) (req "kind" (constant "bad_request"))
(req "message" string)) (req "message" string))
(function Bad_request msg -> Some ((), msg) | _ -> None) (function Bad_request msg -> Some ((), msg) | _ -> None)
(function (), msg -> Bad_request msg) ; (function (), msg -> Bad_request msg) ;
case ~tag: 3 case (Tag 3)
(obj2 (obj2
(req "kind" (constant "method_not_allowed")) (req "kind" (constant "method_not_allowed"))
(req "allowed" (list RPC_service.meth_encoding))) (req "allowed" (list RPC_service.meth_encoding)))
(function Method_not_allowed meths -> Some ((), meths) | _ -> None) (function Method_not_allowed meths -> Some ((), meths) | _ -> None)
(function ((), meths) -> Method_not_allowed meths) ; (function ((), meths) -> Method_not_allowed meths) ;
case ~tag: 4 case (Tag 4)
(obj2 (obj2
(req "kind" (constant "unsupported_media_type")) (req "kind" (constant "unsupported_media_type"))
(opt "content_type" string)) (opt "content_type" string))
(function Unsupported_media_type m -> Some ((), m) | _ -> None) (function Unsupported_media_type m -> Some ((), m) | _ -> None)
(function ((), m) -> Unsupported_media_type m) ; (function ((), m) -> Unsupported_media_type m) ;
case ~tag: 5 case (Tag 5)
(obj3 (obj3
(req "kind" (constant "not_acceptable")) (req "kind" (constant "not_acceptable"))
(req "proposed" string) (req "proposed" string)
@ -88,7 +88,7 @@ let rest_error_encoding =
| _ -> None) | _ -> None)
(function ((), proposed, acceptable) -> (function ((), proposed, acceptable) ->
Not_acceptable { proposed ; acceptable }) ; Not_acceptable { proposed ; acceptable }) ;
case ~tag: 6 case (Tag 6)
(obj4 (obj4
(req "kind" (constant "unexpected_status_code")) (req "kind" (constant "unexpected_status_code"))
(req "code" uint16) (req "code" uint16)
@ -101,7 +101,7 @@ let rest_error_encoding =
(function ((), code, content, media_type) -> (function ((), code, content, media_type) ->
let code = Cohttp.Code.status_of_code code in let code = Cohttp.Code.status_of_code code in
Unexpected_status_code { code ; content ; media_type }) ; Unexpected_status_code { code ; content ; media_type }) ;
case ~tag: 7 case (Tag 7)
(obj3 (obj3
(req "kind" (constant "unexpected_content_type")) (req "kind" (constant "unexpected_content_type"))
(req "received" string) (req "received" string)
@ -112,7 +112,7 @@ let rest_error_encoding =
| _ -> None) | _ -> None)
(function ((), received, acceptable) -> (function ((), received, acceptable) ->
Unexpected_content_type { received ; acceptable }) ; Unexpected_content_type { received ; acceptable }) ;
case ~tag: 8 case (Tag 8)
(obj4 (obj4
(req "kind" (constant "unexpected_content")) (req "kind" (constant "unexpected_content"))
(req "content" string) (req "content" string)

90
test/utils/bench_data_encoding.ml Normal file
View File

@ -0,0 +1,90 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
let bench ?(num_iterations=1000) name thunk =
Gc.full_major () ;
Gc.compact () ;
let start_time = Sys.time () in
for i = 0 to (num_iterations - 1) do
thunk ()
done ;
let end_time = Sys.time () in
Format.printf
"Benchmark: %s took %f for %d iterations.@."
name
(end_time -. start_time)
num_iterations
let bench_json_binary ?(num_iterations=1000) name encoding value =
bench ~num_iterations ("writing " ^ name ^ " json")
(fun () -> ignore @@ Data_encoding_ezjsonm.to_string @@ Data_encoding.Json.construct encoding value) ;
let encoded_json = Data_encoding_ezjsonm.to_string @@ Data_encoding.Json.construct encoding value in
bench ~num_iterations ("reading " ^ name ^ " json")
(fun () -> Data_encoding.Json.destruct encoding (Ezjsonm.from_string encoded_json)) ;
bench ~num_iterations ("writing " ^ name ^ " binary")
(fun () -> ignore @@ Data_encoding.Binary.to_bytes encoding value) ;
let encoded_binary = Data_encoding.Binary.to_bytes encoding value in
bench ~num_iterations ("reading " ^ name ^ " binary")
(fun () -> ignore @@ Data_encoding.Binary.of_bytes_exn encoding encoded_binary)
type t =
| A of string
| B of bool
| I of int
| F of float
| R of t * t
let cases_encoding : t Data_encoding.t =
let open Data_encoding in
mu "recursive"
(fun recursive -> union [
case (Tag 0)
string
(function A s -> Some s
| _ -> None)
(fun s -> A s) ;
case (Tag 1)
bool
(function B bool -> Some bool
| _ -> None)
(fun bool -> B bool) ;
case (Tag 2)
int31
(function I int -> Some int
| _ -> None)
(fun int -> I int) ;
case (Tag 3)
float
(function F float -> Some float
| _ -> None)
(fun float -> F float) ;
case (Tag 4)
(obj2 (req "field1" recursive)
(req "field2" recursive))
(function R (a, b) -> Some (a, b)
| _ -> None)
(fun (a, b) -> R (a, b))
])
let () =
(* bench_json_binary "1000_element_int_list" Data_encoding.(list int31) (Array.to_list (Array.make 1000 0)) *)
(* bench_json_binary "option_element_int_list" Data_encoding.(list (option int31)) (Array.to_list (Array.make 1000 (Some 0))) *)
(* bench_json_binary "option_option_element_list"
* Data_encoding.(list (option (option int31)))
* (Array.to_list (Array.make 1000 (Some None))) *)
bench_json_binary "option_option_result_element_list"
Data_encoding.(list (result (option (option int31)) string))
(Array.to_list (Array.make 1000 (Error "hello")))
(* bench ~num_iterations:10000 "binary_encoding"
* (let encoding = Data_encoding.(list cases_encoding) in
* let value = Array.to_list (Array.make 1000 (R (R (A "asdf", B true), F 1.0))) in
* (fun () -> ignore @@ Data_encoding.Binary.to_bytes encoding value)) *)
(* bench_json_binary "binary_encoding_large_list"
* Data_encoding.(list cases_encoding)
* (Array.to_list (Array.make 10000 (R (R (A "asdf", B true), F 1.0)))) *)

38
test/utils/test_data_encoding.ml
View File

@ -135,11 +135,11 @@ let prn_t = function
let test_tag_errors _ = let test_tag_errors _ =
let duplicate_tag () = let duplicate_tag () =
union [ union [
case ~tag:1 case (Tag 1)
int8 int8
(fun i -> i) (fun i -> i)
(fun i -> Some i) ; (fun i -> Some i) ;
case ~tag:1 case (Tag 1)
int8 int8
(fun i -> i) (fun i -> i)
(fun i -> Some i)] in (fun i -> Some i)] in
@ -148,7 +148,7 @@ let test_tag_errors _ =
| _ -> false) ; | _ -> false) ;
let invalid_tag () = let invalid_tag () =
union [ union [
case ~tag:(2 lsl 7) case (Tag (2 lsl 7))
int8 int8
(fun i -> i) (fun i -> i)
(fun i -> Some i)] in (fun i -> Some i)] in
@ -160,19 +160,19 @@ let test_tag_errors _ =
let test_union _ = let test_union _ =
let enc = let enc =
(union [ (union [
case ~tag:1 case (Tag 1)
int8 int8
(function A i -> Some i | _ -> None) (function A i -> Some i | _ -> None)
(fun i -> A i) ; (fun i -> A i) ;
case ~tag:2 case (Tag 2)
string string
(function B s -> Some s | _ -> None) (function B s -> Some s | _ -> None)
(fun s -> B s) ; (fun s -> B s) ;
case ~tag:3 case (Tag 3)
int8 int8
(function C i -> Some i | _ -> None) (function C i -> Some i | _ -> None)
(fun i -> C i) ; (fun i -> C i) ;
case ~tag:4 case (Tag 4)
(obj2 (obj2
(req "kind" (constant "D")) (req "kind" (constant "D"))
(req "data" (string))) (req "data" (string)))
@ -182,7 +182,7 @@ let test_union _ =
let jsonA = Json.construct enc (A 1) in let jsonA = Json.construct enc (A 1) in
let jsonB = Json.construct enc (B "2") in let jsonB = Json.construct enc (B "2") in
let jsonC = Json.construct enc (C 3) in let jsonC = Json.construct enc (C 3) in
let jsonD = Json.construct enc (D"4") in let jsonD = Json.construct enc (D "4") in
Assert.test_fail Assert.test_fail
~msg:__LOC__ (fun () -> Json.construct enc E) is_invalid_arg ; ~msg:__LOC__ (fun () -> Json.construct enc E) is_invalid_arg ;
Assert.equal ~prn:prn_t ~msg:__LOC__ (A 1) (Json.destruct enc jsonA) ; Assert.equal ~prn:prn_t ~msg:__LOC__ (A 1) (Json.destruct enc jsonA) ;
@ -225,11 +225,11 @@ let test_splitted _ =
~binary:string ~binary:string
~json: ~json:
(union [ (union [
case ~tag:1 case (Tag 1)
string string
(fun _ -> None) (fun _ -> None)
(fun s -> s) ; (fun s -> s) ;
case ~tag:2 case (Tag 2)
s_enc s_enc
(fun s -> Some { field = int_of_string s }) (fun s -> Some { field = int_of_string s })
(fun s -> string_of_int s.field) ; (fun s -> string_of_int s.field) ;
@ -315,6 +315,23 @@ let wrap_test f base_dir =
f base_dir >>= fun result -> f base_dir >>= fun result ->
return result return result
let test_wrapped_binary _ =
let open Data_encoding in
let enc = union [
case (Tag 0)
(obj1 (req "ok" string))
(function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ;
case (Tag 1)
(obj1 (req "error" string))
(function Error x -> Some x | _ -> None)
(fun x -> Error x) ;
] in
let data = (Ok "") in
let encoded = Data_encoding.Binary.to_bytes enc data in
let decoded = Data_encoding.Binary.of_bytes_exn enc encoded in
Lwt.return @@ Assert.equal data decoded
let tests = [ let tests = [
"simple", test_simple_values ; "simple", test_simple_values ;
"json", test_json ; "json", test_json ;
@ -322,6 +339,7 @@ let tests = [
"splitted", test_splitted ; "splitted", test_splitted ;
"json.input", test_json_input ; "json.input", test_json_input ;
"tags", test_tag_errors ; "tags", test_tag_errors ;
"wrapped_binary", test_wrapped_binary ;
] ]
let () = let () =

12
test/utils/test_stream_data_encoding.ml
View File

@ -323,19 +323,19 @@ let prn_t = function
let test_union _ = let test_union _ =
let enc = let enc =
(union [ (union [
case ~tag:1 case (Tag 1)
int8 int8
(function A i -> Some i | _ -> None) (function A i -> Some i | _ -> None)
(fun i -> A i) ; (fun i -> A i) ;
case ~tag:2 case (Tag 2)
string string
(function B s -> Some s | _ -> None) (function B s -> Some s | _ -> None)
(fun s -> B s) ; (fun s -> B s) ;
case ~tag:3 case (Tag 3)
int8 int8
(function C i -> Some i | _ -> None) (function C i -> Some i | _ -> None)
(fun i -> C i) ; (fun i -> C i) ;
case ~tag:4 case (Tag 4)
(obj2 (obj2
(req "kind" (constant "D")) (req "kind" (constant "D"))
(req "data" (string))) (req "data" (string)))
@ -398,11 +398,11 @@ let test_splitted _ =
~binary:string ~binary:string
~json: ~json:
(union [ (union [
case ~tag:1 case (Tag 1)
string string
(fun _ -> None) (fun _ -> None)
(fun s -> s) ; (fun s -> s) ;
case ~tag:2 case (Tag 2)
s_enc s_enc
(fun s -> Some { field = int_of_string s }) (fun s -> Some { field = int_of_string s })
(fun s -> string_of_int s.field) ; (fun s -> string_of_int s.field) ;