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

4
lib_base/time.ml
View File

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

6
lib_crypto/blake2B.ml
View File

@ -321,19 +321,19 @@ module Generic_Merkle_tree (H : sig
mu "path"
(fun path_encoding ->
union [
case ~tag:240
case (Tag 240)
(obj2
(req "path" path_encoding)
(req "right" H.encoding))
(function Left (p, r) -> Some (p, r) | _ -> None)
(fun (p, r) -> Left (p, r)) ;
case ~tag:15
case (Tag 15)
(obj2
(req "left" H.encoding)
(req "path" path_encoding))
(function Right (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Right (r, p)) ;
case ~tag:0
case (Tag 0)
unit
(function Op -> Some () | _ -> None)
(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 Invalid_size of int
let apply fs v =
let apply ?(error=No_case_matched) fs v =
let rec loop = function
| [] -> raise No_case_matched
| [] -> raise error
| f :: fs ->
match f v with
| Some l -> l
@ -107,6 +107,8 @@ module Kind = struct
end
type case_tag = Tag of int | Json_only
type 'a desc =
| Null : unit desc
| Empty : unit desc
@ -158,7 +160,7 @@ and 'a case =
| Case : { encoding : 'a t ;
proj : ('t -> 'a option) ;
inj : ('a -> 't) ;
tag : int option } -> 't case
tag : case_tag } -> 't case
and 'a t = {
encoding: 'a desc ;
@ -685,8 +687,8 @@ module Encoding = struct
List.fold_left
(fun others (Case { tag }) ->
match tag with
| None -> others
| Some tag ->
| Json_only -> others
| Tag tag ->
if List.mem tag others then raise (Duplicated_tag tag) ;
if tag < 0 || max_tag <= tag then
raise (Invalid_tag (tag, tag_size)) ;
@ -700,14 +702,14 @@ module Encoding = struct
List.map (fun (Case { encoding }) -> classify encoding) cases in
let kind = Kind.merge_list tag_size kinds in
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 =
union
~tag_size:`Uint8
[ case ~tag:1 ty
[ case (Tag 1) ty
(fun x -> x)
(fun x -> Some x) ;
case ~tag:0 empty
case (Tag 0) empty
(function None -> Some () | Some _ -> None)
(fun () -> None) ;
]
@ -725,10 +727,10 @@ module Encoding = struct
let result ok_enc error_enc =
union
~tag_size:`Uint8
[ case ~tag:1 ok_enc
[ case (Tag 1) ok_enc
(function Ok x -> Some x | Error _ -> None)
(fun x -> Ok x) ;
case ~tag:0 error_enc
case (Tag 0) error_enc
(function Ok _ -> None | Error x -> Some x)
(fun x -> Error x) ;
]
@ -782,12 +784,10 @@ module Binary = struct
let length2 = length e2 in
fun (v1, v2) -> length1 v1 + length2 v2
| Union (`Dynamic, sz, cases) ->
let case_length = function
| Case { tag = None } -> None
| Case { encoding = e ; proj ; tag = Some _ } ->
let length v = tag_size sz + length e v in
Some (fun v -> Option.map ~f:length (proj v)) in
apply (TzList.filter_map case_length cases)
let case_length (Case { encoding = e ; proj }) =
let length v = tag_size sz + length e v in
fun v -> Option.map ~f:length (proj v) in
apply (List.map case_length cases)
| Mu (`Dynamic, _name, self) ->
fun v -> length (self e) v
| Obj (Opt (`Dynamic, _, e)) ->
@ -828,15 +828,24 @@ module Binary = struct
let length = length e in
(function None -> 0 | Some x -> length x)
| Union (`Variable, sz, cases) ->
let case_length = function
| Case { tag = None } -> None
| Case { encoding = e ; proj ; tag = Some _ } ->
let rec case_lengths json_only_cases acc = function
| [] -> (List.rev acc, json_only_cases)
| 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
Some (fun v ->
match proj v with
| None -> None
| Some v -> Some (length v)) in
apply (TzList.filter_map case_length cases)
case_lengths
json_only_cases
((fun v ->
match proj v with
| 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) ->
fun v -> length (self e) v
(* Recursive*)
@ -944,17 +953,16 @@ module Binary = struct
let union w sz cases =
let writes_case = function
| Case { tag = None } ->
(fun _ -> None)
| Case { encoding = e ; proj ; tag = Some tag } ->
| Case { tag = Json_only } -> None
| Case { encoding = e ; proj ; tag = Tag tag } ->
let write = w.write e in
let write v buf ofs =
write_tag sz tag buf ofs |> write v buf in
fun v ->
match proj v with
| None -> None
| Some v -> Some (write v) in
apply (List.map writes_case cases)
Some (fun v ->
match proj v with
| None -> None
| Some v -> Some (write v)) in
apply (TzList.filter_map writes_case cases)
end
@ -1150,8 +1158,8 @@ module Binary = struct
let read_cases =
TzList.filter_map
(function
| (Case { tag = None }) -> None
| (Case { encoding = e ; inj ; tag = Some tag }) ->
| (Case { tag = Json_only }) -> None
| (Case { encoding = e ; inj ; tag = Tag tag }) ->
let read = r.read e in
Some (tag, fun len buf ofs ->
let ofs, v = read len buf ofs in
@ -1510,7 +1518,7 @@ module Binary = struct
let opt =
List.fold_left
(fun acc c -> match c with
| (Case { encoding ; tag = Some tag })
| (Case { encoding ; tag = Tag tag })
when tag == ctag ->
assert (acc == None) ;
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. *)
type 't case
type case_tag = Tag of int | Json_only
(** Encodes a variant constructor. Takes the encoding for the specific
parameters, a recognizer function that will extract the parameters
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. *)
val case :
?tag:int ->
case_tag ->
'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
(** 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
~binary:
(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)
(fun k -> Default k) ;
case ~tag:1 Contract_hash.encoding
case (Tag 1) Contract_hash.encoding
(function Originated k -> Some k | _ -> None)
(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
let hash_case tag =
case ~tag Ed25519.Public_key_hash.encoding
case tag Ed25519.Public_key_hash.encoding
(function
| Hash hash -> Some hash
| _ -> None)
(fun hash -> Hash hash)
let pubkey_case tag =
case ~tag Ed25519.Public_key.encoding
case tag Ed25519.Public_key.encoding
(function
| Public_key hash -> Some hash
| _ -> None)
@ -34,7 +34,7 @@ let pubkey_case tag =
let encoding =
union [
hash_case 0 ;
pubkey_case 1 ;
hash_case (Tag 0) ;
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))
let transaction_case tag =
case ~tag transaction_encoding
case tag transaction_encoding
(function
| Transaction { amount ; destination ; parameters } ->
Some ((), amount, destination, parameters)
@ -119,7 +119,7 @@ module Encoding = struct
(opt "script" Script_repr.encoding))
let origination_case tag =
case ~tag origination_encoding
case tag origination_encoding
(function
| Origination { manager ; credit ; spendable ;
delegatable ; delegate ; script } ->
@ -140,7 +140,7 @@ module Encoding = struct
(opt "delegate" Ed25519.Public_key_hash.encoding))
let delegation_case tag =
case ~tag delegation_encoding
case tag delegation_encoding
(function Delegation key -> Some ((), key) | _ -> None)
(fun ((), key) -> Delegation key)
@ -152,13 +152,13 @@ module Encoding = struct
(req "counter" int32)
(req "operations"
(list (union ~tag_size:`Uint8 [
transaction_case 0 ;
origination_case 1 ;
delegation_case 2 ;
transaction_case (Tag 0) ;
origination_case (Tag 1) ;
delegation_case (Tag 2) ;
]))))
let manager_kind_case tag =
case ~tag manager_kind_encoding
case tag manager_kind_encoding
(function
| Manager_operations { source; public_key ; fee ; counter ;operations } ->
Some (source, public_key, fee, counter, operations)
@ -173,7 +173,7 @@ module Encoding = struct
(req "slot" int31))
let endorsement_case tag =
case ~tag endorsement_encoding
case tag endorsement_encoding
(function
| Endorsement { block ; slot } ->
Some ((), block, slot)
@ -188,7 +188,7 @@ module Encoding = struct
(req "proposals" (list Protocol_hash.encoding)))
let proposal_case tag =
case ~tag proposal_encoding
case tag proposal_encoding
(function
| Proposals { period ; proposals } ->
Some ((), period, proposals)
@ -204,7 +204,7 @@ module Encoding = struct
(req "ballot" Vote_repr.ballot_encoding))
let ballot_case tag =
case ~tag ballot_encoding
case tag ballot_encoding
(function
| Ballot { period ; proposal ; ballot } ->
Some ((), period, proposal, ballot)
@ -217,13 +217,13 @@ module Encoding = struct
(req "source" Ed25519.Public_key.encoding)
(req "operations"
(list (union [
endorsement_case 0 ;
proposal_case 1 ;
ballot_case 2 ;
endorsement_case (Tag 0) ;
proposal_case (Tag 1) ;
ballot_case (Tag 2) ;
]))))
let delegate_kind_case tag =
case ~tag delegate_kind_encoding
case tag delegate_kind_encoding
(function
| Delegate_operations { source ; operations } ->
Some (source, operations)
@ -241,12 +241,12 @@ module Encoding = struct
args) in
let open Data_encoding in
union ~tag_size:`Uint8 [
case ~tag:0
case (Tag 0)
(mk_case "activate"
(obj1 (req "hash" Protocol_hash.encoding)))
(function (Activate hash) -> Some hash | _ -> None)
(fun hash -> Activate hash) ;
case ~tag:1
case (Tag 1)
(mk_case "activate_testnet"
(obj1 (req "hash" Protocol_hash.encoding)))
(function (Activate_testnet hash) -> Some hash | _ -> None)
@ -254,16 +254,16 @@ module Encoding = struct
]
let dictator_kind_case tag =
case ~tag dictator_kind_encoding
case tag dictator_kind_encoding
(function Dictator_operation op -> Some op | _ -> None)
(fun op -> Dictator_operation op)
let signed_operations_case tag =
case ~tag
case tag
(union [
manager_kind_case 0 ;
delegate_kind_case 1 ;
dictator_kind_case 2 ;
manager_kind_case (Tag 0) ;
delegate_kind_case (Tag 1) ;
dictator_kind_case (Tag 2) ;
])
(function Sourced_operations ops -> Some ops | _ -> None)
(fun ops -> Sourced_operations ops)
@ -275,7 +275,7 @@ module Encoding = struct
(req "nonce" Seed_repr.nonce_encoding))
let seed_nonce_revelation_case tag =
case ~tag seed_nonce_revelation_encoding
case tag seed_nonce_revelation_encoding
(function
| Seed_nonce_revelation { level ; nonce } -> Some ((), level, nonce)
| _ -> None
@ -289,7 +289,7 @@ module Encoding = struct
(req "nonce" (Fixed.bytes 16)))
let faucet_case tag =
case ~tag faucet_encoding
case tag faucet_encoding
(function
| Faucet { id ; nonce } -> Some ((), id, nonce)
| _ -> None
@ -297,21 +297,21 @@ module Encoding = struct
(fun ((), id, nonce) -> Faucet { id ; nonce })
let unsigned_operation_case tag =
case ~tag
case tag
(obj1
(req "operations"
(list
(union [
seed_nonce_revelation_case 0 ;
faucet_case 1 ;
seed_nonce_revelation_case (Tag 0) ;
faucet_case (Tag 1) ;
]))))
(function Anonymous_operations ops -> Some ops | _ -> None)
(fun ops -> Anonymous_operations ops)
let proto_operation_encoding =
union [
signed_operations_case 0 ;
unsigned_operation_case 1 ;
signed_operations_case (Tag 0) ;
unsigned_operation_case (Tag 1) ;
]
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 open Data_encoding in
union [
case ~tag:0
case (Tag 0)
(obj1 (req "incompatible_protocol_version" string))
(function Incompatible_protocol_version arg -> Some arg | _ -> None)
(fun arg -> Incompatible_protocol_version arg) ;
case ~tag:1
case (Tag 1)
(obj2
(req "missing_key" (list string))
(req "function" (string_enum ["get", `Get ; "set", `Set])))
(function Missing_key (key, f) -> Some (key, f) | _ -> None)
(fun (key, f) -> Missing_key (key, f)) ;
case ~tag:2
case (Tag 2)
(obj1 (req "existing_key" (list string)))
(function Existing_key key -> Some key | _ -> None)
(fun key -> Existing_key key) ;
case ~tag:3
case (Tag 3)
(obj1 (req "corrupted_data" (list string)))
(function Corrupted_data key -> Some key | _ -> None)
(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 open Data_encoding in
union [
case
case (Tag 0)
(obj1 (req "ok" encoding))
(function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ;
case
case (Tag 1)
(obj1 (req "error" error_encoding))
(function Error x -> Some x | _ -> None)
(fun x -> Error x) ;
@ -229,15 +229,15 @@ module Context = struct
let nonce_encoding =
union [
case
case (Tag 0)
(obj1 (req "nonce" Nonce.encoding))
(function Revealed nonce -> Some nonce | _ -> None)
(fun nonce -> Revealed nonce) ;
case
case (Tag 1)
(obj1 (req "hash" Nonce_hash.encoding))
(function Missing nonce -> Some nonce | _ -> None)
(fun nonce -> Missing nonce) ;
case
case (Tag 2)
empty
(function Forgotten -> Some () | _ -> None)
(fun () -> Forgotten) ;

4
lib_embedded_protocol_alpha/src/storage.ml
View File

@ -142,7 +142,7 @@ module Cycle = struct
let nonce_status_encoding =
let open Data_encoding in
union [
case ~tag:0
case (Tag 0)
(tup3
Nonce_hash.encoding
Ed25519.Public_key_hash.encoding
@ -153,7 +153,7 @@ module Cycle = struct
| _ -> None)
(fun (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
(function
| 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 open Data_encoding in
union ~tag_size:`Uint8 [
case ~tag:0
case (Tag 0)
(constant "proposal")
(function Proposal -> Some () | _ -> None)
(fun () -> Proposal) ;
case ~tag:1
case (Tag 1)
(constant "testing_vote")
(function Testing_vote -> Some () | _ -> None)
(fun () -> Testing_vote) ;
case ~tag:2
case (Tag 2)
(constant "testing")
(function Testing -> Some () | _ -> None)
(fun () -> Testing) ;
case ~tag:3
case (Tag 3)
(constant "promotion_vote")
(function Promotion_vote -> Some () | _ -> None)
(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 open Data_encoding in
union [
case
case (Tag 0)
(obj1 (req "ok" encoding))
(function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ;
case
case (Tag 1)
(obj1 (req "error" error_encoding))
(function Error x -> Some x | _ -> None)
(fun x -> Error x) ;

4
lib_embedded_protocol_genesis/src/data.ml
View File

@ -35,7 +35,7 @@ module Command = struct
let encoding =
let open Data_encoding in
union ~tag_size:`Uint8 [
case ~tag:0
case (Tag 0)
(mk_case "activate"
(obj2
(req "hash" Protocol_hash.encoding)
@ -47,7 +47,7 @@ module Command = struct
| _ -> None)
(fun (protocol, validation_passes) ->
Activate { protocol ; validation_passes }) ;
case ~tag:1
case (Tag 1)
(mk_case "activate_testnet"
(obj3
(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 open Data_encoding in
union [
case
case (Tag 0)
(obj1 (req "ok" encoding))
(function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ;
case
case (Tag 1)
(obj1 (req "error" error_encoding))
(function Error x -> Some x | _ -> None)
(fun x -> Error x) ;

12
lib_error_monad/error_monad.ml
View File

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

8
lib_micheline/micheline.ml
View File

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

10
lib_micheline/micheline_parser.ml
View File

@ -65,23 +65,23 @@ type token_value =
let token_value_encoding =
let open Data_encoding in
union
[ case (obj1 (req "string" string))
[ case (Tag 0) (obj1 (req "string" string))
(function String s -> Some s | _ -> None)
(fun s -> String s) ;
case (obj1 (req "int" string))
case (Tag 1) (obj1 (req "int" string))
(function Int s -> Some s | _ -> None)
(fun s -> Int s) ;
case (obj1 (req "annot" string))
case (Tag 2) (obj1 (req "annot" string))
(function Annot s -> Some s | _ -> None)
(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
| Comment s -> Some (s, false)
| Eol_comment s -> Some (s, true) | _ -> None)
(function
| (s, false) -> Comment s
| (s, true) -> Eol_comment s) ;
case
case (Tag 4)
(obj1 (req "punctuation" (string_enum [
"(", Open_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
dynamic_size @@
union ~tag_size:`Uint16
([ case ~tag:0x01 null
([ case (Tag 0x01) null
(function Disconnect -> Some () | _ -> None)
(fun () -> Disconnect);
case ~tag:0x02 null
case (Tag 0x02) null
(function Bootstrap -> Some () | _ -> None)
(fun () -> Bootstrap);
case ~tag:0x03 (Variable.list Point.encoding)
case (Tag 0x03) (Variable.list Point.encoding)
(function Advertise points -> Some points | _ -> None)
(fun points -> Advertise points);
case ~tag:0x04 (tup2 Point.encoding Peer_id.encoding)
case (Tag 0x04) (tup2 Point.encoding Peer_id.encoding)
(function
| Swap_request (point, peer_id) -> Some (point, peer_id)
| _ -> None)
(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
| Swap_ack (point, peer_id) -> Some (point, peer_id)
| _ -> None)
@ -64,7 +64,7 @@ module Message = struct
] @
ListLabels.map msg_encoding
~f:(function Encoding { tag ; encoding ; wrap ; unwrap } ->
case ~tag encoding
case (Tag tag) encoding
(function Message msg -> unwrap msg | _ -> None)
(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
(obj1 (req "event_kind" (constant name))) obj) in
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)
(fun () -> Outgoing_request) ;
case ~tag:1 (branch_encoding "accepting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 1) (branch_encoding "accepting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Accepting_request peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Accepting_request peer_id) ;
case ~tag:2 (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 2) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Rejecting_request peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Rejecting_request peer_id) ;
case ~tag:3 (branch_encoding "request_rejected"
(obj1 (opt "peer_id" Peer_id.encoding)))
case (Tag 3) (branch_encoding "request_rejected"
(obj1 (opt "peer_id" Peer_id.encoding)))
(function Request_rejected peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Request_rejected peer_id) ;
case ~tag:4 (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 4) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Connection_established peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Connection_established peer_id) ;
case ~tag:5 (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 5) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Disconnection peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Disconnection peer_id) ;
case ~tag:6 (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 6) (branch_encoding "rejecting_request"
(obj1 (req "peer_id" Peer_id.encoding)))
(function External_disconnection peer_id -> Some peer_id | _ -> None)
(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
(obj1 (req "event_kind" (constant name))) obj) in
union ~tag_size:`Uint8 [
case ~tag:0 (branch_encoding "requested" empty)
case (Tag 0) (branch_encoding "requested" empty)
(function Requested -> Some () | _ -> None)
(fun () -> Requested) ;
case ~tag:1 (branch_encoding "accepted"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 1) (branch_encoding "accepted"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Accepted peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Accepted peer_id) ;
case ~tag:2 (branch_encoding "running"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 2) (branch_encoding "running"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Running peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Running peer_id) ;
case ~tag:3 (branch_encoding "disconnected" empty)
case (Tag 3) (branch_encoding "disconnected" empty)
(function Disconnected -> Some () | _ -> None)
(fun () -> Disconnected) ;
]
@ -600,114 +600,114 @@ module Connection_pool_log_event = struct
(merge_objs
(obj1 (req "event" (constant name))) obj) in
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)
(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)
(fun () -> Too_many_connections) ;
case ~tag:2 (branch_encoding "new_point"
(obj1 (req "point" Point.encoding)))
case (Tag 2) (branch_encoding "new_point"
(obj1 (req "point" Point.encoding)))
(function New_point p -> Some p | _ -> None)
(fun p -> New_point p) ;
case ~tag:3 (branch_encoding "new_peer"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 3) (branch_encoding "new_peer"
(obj1 (req "peer_id" Peer_id.encoding)))
(function New_peer p -> Some p | _ -> None)
(fun p -> New_peer p) ;
case ~tag:4 (branch_encoding "incoming_connection"
(obj1 (req "point" Point.encoding)))
case (Tag 4) (branch_encoding "incoming_connection"
(obj1 (req "point" Point.encoding)))
(function Incoming_connection p -> Some p | _ -> None)
(fun p -> Incoming_connection p) ;
case ~tag:5 (branch_encoding "outgoing_connection"
(obj1 (req "point" Point.encoding)))
case (Tag 5) (branch_encoding "outgoing_connection"
(obj1 (req "point" Point.encoding)))
(function Outgoing_connection p -> Some p | _ -> None)
(fun p -> Outgoing_connection p) ;
case ~tag:6 (branch_encoding "authentication_failed"
(obj1 (req "point" Point.encoding)))
case (Tag 6) (branch_encoding "authentication_failed"
(obj1 (req "point" Point.encoding)))
(function Authentication_failed p -> Some p | _ -> None)
(fun p -> Authentication_failed p) ;
case ~tag:7 (branch_encoding "accepting_request"
(obj3
(req "point" Point.encoding)
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
case (Tag 7) (branch_encoding "accepting_request"
(obj3
(req "point" Point.encoding)
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
(function Accepting_request (p, id_p, g) ->
Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ;
case ~tag:8 (branch_encoding "rejecting_request"
(obj3
(req "point" Point.encoding)
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
case (Tag 8) (branch_encoding "rejecting_request"
(obj3
(req "point" Point.encoding)
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
(function Rejecting_request (p, id_p, g) ->
Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ;
case ~tag:9 (branch_encoding "request_rejected"
(obj2
(req "point" Point.encoding)
(opt "identity"
(tup2 Id_point.encoding Peer_id.encoding))))
case (Tag 9) (branch_encoding "request_rejected"
(obj2
(req "point" Point.encoding)
(opt "identity"
(tup2 Id_point.encoding Peer_id.encoding))))
(function Request_rejected (p, id) -> Some (p, id) | _ -> None)
(fun (p, id) -> Request_rejected (p, id)) ;
case ~tag:10 (branch_encoding "connection_established"
(obj2
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
case (Tag 10) (branch_encoding "connection_established"
(obj2
(req "id_point" Id_point.encoding)
(req "peer_id" Peer_id.encoding)))
(function Connection_established (id_p, g) ->
Some (id_p, g) | _ -> None)
(fun (id_p, g) -> Connection_established (id_p, g)) ;
case ~tag:11 (branch_encoding "disconnection"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 11) (branch_encoding "disconnection"
(obj1 (req "peer_id" Peer_id.encoding)))
(function Disconnection g -> Some g | _ -> None)
(fun g -> Disconnection g) ;
case ~tag:12 (branch_encoding "external_disconnection"
(obj1 (req "peer_id" Peer_id.encoding)))
case (Tag 12) (branch_encoding "external_disconnection"
(obj1 (req "peer_id" Peer_id.encoding)))
(function External_disconnection g -> Some g | _ -> None)
(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)
(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)
(fun () -> Gc_peer_ids) ;
case ~tag:15 (branch_encoding "swap_request_received"
(obj1 (req "source" Peer_id.encoding)))
case (Tag 15) (branch_encoding "swap_request_received"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_request_received { source } -> Some source
| _ -> None)
(fun source -> Swap_request_received { source }) ;
case ~tag:16 (branch_encoding "swap_ack_received"
(obj1 (req "source" Peer_id.encoding)))
case (Tag 16) (branch_encoding "swap_ack_received"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_ack_received { source } -> Some source
| _ -> None)
(fun source -> Swap_ack_received { source }) ;
case ~tag:17 (branch_encoding "swap_request_sent"
(obj1 (req "source" Peer_id.encoding)))
case (Tag 17) (branch_encoding "swap_request_sent"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_request_sent { source } -> Some source
| _ -> None)
(fun source -> Swap_request_sent { source }) ;
case ~tag:18 (branch_encoding "swap_ack_sent"
(obj1 (req "source" Peer_id.encoding)))
case (Tag 18) (branch_encoding "swap_ack_sent"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_ack_sent { source } -> Some source
| _ -> None)
(fun source -> Swap_ack_sent { source }) ;
case ~tag:19 (branch_encoding "swap_request_ignored"
(obj1 (req "source" Peer_id.encoding)))
case (Tag 19) (branch_encoding "swap_request_ignored"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_request_ignored { source } -> Some source
| _ -> None)
(fun source -> Swap_request_ignored { source }) ;
case ~tag:20 (branch_encoding "swap_success"
(obj1 (req "source" Peer_id.encoding)))
case (Tag 20) (branch_encoding "swap_success"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_success { source } -> Some source
| _ -> None)
(fun source -> Swap_success { source }) ;
case ~tag:21 (branch_encoding "swap_failure"
(obj1 (req "source" Peer_id.encoding)))
case (Tag 21) (branch_encoding "swap_failure"
(obj1 (req "source" Peer_id.encoding)))
(function
| Swap_failure { source } -> Some source
| _ -> None)

4
lib_node_services/node_rpc_services.ml
View File

@ -37,11 +37,11 @@ module Error = struct
let wrap param_encoding =
union [
case
case (Tag 0)
(obj1 (req "ok" param_encoding))
(function Ok x -> Some x | _ -> None)
(fun x -> Ok x) ;
case
case (Tag 1)
(obj1 (req "error" encoding))
(function Error x -> Some x | _ -> None)
(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
union
[
case
case (Tag 0)
(obj2
(req "error" (constant "cannot_parse_operation"))
(req "operation" Operation_hash.encoding))
(function Cannot_parse_operation operation -> Some ((), operation)
| _ -> None)
(fun ((), operation) -> Cannot_parse_operation operation) ;
case
case (Tag 1)
(obj3
(req "error" (constant "invalid_fitness"))
(req "expected" Fitness.encoding)
@ -74,19 +74,19 @@ let block_error_encoding =
Some ((), expected, found)
| _ -> None)
(fun ((), expected, found) -> Invalid_fitness { expected ; found }) ;
case
case (Tag 2)
(obj1
(req "error" (constant "non_increasing_timestamp")))
(function Non_increasing_timestamp -> Some ()
| _ -> None)
(fun () -> Non_increasing_timestamp) ;
case
case (Tag 3)
(obj1
(req "error" (constant "non_increasing_fitness")))
(function Non_increasing_fitness -> Some ()
| _ -> None)
(fun () -> Non_increasing_fitness) ;
case
case (Tag 4)
(obj3
(req "error" (constant "invalid_level"))
(req "expected" int32)
@ -96,7 +96,7 @@ let block_error_encoding =
Some ((), expected, found)
| _ -> None)
(fun ((), expected, found) -> Invalid_level { expected ; found }) ;
case
case (Tag 5)
(obj3
(req "error" (constant "invalid_proto_level"))
(req "expected" uint8)
@ -107,14 +107,14 @@ let block_error_encoding =
| _ -> None)
(fun ((), expected, found) ->
Invalid_proto_level { expected ; found }) ;
case
case (Tag 6)
(obj2
(req "error" (constant "replayed_operation"))
(req "operation" Operation_hash.encoding))
(function Replayed_operation operation -> Some ((), operation)
| _ -> None)
(fun ((), operation) -> Replayed_operation operation) ;
case
case (Tag 7)
(obj3
(req "error" (constant "outdated_operation"))
(req "operation" Operation_hash.encoding)
@ -125,7 +125,7 @@ let block_error_encoding =
| _ -> None)
(fun ((), operation, originating_block) ->
Outdated_operation { operation ; originating_block }) ;
case
case (Tag 8)
(obj2
(req "error" (constant "unexpected_number_of_passes"))
(req "found" uint8))
@ -133,7 +133,7 @@ let block_error_encoding =
| Unexpected_number_of_validation_passes n -> Some ((), n)
| _ -> None)
(fun ((), n) -> Unexpected_number_of_validation_passes n) ;
case
case (Tag 9)
(obj4
(req "error" (constant "too_many_operations"))
(req "validation_pass" uint8)
@ -145,7 +145,7 @@ let block_error_encoding =
| _ -> None)
(fun ((), pass, found, max) ->
Too_many_operations { pass ; found ; max }) ;
case
case (Tag 10)
(obj4
(req "error" (constant "oversized_operation"))
(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
union
[
case
case (Tag 0)
(obj1
(req "error" (constant "compilation_failed")))
(function Compilation_failed -> Some ()
| _ -> None)
(fun () -> Compilation_failed) ;
case
case (Tag 1)
(obj1
(req "error" (constant "dynlinking_failed")))
(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
type case_tag = Tag of int | Json_only
type 't 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 :
?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 open Data_encoding in
union [
case ~tag:0 string
case (Tag 0) string
(function PStatic s -> Some s | _ -> None)
(fun s -> PStatic s) ;
case ~tag:1 arg_encoding
case (Tag 1) arg_encoding
(function PDynamic s -> Some s | _ -> None)
(fun s -> PDynamic s) ;
]
@ -47,19 +47,19 @@ let path_item_encoding =
let query_kind_encoding =
let open Data_encoding in
union [
case ~tag:0
case (Tag 0)
(obj1 (req "single" arg_encoding))
(function Single s -> Some s | _ -> None)
(fun s -> Single s) ;
case ~tag:1
case (Tag 1)
(obj1 (req "optional" arg_encoding))
(function Optional s -> Some s | _ -> None)
(fun s -> Optional s) ;
case ~tag:2
case (Tag 2)
(obj1 (req "flag" empty))
(function Flag -> Some () | _ -> None)
(fun () -> Flag) ;
case ~tag:3
case (Tag 3)
(obj1 (req "multi" arg_encoding))
(function Multi s -> Some s | _ -> None)
(fun s -> Multi s) ;
@ -96,7 +96,7 @@ let directory_descr_encoding =
mu "service_tree" @@ fun directory_descr_encoding ->
let static_subdirectories_descr_encoding =
union [
case ~tag:0 (obj1 (req "suffixes"
case (Tag 0) (obj1 (req "suffixes"
(list (obj2 (req "name" string)
(req "tree" directory_descr_encoding)))))
(function Suffixes map ->
@ -104,7 +104,7 @@ let directory_descr_encoding =
(fun m ->
let add acc (n,t) = StringMap.add n t acc in
Suffixes (List.fold_left add StringMap.empty m)) ;
case ~tag:1 (obj1 (req "dynamic_dispatch"
case (Tag 1) (obj1 (req "dynamic_dispatch"
(obj2
(req "arg" arg_encoding)
(req "tree" directory_descr_encoding))))
@ -140,10 +140,10 @@ let directory_descr_encoding =
(opt "patch_service" service_descr_encoding)
(opt "subdirs" static_subdirectories_descr_encoding)) in
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)
(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)
(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 open Data_encoding in
union
[ case ~tag: 0
[ case (Tag 0)
(obj1
(req "kind" (constant "empty_answer")))
(function Empty_answer -> Some () | _ -> None)
(fun () -> Empty_answer) ;
case ~tag: 1
case (Tag 1)
(obj2
(req "kind" (constant "connection_failed"))
(req "message" string))
(function Connection_failed msg -> Some ((), msg) | _ -> None)
(function (), msg -> Connection_failed msg) ;
case ~tag: 2
case (Tag 2)
(obj2
(req "kind" (constant "bad_request"))
(req "message" string))
(function Bad_request msg -> Some ((), msg) | _ -> None)
(function (), msg -> Bad_request msg) ;
case ~tag: 3
case (Tag 3)
(obj2
(req "kind" (constant "method_not_allowed"))
(req "allowed" (list RPC_service.meth_encoding)))
(function Method_not_allowed meths -> Some ((), meths) | _ -> None)
(function ((), meths) -> Method_not_allowed meths) ;
case ~tag: 4
case (Tag 4)
(obj2
(req "kind" (constant "unsupported_media_type"))
(opt "content_type" string))
(function Unsupported_media_type m -> Some ((), m) | _ -> None)
(function ((), m) -> Unsupported_media_type m) ;
case ~tag: 5
case (Tag 5)
(obj3
(req "kind" (constant "not_acceptable"))
(req "proposed" string)
@ -88,7 +88,7 @@ let rest_error_encoding =
| _ -> None)
(function ((), proposed, acceptable) ->
Not_acceptable { proposed ; acceptable }) ;
case ~tag: 6
case (Tag 6)
(obj4
(req "kind" (constant "unexpected_status_code"))
(req "code" uint16)
@ -101,7 +101,7 @@ let rest_error_encoding =
(function ((), code, content, media_type) ->
let code = Cohttp.Code.status_of_code code in
Unexpected_status_code { code ; content ; media_type }) ;
case ~tag: 7
case (Tag 7)
(obj3
(req "kind" (constant "unexpected_content_type"))
(req "received" string)
@ -112,7 +112,7 @@ let rest_error_encoding =
| _ -> None)
(function ((), received, acceptable) ->
Unexpected_content_type { received ; acceptable }) ;
case ~tag: 8
case (Tag 8)
(obj4
(req "kind" (constant "unexpected_content"))
(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 duplicate_tag () =
union [
case ~tag:1
case (Tag 1)
int8
(fun i -> i)
(fun i -> Some i) ;
case ~tag:1
case (Tag 1)
int8
(fun i -> i)
(fun i -> Some i)] in
@ -148,7 +148,7 @@ let test_tag_errors _ =
| _ -> false) ;
let invalid_tag () =
union [
case ~tag:(2 lsl 7)
case (Tag (2 lsl 7))
int8
(fun i -> i)
(fun i -> Some i)] in
@ -160,19 +160,19 @@ let test_tag_errors _ =
let test_union _ =
let enc =
(union [
case ~tag:1
case (Tag 1)
int8
(function A i -> Some i | _ -> None)
(fun i -> A i) ;
case ~tag:2
case (Tag 2)
string
(function B s -> Some s | _ -> None)
(fun s -> B s) ;
case ~tag:3
case (Tag 3)
int8
(function C i -> Some i | _ -> None)
(fun i -> C i) ;
case ~tag:4
case (Tag 4)
(obj2
(req "kind" (constant "D"))
(req "data" (string)))
@ -182,7 +182,7 @@ let test_union _ =
let jsonA = Json.construct enc (A 1) in
let jsonB = Json.construct enc (B "2") 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
~msg:__LOC__ (fun () -> Json.construct enc E) is_invalid_arg ;
Assert.equal ~prn:prn_t ~msg:__LOC__ (A 1) (Json.destruct enc jsonA) ;
@ -225,11 +225,11 @@ let test_splitted _ =
~binary:string
~json:
(union [
case ~tag:1
case (Tag 1)
string
(fun _ -> None)
(fun s -> s) ;
case ~tag:2
case (Tag 2)
s_enc
(fun s -> Some { field = int_of_string s })
(fun s -> string_of_int s.field) ;
@ -315,6 +315,23 @@ let wrap_test f base_dir =
f base_dir >>= fun 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 = [
"simple", test_simple_values ;
"json", test_json ;
@ -322,6 +339,7 @@ let tests = [
"splitted", test_splitted ;
"json.input", test_json_input ;
"tags", test_tag_errors ;
"wrapped_binary", test_wrapped_binary ;
]
let () =

12
test/utils/test_stream_data_encoding.ml
View File

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