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

Data_encoding: mandatory title to case

Browse Source
This commit is contained in:
Grégoire Henry 2018-05-31 23:19:43 +02:00 committed by Benjamin Canou
parent b7ca0a1e1e
commit 030630ec0f
50 changed files with 373 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
src/lib_base/p2p_connection.ml
View File

@ -145,47 +145,47 @@ module Pool_event = struct
(obj1 (req "event" (constant name))) obj) in
union ~tag_size:`Uint8 [
case (Tag 0)
~name:"too_few_connections"
~title:"Too_few_connections"
(branch_encoding "too_few_connections" empty)
(function Too_few_connections -> Some () | _ -> None)
(fun () -> Too_few_connections) ;
case (Tag 1)
~name:"too_many_connections"
~title:"Too_many_connections"
(branch_encoding "too_many_connections" empty)
(function Too_many_connections -> Some () | _ -> None)
(fun () -> Too_many_connections) ;
case (Tag 2)
~name:"new_point"
~title:"New_point"
(branch_encoding "new_point"
(obj1 (req "point" P2p_point.Id.encoding)))
(function New_point p -> Some p | _ -> None)
(fun p -> New_point p) ;
case (Tag 3)
~name:"new_peer"
~title:"New_peer"
(branch_encoding "new_peer"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function New_peer p -> Some p | _ -> None)
(fun p -> New_peer p) ;
case (Tag 4)
~name:"incoming_connection"
~title:"Incoming_connection"
(branch_encoding "incoming_connection"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Incoming_connection p -> Some p | _ -> None)
(fun p -> Incoming_connection p) ;
case (Tag 5)
~name:"outgoing_connection"
~title:"Outgoing_connection"
(branch_encoding "outgoing_connection"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Outgoing_connection p -> Some p | _ -> None)
(fun p -> Outgoing_connection p) ;
case (Tag 6)
~name:"authentication_failed"
~title:"Authentication_failed"
(branch_encoding "authentication_failed"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Authentication_failed p -> Some p | _ -> None)
(fun p -> Authentication_failed p) ;
case (Tag 7)
~name:"accepting_request"
~title:"Accepting_request"
(branch_encoding "accepting_request"
(obj3
(req "point" P2p_point.Id.encoding)
@ -195,7 +195,7 @@ module Pool_event = struct
Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ;
case (Tag 8)
~name:"rejecting_request"
~title:"Rejecting_request"
(branch_encoding "rejecting_request"
(obj3
(req "point" P2p_point.Id.encoding)
@ -205,7 +205,7 @@ module Pool_event = struct
Some (p, id_p, g) | _ -> None)
(fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ;
case (Tag 9)
~name:"request_rejected"
~title:"Request_rejected"
(branch_encoding "request_rejected"
(obj2
(req "point" P2p_point.Id.encoding)
@ -214,7 +214,7 @@ module Pool_event = struct
(function Request_rejected (p, id) -> Some (p, id) | _ -> None)
(fun (p, id) -> Request_rejected (p, id)) ;
case (Tag 10)
~name:"connection_established"
~title:"Connection_established"
(branch_encoding "connection_established"
(obj2
(req "id_point" Id.encoding)
@ -223,29 +223,29 @@ module Pool_event = struct
Some (id_p, g) | _ -> None)
(fun (id_p, g) -> Connection_established (id_p, g)) ;
case (Tag 11)
~name:"disconnection"
~title:"Disconnection"
(branch_encoding "disconnection"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function Disconnection g -> Some g | _ -> None)
(fun g -> Disconnection g) ;
case (Tag 12)
~name:"external_disconnection"
~title:"External_disconnection"
(branch_encoding "external_disconnection"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function External_disconnection g -> Some g | _ -> None)
(fun g -> External_disconnection g) ;
case (Tag 13)
~name:"gc_points"
~title:"Gc_points"
(branch_encoding "gc_points" empty)
(function Gc_points -> Some () | _ -> None)
(fun () -> Gc_points) ;
case (Tag 14)
~name:"gc_peer_ids"
~title:"Gc_peer_ids"
(branch_encoding "gc_peer_ids" empty)
(function Gc_peer_ids -> Some () | _ -> None)
(fun () -> Gc_peer_ids) ;
case (Tag 15)
~name:"swap_request_received"
~title:"Swap_request_received"
(branch_encoding "swap_request_received"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
@ -253,7 +253,7 @@ module Pool_event = struct
| _ -> None)
(fun source -> Swap_request_received { source }) ;
case (Tag 16)
~name:"swap_ack_received"
~title:"Swap_ack_received"
(branch_encoding "swap_ack_received"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
@ -261,7 +261,7 @@ module Pool_event = struct
| _ -> None)
(fun source -> Swap_ack_received { source }) ;
case (Tag 17)
~name:"swap_request_sent"
~title:"Swap_request_sent"
(branch_encoding "swap_request_sent"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
@ -269,7 +269,7 @@ module Pool_event = struct
| _ -> None)
(fun source -> Swap_request_sent { source }) ;
case (Tag 18)
~name:"swap_ack_sent"
~title:"Swap_ack_sent"
(branch_encoding "swap_ack_sent"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
@ -277,7 +277,7 @@ module Pool_event = struct
| _ -> None)
(fun source -> Swap_ack_sent { source }) ;
case (Tag 19)
~name:"swap_request_ignored"
~title:"Swap_request_ignored"
(branch_encoding "swap_request_ignored"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
@ -285,7 +285,7 @@ module Pool_event = struct
| _ -> None)
(fun source -> Swap_request_ignored { source }) ;
case (Tag 20)
~name:"swap_success"
~title:"Swap_success"
(branch_encoding "swap_success"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
@ -293,7 +293,7 @@ module Pool_event = struct
| _ -> None)
(fun source -> Swap_success { source }) ;
case (Tag 21)
~name:"swap_failure"
~title:"Swap_failure"
(branch_encoding "swap_failure"
(obj1 (req "source" P2p_peer_id.encoding)))
(function

36
src/lib_base/p2p_point.ml
View File

@ -169,24 +169,24 @@ module State = struct
(obj1 (req "event_kind" (constant name))) obj) in
union ~tag_size:`Uint8 [
case (Tag 0)
~name:"requested"
~title:"Requested"
(branch_encoding "requested" empty)
(function Requested -> Some () | _ -> None)
(fun () -> Requested) ;
case (Tag 1)
~name:"accepted"
~title:"Accepted"
(branch_encoding "accepted"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Accepted p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Accepted p2p_peer_id) ;
case (Tag 2)
~name:"running"
~title:"Running"
(branch_encoding "running"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Running p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Running p2p_peer_id) ;
case (Tag 3)
~name:"disconnected"
~title:"Disconnected"
(branch_encoding "disconnected" empty)
(function Disconnected -> Some () | _ -> None)
(fun () -> Disconnected) ;
@ -277,30 +277,44 @@ module Pool_event = 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)
~title:"Outgoing_request"
(branch_encoding "outgoing_request" empty)
(function Outgoing_request -> Some () | _ -> None)
(fun () -> Outgoing_request) ;
case (Tag 1) (branch_encoding "accepting_request"
case (Tag 1)
~title:"Accepting_request"
(branch_encoding "accepting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Accepting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Accepting_request p2p_peer_id) ;
case (Tag 2) (branch_encoding "rejecting_request"
case (Tag 2)
~title:"Rejecting_request"
(branch_encoding "rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Rejecting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Rejecting_request p2p_peer_id) ;
case (Tag 3) (branch_encoding "request_rejected"
case (Tag 3)
~title:"Rejecting_rejected"
(branch_encoding "request_rejected"
(obj1 (opt "p2p_peer_id" P2p_peer_id.encoding)))
(function Request_rejected p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Request_rejected p2p_peer_id) ;
case (Tag 4) (branch_encoding "rejecting_request"
case (Tag 4)
~title:"Connection_established"
(branch_encoding "rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Connection_established p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Connection_established p2p_peer_id) ;
case (Tag 5) (branch_encoding "rejecting_request"
case (Tag 5)
~title:"Disconnection"
(branch_encoding "rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Disconnection p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Disconnection p2p_peer_id) ;
case (Tag 6) (branch_encoding "rejecting_request"
case (Tag 6)
~title:"External_disconnection"
(branch_encoding "rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function External_disconnection p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> External_disconnection p2p_peer_id) ;

6
src/lib_base/test_chain_status.ml
View File

@ -24,11 +24,11 @@ let encoding =
let open Data_encoding in
def "test_chain_status" @@
union [
case (Tag 0) ~name:"Not_running"
case (Tag 0) ~title:"Not_running"
(obj1 (req "status" (constant "not_running")))
(function Not_running -> Some () | _ -> None)
(fun () -> Not_running) ;
case (Tag 1) ~name:"Forking"
case (Tag 1) ~title:"Forking"
(obj3
(req "status" (constant "forking"))
(req "protocol" Protocol_hash.encoding)
@ -39,7 +39,7 @@ let encoding =
| _ -> None)
(fun ((), protocol, expiration) ->
Forking { protocol ; expiration }) ;
case (Tag 2) ~name:"Running"
case (Tag 2) ~title:"Running"
(obj5
(req "status" (constant "running"))
(req "chain_id" Chain_id.encoding)

2
src/lib_base/time.ml
View File

@ -98,10 +98,12 @@ module T = struct
~json:
(union [
case Json_only
~title:"RFC encoding"
rfc_encoding
(fun i -> Some i)
(fun i -> i) ;
case Json_only
~title:"Second since epoch"
int64
(fun _ -> None)
(fun i -> i) ;

3
src/lib_crypto/blake2B.ml
View File

@ -311,18 +311,21 @@ module Make_merkle_tree
(fun path_encoding ->
union [
case (Tag 240)
~title:"Left"
(obj2
(req "path" path_encoding)
(req "right" encoding))
(function Left (p, r) -> Some (p, r) | _ -> None)
(fun (p, r) -> Left (p, r)) ;
case (Tag 15)
~title:"Right"
(obj2
(req "left" encoding)
(req "path" path_encoding))
(function Right (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Right (r, p)) ;
case (Tag 0)
~title:"Op"
unit
(function Op -> Some () | _ -> None)
(fun () -> Op)

12
src/lib_crypto/signature.ml
View File

@ -50,11 +50,11 @@ module Public_key_hash = struct
def "public_key_hash" ~description:title @@
union [
case (Tag 0) Ed25519.Public_key_hash.encoding
~name:"Ed25519"
~title:"Ed25519"
(function Ed25519 x -> Some x | _ -> None)
(function x -> Ed25519 x);
case (Tag 1) Secp256k1.Public_key_hash.encoding
~name:"Secp256k1"
~title:"Secp256k1"
(function Secp256k1 x -> Some x | _ -> None)
(function x -> Secp256k1 x)
]
@ -242,11 +242,11 @@ module Public_key = struct
def "public_key" ~description:title @@
union [
case (Tag 0) Ed25519.Public_key.encoding
~name:"Ed25519"
~title:"Ed25519"
(function Ed25519 x -> Some x | _ -> None)
(function x -> Ed25519 x);
case (Tag 1) Secp256k1.Public_key.encoding
~name:"Secp256k1"
~title:"Secp256k1"
(function Secp256k1 x -> Some x | _ -> None)
(function x -> Secp256k1 x)
]
@ -327,11 +327,11 @@ module Secret_key = struct
def "secret_key" ~description:title @@
union [
case (Tag 0) Ed25519.Secret_key.encoding
~name:"Ed25519"
~title:"Ed25519"
(function Ed25519 x -> Some x | _ -> None)
(function x -> Ed25519 x);
case (Tag 1) Secp256k1.Secret_key.encoding
~name:"Secp256k1"
~title:"Secp256k1"
(function Secp256k1 x -> Some x | _ -> None)
(function x -> Secp256k1 x)
]

7
src/lib_data_encoding/binary_description.ml
View File

@ -192,7 +192,7 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
List.fold_right
(fun (tag, Case case) (cases, references) ->
let fields, references = fields None recursives references case.encoding.encoding in
((tag, case.name, tag_field :: fields) :: cases, references))
((tag, Some case.title, tag_field :: fields) :: cases, references))
cases
([], references) in
let name = new_reference () in
@ -235,7 +235,8 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
| Objs { left ; right } ->
let (left_fields, references) =
fields None recursives references left.encoding in
let (right_fields, references) = fields None recursives references right.encoding in
let (right_fields, references) =
fields None recursives references right.encoding in
(left_fields @ right_fields, references)
| Null -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references)
| Empty -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references)
@ -290,7 +291,7 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
| Union { kind ; tag_size ; cases } ->
let name, references = union recursives references kind tag_size cases in
([ Anonymous_field (kind, Ref name) ], references)
| (Mu { kind ; name ; description ; fix } as encoding) ->
| (Mu { kind ; name ; title = _ ; description ; fix } as encoding) ->
let kind = (kind :> Kind.t) in
if List.mem name recursives
then ([ Anonymous_field (kind, Ref name) ], references)

42
src/lib_data_encoding/binary_schema.ml
View File

@ -292,7 +292,7 @@ module Encoding = struct
(fun layout ->
union [
case
~name:"Zero_width"
~title:"Zero_width"
(Tag 0)
(obj1
(req "kind" (constant "Zero_width")))
@ -300,7 +300,7 @@ module Encoding = struct
| Zero_width -> Some ()
| _ -> None)
(fun () -> Zero_width) ;
case ~name:"Int"
case ~title:"Int"
(Tag 1)
(obj2
(req "size" integer_extended_encoding)
@ -309,14 +309,14 @@ module Encoding = struct
| Int integer -> Some (integer, ())
| _ -> None)
(fun (integer, _)-> Int integer) ;
case ~name:"Bool"
case ~title:"Bool"
(Tag 2)
(obj1 (req "kind" (constant "Bool")))
(function
| Bool -> Some ()
| _ -> None)
(fun () -> Bool) ;
case ~name:"RangedInt"
case ~title:"RangedInt"
(Tag 3)
(obj3
(req "min" int31)
@ -326,7 +326,7 @@ module Encoding = struct
| RangedInt (min, max) -> Some (min, max, ())
| _ -> None)
(fun (min, max, _) -> RangedInt (min, max)) ;
case ~name:"RangedFloat"
case ~title:"RangedFloat"
(Tag 4)
(obj3
(req "min" float)
@ -336,28 +336,28 @@ module Encoding = struct
| RangedFloat (min, max) -> Some (min, max, ())
| _ -> None)
(fun (min, max, ()) -> RangedFloat (min, max)) ;
case ~name:"Float"
case ~title:"Float"
(Tag 5)
(obj1 (req "kind" (constant "Float")))
(function
| Float -> Some ()
| _ -> None)
(fun () -> Float) ;
case ~name:"Bytes"
case ~title:"Bytes"
(Tag 6)
(obj1 (req "kind" (constant "Bytes")))
(function
| Bytes -> Some ()
| _ -> None)
(fun () -> Bytes) ;
case ~name:"String"
case ~title:"String"
(Tag 7)
(obj1 (req "kind" (constant "String")))
(function
| String -> Some ()
| _ -> None)
(fun () -> String) ;
case ~name:"Enum"
case ~title:"Enum"
(Tag 8)
(obj3
(req "size" integer_encoding)
@ -367,7 +367,7 @@ module Encoding = struct
| Enum (size, cases) -> Some (size, cases, ())
| _ -> None)
(fun (size, cases, _) -> Enum (size, cases)) ;
case ~name:"Seq"
case ~title:"Seq"
(Tag 9)
(obj2
(req "layout" layout)
@ -376,7 +376,7 @@ module Encoding = struct
| Seq layout -> Some (layout, ())
| _ -> None)
(fun (layout, ()) -> Seq layout) ;
case ~name:"Ref"
case ~title:"Ref"
(Tag 10)
(obj2
(req "name" string)
@ -389,13 +389,13 @@ module Encoding = struct
let kind_enum_cases =
(fun () ->
[ case ~name:"Dynamic"
[ case ~title:"Dynamic"
(Tag 0)
(obj1 (req "kind" (constant "Dynamic")))
(function `Dynamic -> Some ()
| _ -> None)
(fun () -> `Dynamic) ;
case ~name:"Variable"
case ~title:"Variable"
(Tag 1)
(obj1 (req "kind" (constant "Variable")))
(function `Variable -> Some ()
@ -408,7 +408,7 @@ module Encoding = struct
let kind_t_encoding =
def "schema.kind" @@
union
((case ~name:"Fixed"
((case ~title:"Fixed"
(Tag 2)
(obj2
(req "size" int31)
@ -427,7 +427,7 @@ module Encoding = struct
let dynamic_layout_encoding = dynamic_size layout_encoding in
def "schema.field" @@
union [
case ~name:"Named_field"
case ~title:"Named_field"
(Tag 0)
(obj4
(req "name" string)
@ -437,7 +437,7 @@ module Encoding = struct
(function Named_field (name, kind, layout) -> Some (name, layout, kind, ())
| _ -> None)
(fun (name, kind, layout, _) -> Named_field (name, layout, kind)) ;
case ~name:"Anonymous_field"
case ~title:"Anonymous_field"
(Tag 1)
(obj3
(req "layout" dynamic_layout_encoding)
@ -446,7 +446,7 @@ module Encoding = struct
(function Anonymous_field (kind, layout) -> Some (layout, (), kind)
| _ -> None)
(fun (kind, _, layout) -> Anonymous_field (layout, kind)) ;
case ~name:"Dynamic_field"
case ~title:"Dynamic_field"
(Tag 2)
(obj4
(req "kind" (constant "dyn"))
@ -456,7 +456,7 @@ module Encoding = struct
(function Dynamic_size_field (name, i, size) -> Some ((), name, i, size)
| _ -> None)
(fun ((), name, i, size) -> Dynamic_size_field (name, i, size)) ;
case ~name:"Optional_field"
case ~title:"Optional_field"
(Tag 3)
(obj2
(req "kind" (constant "option_indicator"))
@ -473,7 +473,7 @@ module Encoding = struct
let binary_description_encoding =
union [
case ~name:"Obj"
case ~title:"Obj"
(Tag 0)
(obj1
(req "fields" (list (dynamic_size field_descr_encoding))))
@ -481,7 +481,7 @@ module Encoding = struct
| Obj { fields } -> Some (fields)
| _ -> None)
(fun (fields) -> Obj { fields }) ;
case ~name:"Cases"
case ~title:"Cases"
(Tag 1)
(obj3
(req "tag_size" tag_size_encoding)
@ -502,7 +502,7 @@ module Encoding = struct
| _ -> None)
(fun (tag_size, kind, cases) ->
Cases { kind ; tag_size ; cases }) ;
case ~name:"Int_enum"
case ~title:"Int_enum"
(Tag 2)
(obj2
(req "size" integer_encoding)

3
src/lib_data_encoding/data_encoding.mli
View File

@ -358,7 +358,8 @@ module Encoding: sig
An optional name for the case can be provided,
which is used in the binary documentation. *)
val case :
?name:string ->
title:string ->
?description:string ->
case_tag ->
'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case

18
src/lib_data_encoding/encoding.ml
View File

@ -147,7 +147,8 @@ and _ field =
} -> 'a field
and 'a case =
| Case : { name : string option ;
| Case : { title : string ;
description : string option ;
encoding : 'a t ;
proj : ('t -> 'a option) ;
inj : ('a -> 't) ;
@ -559,7 +560,8 @@ let union ?(tag_size = `Uint8) cases =
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 ?name tag encoding proj inj = Case { name ; encoding ; proj ; inj ; tag }
let case ~title ?description tag encoding proj inj =
Case { title ; description ; encoding ; proj ; inj ; tag }
let rec is_nullable: type t. t encoding -> bool = fun e ->
match e.encoding with
@ -605,12 +607,14 @@ let option ty =
(* TODO add a special construct `Option` in the GADT *)
union
~tag_size:`Uint8
[ case (Tag 1) ty
~name:"Some"
[ case
(Tag 1) ty
~title:"Some"
(fun x -> x)
(fun x -> Some x) ;
case (Tag 0) null
~name:"None"
case
(Tag 0) null
~title:"None"
(function None -> Some () | Some _ -> None)
(fun () -> None) ;
]
@ -633,9 +637,11 @@ let result ok_enc error_enc =
union
~tag_size:`Uint8
[ case (Tag 1) ok_enc
~title:"Ok"
(function Ok x -> Some x | Error _ -> None)
(fun x -> Ok x) ;
case (Tag 0) error_enc
~title:"Result"
(function Ok _ -> None | Error x -> Some x)
(fun x -> Error x) ;
]

6
src/lib_data_encoding/encoding.mli
View File

@ -105,7 +105,8 @@ and _ field =
} -> 'a field
and 'a case =
| Case : { name : string option ;
| Case : { title : string ;
description : string option ;
encoding : 'a t ;
proj : ('t -> 'a option) ;
inj : ('a -> 't) ;
@ -249,7 +250,8 @@ val array : 'a encoding -> 'a array encoding
val list : 'a encoding -> 'a list encoding
val case :
?name:string ->
title:string ->
?description: string ->
case_tag ->
'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
val union :

39
src/lib_data_encoding/json.ml
View File

@ -92,16 +92,17 @@ let rec lift_union : type a. a Encoding.t -> a Encoding.t = fun e ->
| Conv { proj ; inj ; encoding = e ; schema } -> begin
match lift_union e with
| { encoding = Union { kind ; tag_size ; cases } } ->
let cases =
List.map
(fun (Case { name ; encoding ; proj = proj' ; inj = inj' ; tag }) ->
make @@
Union { kind ; tag_size ;
cases = List.map
(fun (Case { title ; description ; encoding ; proj = proj' ; inj = inj' ; tag }) ->
Case { encoding ;
name ;
proj = (fun x -> proj' (proj x)) ;
title ;
description ;
proj = (fun x -> proj' (proj x));
inj = (fun x -> inj (inj' x)) ;
tag })
cases in
make @@ Union { kind ; tag_size ; cases }
cases }
| e -> make @@ Conv { proj ; inj ; encoding = e ; schema }
end
| Objs { kind ; left ; right } ->
@ -120,33 +121,37 @@ and lift_union_in_pair
let open Encoding in
match lift_union e1, lift_union e2 with
| e1, { encoding = Union { tag_size ; cases } } ->
let cases =
make @@
Union { kind = `Dynamic (* ignored *) ; tag_size ;
cases =
List.map
(fun (Case { name ; encoding = e2 ; proj ; inj ; tag }) ->
(fun (Case { title ; description ; encoding = e2 ; proj ; inj ; tag }) ->
Case { encoding = lift_union_in_pair b p e1 e2 ;
name ;
title ;
description ;
proj = (fun (x, y) ->
match proj y with
| None -> None
| Some y -> Some (x, y)) ;
inj = (fun (x, y) -> (x, inj y)) ;
tag })
cases in
make @@ Union { kind = `Dynamic (* ignored *) ; tag_size ; cases }
cases }
| { encoding = Union { tag_size ; cases } }, e2 ->
let cases =
make @@
Union { kind = `Dynamic (* ignored *) ; tag_size ;
cases =
List.map
(fun (Case { name ; encoding = e1 ; proj ; inj ; tag }) ->
(fun (Case { title ; description ; encoding = e1 ; proj ; inj ; tag }) ->
Case { encoding = lift_union_in_pair b p e1 e2 ;
name ;
title ;
description ;
proj = (fun (x, y) ->
match proj x with
| None -> None
| Some x -> Some (x, y)) ;
inj = (fun (x, y) -> (inj x, y)) ;
tag })
cases in
make @@ Union { kind = `Dynamic (* ignored *) ; tag_size ; cases }
cases }
| e1, e2 -> b.build p e1 e2
let rec json : type a. a Encoding.desc -> a Json_encoding.encoding =

8
src/lib_data_encoding/test/bench_data_encoding.ml
View File

@ -59,27 +59,33 @@ let cases_encoding : t Data_encoding.t =
mu "recursive"
(fun recursive -> union [
case (Tag 0)
~title:"A"
string
(function A s -> Some s
| _ -> None)
(fun s -> A s) ;
case (Tag 1)
~title:"B"
bool
(function B bool -> Some bool
| _ -> None)
(fun bool -> B bool) ;
case (Tag 2)
~title:"I"
int31
(function I int -> Some int
| _ -> None)
(fun int -> I int) ;
case (Tag 3)
~title:"F"
float
(function F float -> Some float
| _ -> None)
(fun float -> F float) ;
case (Tag 4)
(obj2 (req "field1" recursive)
~title:"R"
(obj2
(req "field1" recursive)
(req "field2" recursive))
(function R (a, b) -> Some (a, b)
| _ -> None)

4
src/lib_data_encoding/test/invalid_encoding.ml
View File

@ -20,8 +20,8 @@ let tests = [
test "merge_non_objs" (fun () -> merge_objs int8 string) ;
test "empty_union" (fun () -> union []) ;
test "duplicated_tag" (fun () ->
union [ case (Tag 0) empty (fun () -> None) (fun () -> ()) ;
case (Tag 0) empty (fun () -> None) (fun () -> ()) ]) ;
union [ case (Tag 0) ~title:"" empty (fun () -> None) (fun () -> ()) ;
case (Tag 0) ~title:"" empty (fun () -> None) (fun () -> ()) ]) ;
test "fixed_negative_size" (fun () -> Fixed.string (~- 1)) ;
test "fixed_null_size" (fun () -> Fixed.bytes 0) ;
test "array_null_size" (fun () -> Variable.list empty) ;

8
src/lib_data_encoding/test/types.ml
View File

@ -101,24 +101,29 @@ type union = A of int | B of string | C of int | D of string | E
let union_enc =
union [
case (Tag 1)
~title:"A"
int8
(function A i -> Some i | _ -> None)
(fun i -> A i) ;
case (Tag 2)
~title:"B"
string
(function B s -> Some s | _ -> None)
(fun s -> B s) ;
case (Tag 3)
~title:"C"
(obj1 (req "C" int8))
(function C i -> Some i | _ -> None)
(fun i -> C i) ;
case (Tag 4)
~title:"D"
(obj2
(req "kind" (constant "D"))
(req "data" (string)))
(function D s -> Some ((), s) | _ -> None)
(fun ((), s) -> D s) ;
case (Tag 5)
~title:"E"
empty
(function E -> Some () | _ -> None)
(fun () -> E) ;
@ -127,6 +132,7 @@ let union_enc =
let mini_union_enc =
union [
case (Tag 1)
~title:"A"
int8
(function A i -> Some i | _ -> None)
(fun i -> A i) ;
@ -151,10 +157,12 @@ let mu_list_enc enc =
mu "list" @@ fun mu_list_enc ->
union [
case (Tag 0)
~title:"Nil"
empty
(function [] -> Some () | _ :: _ -> None)
(fun () -> []) ;
case (Tag 1)
~title:"Cons"
(obj2
(req "value" enc)
(req "next" mu_list_enc))

31
src/lib_error_monad/error_monad.ml
View File

@ -118,6 +118,7 @@ module Make(Prefix : sig val id : string end) = struct
let encoding_case =
let open Data_encoding in
case Json_only
~title:"Generic error"
(def "generic_error" ~title ~description @@
conv (fun x -> ((), x)) (fun ((), x) -> x) @@
(obj2
@ -141,7 +142,9 @@ module Make(Prefix : sig val id : string end) = struct
| _ -> None in
let encoding_case =
let open Data_encoding in
case Json_only json from_error to_error in
case Json_only
~title:"Unregistred error"
json from_error to_error in
let pp ppf json =
Format.fprintf ppf "@[<v 2>Unregistred error:@ %a@]"
Data_encoding.Json.pp json in
@ -177,7 +180,9 @@ module Make(Prefix : sig val id : string end) = struct
| WEM.Unregistred_error _ ->
failwith "ignore wrapped error when deserializing"
| res -> WEM.wrap res in
case Json_only WEM.error_encoding unwrap wrap
case Json_only
~title:name
WEM.error_encoding unwrap wrap
| Main category ->
let with_id_and_kind_encoding =
merge_objs
@ -186,9 +191,12 @@ module Make(Prefix : sig val id : string end) = struct
(req "id" (constant name)))
encoding in
case Json_only
(def name ~title ~description
(conv (fun x -> (((), ()), x)) (fun (((),()), x) -> x)
with_id_and_kind_encoding))
~title
~description
(conv
(fun x -> (((), ()), x))
(fun (((),()), x) -> x)
with_id_and_kind_encoding)
from_error to_error in
!set_error_encoding_cache_dirty () ;
error_kinds :=
@ -299,11 +307,11 @@ module Make(Prefix : sig val id : string end) = struct
union
~tag_size:`Uint8
[ case (Tag 0) t_encoding
~name:"A successful result"
~title:"Ok"
(function Ok x -> Some x | _ -> None)
(function res -> Ok res) ;
case (Tag 1) errors_encoding
~name:"A erroneous result"
~title:"Error"
(function Error x -> Some x | _ -> None)
(fun errs -> Error errs) ]
@ -551,13 +559,12 @@ module Make(Prefix : sig val id : string end) = struct
let description = "An fatal assertion" in
let encoding_case =
let open Data_encoding in
case Json_only
(def "assertion" ~title ~description @@
conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y)) @@
(obj3
case Json_only ~title ~description
(conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y))
((obj3
(req "kind" (constant "assertion"))
(req "location" string)
(req "error" string)))
(req "error" string))))
from_error to_error in
let pp ppf (loc, msg) =
Format.fprintf ppf

20
src/lib_micheline/micheline.ml
View File

@ -120,23 +120,23 @@ let canonical_encoding ~variant prim_encoding =
obj1 (req "string" string) in
let int_encoding tag =
case tag int_encoding
~name:"Int"
~title:"Int"
(function Int (_, v) -> Some v | _ -> None)
(fun v -> Int (0, v)) in
let string_encoding tag =
case tag string_encoding
~name:"String"
~title:"String"
(function String (_, v) -> Some v | _ -> None)
(fun v -> String (0, v)) in
let seq_encoding tag expr_encoding =
case tag (list expr_encoding)
~name:"Sequence"
~title:"Sequence"
(function Seq (_, v, _annot) -> Some v | _ -> None)
(fun args -> Seq (0, args, None)) in
let byte_string = Bounded.string 255 in
let application_encoding tag expr_encoding =
case tag
~name:"Generic prim (any number of args with or without annot)"
~title:"Generic prim (any number of args with or without annot)"
(obj3 (req "prim" prim_encoding)
(req "args" (list expr_encoding))
(opt "annot" byte_string))
@ -156,14 +156,14 @@ let canonical_encoding ~variant prim_encoding =
seq_encoding (Tag 2) expr_encoding ;
(* No args, no annot *)
case (Tag 3)
~name:"Prim (no args, annot)"
~title:"Prim (no args, annot)"
(obj1 (req "prim" prim_encoding))
(function Prim (_, v, [], None) -> Some v
| _ -> None)
(fun v -> Prim (0, v, [], None)) ;
(* No args, with annot *)
case (Tag 4)
~name:"Prim (no args + annot)"
~title:"Prim (no args + annot)"
(obj2 (req "prim" prim_encoding)
(req "annot" byte_string))
(function
@ -172,7 +172,7 @@ let canonical_encoding ~variant prim_encoding =
(function (prim, annot) -> Prim (0, prim, [], Some annot)) ;
(* Single arg, no annot *)
case (Tag 5)
~name:"Prim (1 arg, no annot)"
~title:"Prim (1 arg, no annot)"
(obj2 (req "prim" prim_encoding)
(req "arg" expr_encoding))
(function
@ -181,7 +181,7 @@ let canonical_encoding ~variant prim_encoding =
(function (prim, arg) -> Prim (0, prim, [ arg ], None)) ;
(* Single arg, with annot *)
case (Tag 6)
~name:"Prim (1 arg + annot)"
~title:"Prim (1 arg + annot)"
(obj3 (req "prim" prim_encoding)
(req "arg" expr_encoding)
(req "annot" byte_string))
@ -191,7 +191,7 @@ let canonical_encoding ~variant prim_encoding =
(fun (prim, arg, annot) -> Prim (0, prim, [ arg ], Some annot)) ;
(* Two args, no annot *)
case (Tag 7)
~name:"Prim (2 args, no annot)"
~title:"Prim (2 args, no annot)"
(obj3 (req "prim" prim_encoding)
(req "arg1" expr_encoding)
(req "arg2" expr_encoding))
@ -201,7 +201,7 @@ let canonical_encoding ~variant prim_encoding =
(fun (prim, arg1, arg2) -> Prim (0, prim, [ arg1 ; arg2 ], None)) ;
(* Two args, with annot *)
case (Tag 8)
~name:"Prim (2 args + annot)"
~title:"Prim (2 args + annot)"
(obj4 (req "prim" prim_encoding)
(req "arg1" expr_encoding)
(req "arg2" expr_encoding)

17
src/lib_micheline/micheline_parser.ml
View File

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

1
src/lib_p2p/p2p.ml
View File

@ -24,6 +24,7 @@ type 'conn_meta conn_meta_config = 'conn_meta P2p_socket.metadata_config = {
type 'msg app_message_encoding = 'msg P2p_pool.encoding =
Encoding : {
tag: int ;
title: string ;
encoding: 'a Data_encoding.t ;
wrap: 'a -> 'msg ;
unwrap: 'msg -> 'a option ;

1
src/lib_p2p/p2p.mli
View File

@ -29,6 +29,7 @@ type 'conn_meta conn_meta_config = {
type 'msg app_message_encoding = Encoding : {
tag: int ;
title: string ;
encoding: 'a Data_encoding.t ;
wrap: 'a -> 'msg ;
unwrap: 'msg -> 'a option ;

17
src/lib_p2p/p2p_pool.ml
View File

@ -19,6 +19,7 @@ include Logging.Make (struct let name = "p2p.connection-pool" end)
type 'msg encoding = Encoding : {
tag: int ;
title: string ;
encoding: 'a Data_encoding.t ;
wrap: 'a -> 'msg ;
unwrap: 'msg -> 'a option ;
@ -39,21 +40,21 @@ module Message = struct
let open Data_encoding in
dynamic_size @@
union ~tag_size:`Uint16
([ case (Tag 0x01) ~name:"Disconnect"
([ case (Tag 0x01) ~title:"Disconnect"
(obj1 (req "kind" (constant "Disconnect")))
(function Disconnect -> Some () | _ -> None)
(fun () -> Disconnect);
case (Tag 0x02) ~name:"Bootstrap"
case (Tag 0x02) ~title:"Bootstrap"
(obj1 (req "kind" (constant "Bootstrap")))
(function Bootstrap -> Some () | _ -> None)
(fun () -> Bootstrap);
case (Tag 0x03) ~name:"Advertise"
case (Tag 0x03) ~title:"Advertise"
(obj2
(req "id" (Variable.list P2p_point.Id.encoding))
(req "kind" (constant "Advertise")))
(function Advertise points -> Some (points, ()) | _ -> None)
(fun (points, ()) -> Advertise points);
case (Tag 0x04) ~name:"Swap_request"
case (Tag 0x04) ~title:"Swap_request"
(obj3
(req "point" P2p_point.Id.encoding)
(req "peer_id" P2p_peer.Id.encoding)
@ -63,7 +64,7 @@ module Message = struct
| _ -> None)
(fun (point, peer_id, ()) -> Swap_request (point, peer_id)) ;
case (Tag 0x05)
~name:"Swap_ack"
~title:"Swap_ack"
(obj3
(req "point" P2p_point.Id.encoding)
(req "peer_id" P2p_peer.Id.encoding)
@ -74,8 +75,10 @@ module Message = struct
(fun (point, peer_id, ()) -> Swap_ack (point, peer_id)) ;
] @
ListLabels.map msg_encoding
~f:(function Encoding { tag ; encoding ; wrap ; unwrap } ->
Data_encoding.case (Tag tag) encoding
~f:(function Encoding { tag ; title ; encoding ; wrap ; unwrap } ->
Data_encoding.case (Tag tag)
~title
encoding
(function Message msg -> unwrap msg | _ -> None)
(fun msg -> Message (wrap msg))))

1
src/lib_p2p/p2p_pool.mli
View File

@ -25,6 +25,7 @@
type 'msg encoding = Encoding : {
tag: int ;
title: string ;
encoding: 'a Data_encoding.t ;
wrap: 'a -> 'msg ;
unwrap: 'msg -> 'a option ;

2
src/lib_p2p/p2p_socket.ml
View File

@ -192,12 +192,14 @@ module Ack = struct
let nack_encoding = obj1 (req "nack" empty) in
let ack_case tag =
case tag ack_encoding
~title:"Ack"
(function
| Ack -> Some ()
| _ -> None)
(fun () -> Ack) in
let nack_case tag =
case tag nack_encoding
~title:"Nack"
(function
| Nack -> Some ()
| _ -> None

1
src/lib_p2p/test/test_p2p_pool.ml
View File

@ -16,6 +16,7 @@ let msg_config : message P2p_pool.message_config = {
encoding = [
P2p_pool.Encoding {
tag = 0x10 ;
title = "Ping" ;
encoding = Data_encoding.empty ;
wrap = (function () -> Ping) ;
unwrap = (function Ping -> Some ()) ;

5
src/lib_protocol_environment/sigs/v1/data_encoding.mli
View File

@ -167,7 +167,10 @@ type case_tag = Tag of int | Json_only
type 't case
val case :
?name:string -> case_tag -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
title:string ->
?description:string ->
case_tag -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
val union :
?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding

23
src/lib_rpc/RPC_encoding.ml
View File

@ -52,12 +52,15 @@ let path_item_encoding =
let open Data_encoding in
union [
case (Tag 0) string
~title:"PStatic"
(function PStatic s -> Some s | _ -> None)
(fun s -> PStatic s) ;
case (Tag 1) arg_encoding
~title:"PDynamic"
(function PDynamic s -> Some s | _ -> None)
(fun s -> PDynamic s) ;
case (Tag 2) multi_arg_encoding
~title:"PDynamicTail"
(function PDynamicTail s -> Some s | _ -> None)
(fun s -> PDynamicTail s) ;
]
@ -66,18 +69,22 @@ let query_kind_encoding =
let open Data_encoding in
union [
case (Tag 0)
~title:"Single"
(obj1 (req "single" arg_encoding))
(function Single s -> Some s | _ -> None)
(fun s -> Single s) ;
case (Tag 1)
~title:"Optional"
(obj1 (req "optional" arg_encoding))
(function Optional s -> Some s | _ -> None)
(fun s -> Optional s) ;
case (Tag 2)
~title:"Flag"
(obj1 (req "flag" empty))
(function Flag -> Some () | _ -> None)
(fun () -> Flag) ;
case (Tag 3)
~title:"Multi"
(obj1 (req "multi" arg_encoding))
(function Multi s -> Some s | _ -> None)
(fun s -> Multi s) ;
@ -114,7 +121,9 @@ 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)
~title:"Suffixes"
(obj1 (req "suffixes"
(list (obj2 (req "name" string)
(req "tree" directory_descr_encoding)))))
(function Suffixes map ->
@ -122,7 +131,9 @@ 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)
~title:"Arg"
(obj1 (req "dynamic_dispatch"
(obj2
(req "arg" arg_encoding)
(req "tree" directory_descr_encoding))))
@ -158,10 +169,14 @@ 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)
~title:"Static"
(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)
~title:"Dynamic"
(obj1 (req "dynamic" (option string)))
(function Dynamic descr -> Some descr | _ -> None)
(fun descr -> Dynamic descr) ;
]

10
src/lib_rpc_http/RPC_client.ml
View File

@ -37,35 +37,41 @@ let rpc_error_encoding =
let open Data_encoding in
union
[ case (Tag 0)
~title:"Empty_answer"
(obj1
(req "kind" (constant "empty_answer")))
(function Empty_answer -> Some () | _ -> None)
(fun () -> Empty_answer) ;
case (Tag 1)
~title:"Connection_failed"
(obj2
(req "kind" (constant "connection_failed"))
(req "message" string))
(function Connection_failed msg -> Some ((), msg) | _ -> None)
(function (), msg -> Connection_failed msg) ;
case (Tag 2)
~title:"Bad_request"
(obj2
(req "kind" (constant "bad_request"))
(req "message" string))
(function Bad_request msg -> Some ((), msg) | _ -> None)
(function (), msg -> Bad_request msg) ;
case (Tag 3)
~title:"Method_not_allowed"
(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)
~title:"Unsupported_media_type"
(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)
~title:"Not_acceptable"
(obj3
(req "kind" (constant "not_acceptable"))
(req "proposed" string)
@ -77,6 +83,7 @@ let rpc_error_encoding =
(function ((), proposed, acceptable) ->
Not_acceptable { proposed ; acceptable }) ;
case (Tag 6)
~title:"Unexpected_status_code"
(obj4
(req "kind" (constant "unexpected_status_code"))
(req "code" uint16)
@ -90,6 +97,7 @@ let rpc_error_encoding =
let code = Cohttp.Code.status_of_code code in
Unexpected_status_code { code ; content ; media_type }) ;
case (Tag 7)
~title:"Unexpected_content_type"
(obj4
(req "kind" (constant "unexpected_content_type"))
(req "received" string)
@ -102,6 +110,7 @@ let rpc_error_encoding =
(function ((), received, acceptable, body) ->
Unexpected_content_type { received ; acceptable ; body }) ;
case (Tag 8)
~title:"Unexpected_content"
(obj4
(req "kind" (constant "unexpected_content"))
(req "content" string)
@ -114,6 +123,7 @@ let rpc_error_encoding =
(function ((), content, media_type, error) ->
Unexpected_content { content ; media_type ; error }) ;
case (Tag 9)
~title:"OCaml_exception"
(obj2
(req "kind" (constant "ocaml_exception"))
(req "content" string))

21
src/lib_shell/distributed_db_message.ml
View File

@ -37,10 +37,11 @@ type t =
let encoding =
let open Data_encoding in
let case ?max_length ~tag encoding unwrap wrap =
P2p.Encoding { tag; encoding; wrap; unwrap; max_length } in
let case ?max_length ~tag ~title encoding unwrap wrap =
P2p.Encoding { tag ; title ; encoding ; wrap ; unwrap ; max_length } in
[
case ~tag:0x10
~title:"Get_current_branch"
(obj1
(req "get_current_branch" Chain_id.encoding))
(function
@ -49,6 +50,7 @@ let encoding =
(fun chain_id -> Get_current_branch chain_id) ;
case ~tag:0x11
~title:"Current_branch"
(obj2
(req "chain_id" Chain_id.encoding)
(req "current_branch" Block_locator.encoding))
@ -58,6 +60,7 @@ let encoding =
(fun (chain_id, locator) -> Current_branch (chain_id, locator)) ;
case ~tag:0x12
~title:"Deactivate"
(obj1
(req "deactivate" Chain_id.encoding))
(function
@ -66,14 +69,16 @@ let encoding =
(fun chain_id -> Deactivate chain_id) ;
case ~tag:0x13
~title:"Get_current_head"
(obj1
(req "get_current_head" Chain_id.encoding))
(function
| Get_current_head chain_id -> Some chain_id
| _ -> None)
(fun chain_id -> Get_current_branch chain_id) ;
(fun chain_id -> Get_current_head chain_id) ;
case ~tag:0x14
~title:"Current_head"
(obj3
(req "chain_id" Chain_id.encoding)
(req "current_block_header" (dynamic_size Block_header.encoding))
@ -84,6 +89,7 @@ let encoding =
(fun (chain_id, bh, mempool) -> Current_head (chain_id, bh, mempool)) ;
case ~tag:0x20
~title:"Get_block_headers"
(obj1 (req "get_block_headers" (list Block_hash.encoding)))
(function
| Get_block_headers bhs -> Some bhs
@ -91,6 +97,7 @@ let encoding =
(fun bhs -> Get_block_headers bhs) ;
case ~tag:0x21
~title:"Block_header"
(obj1 (req "block_header" Block_header.encoding))
(function
| Block_header bh -> Some bh
@ -98,6 +105,7 @@ let encoding =
(fun bh -> Block_header bh) ;
case ~tag:0x30
~title:"Get_operations"
(obj1 (req "get_operations" (list Operation_hash.encoding)))
(function
| Get_operations bhs -> Some bhs
@ -105,11 +113,13 @@ let encoding =
(fun bhs -> Get_operations bhs) ;
case ~tag:0x31
~title:"Operation"
(obj1 (req "operation" Operation.encoding))
(function Operation o -> Some o | _ -> None)
(fun o -> Operation o);
case ~tag:0x40
~title:"Get_protocols"
(obj1
(req "get_protocols" (list Protocol_hash.encoding)))
(function
@ -118,11 +128,13 @@ let encoding =
(fun protos -> Get_protocols protos);
case ~tag:0x41
~title:"Protocol"
(obj1 (req "protocol" Protocol.encoding))
(function Protocol proto -> Some proto | _ -> None)
(fun proto -> Protocol proto);
case ~tag:0x50
~title:"Get_operation_hashes_for_blocks"
(obj1 (req "get_operation_hashes_for_blocks"
(list (tup2 Block_hash.encoding int8))))
(function
@ -131,6 +143,7 @@ let encoding =
(fun keys -> Get_operation_hashes_for_blocks keys);
case ~tag:0x51
~title:"Operation_hashes_for_blocks"
(obj3
(req "operation_hashes_for_block"
(obj2
@ -144,6 +157,7 @@ let encoding =
Operation_hashes_for_block (block, ofs, ops, path)) ;
case ~tag:0x60
~title:"Get_operations_for_blocks"
(obj1 (req "get_operations_for_blocks"
(list (obj2
(req "hash" Block_hash.encoding)
@ -154,6 +168,7 @@ let encoding =
(fun keys -> Get_operations_for_blocks keys);
case ~tag:0x61
~title:"Operations_for_blocks"
(obj3
(req "operations_for_block"
(obj2

3
src/lib_shell_services/block_services.ml
View File

@ -112,12 +112,15 @@ let raw_context_encoding =
(fun encoding ->
union [
case (Tag 0) bytes
~title:"Key"
(function Key k -> Some k | _ -> None)
(fun k -> Key k) ;
case (Tag 1) (assoc encoding)
~title:"Dir"
(function Dir k -> Some k | _ -> None)
(fun k -> Dir k) ;
case (Tag 2) null
~title:"Cut"
(function Cut -> Some () | _ -> None)
(fun () -> Cut) ;
])

12
src/lib_shell_services/block_validator_errors.ml
View File

@ -37,6 +37,7 @@ let block_error_encoding =
union
[
case (Tag 0)
~title:"Cannot_parse_operation"
(obj2
(req "error" (constant "cannot_parse_operation"))
(req "operation" Operation_hash.encoding))
@ -44,6 +45,7 @@ let block_error_encoding =
| _ -> None)
(fun ((), operation) -> Cannot_parse_operation operation) ;
case (Tag 1)
~title:"Invalid_fitness"
(obj3
(req "error" (constant "invalid_fitness"))
(req "expected" Fitness.encoding)
@ -54,18 +56,21 @@ let block_error_encoding =
| _ -> None)
(fun ((), expected, found) -> Invalid_fitness { expected ; found }) ;
case (Tag 2)
~title:"Non_increasing_timestamp"
(obj1
(req "error" (constant "non_increasing_timestamp")))
(function Non_increasing_timestamp -> Some ()
| _ -> None)
(fun () -> Non_increasing_timestamp) ;
case (Tag 3)
~title:"Non_increasing_fitness"
(obj1
(req "error" (constant "non_increasing_fitness")))
(function Non_increasing_fitness -> Some ()
| _ -> None)
(fun () -> Non_increasing_fitness) ;
case (Tag 4)
~title:"Invalid_level"
(obj3
(req "error" (constant "invalid_level"))
(req "expected" int32)
@ -76,6 +81,7 @@ let block_error_encoding =
| _ -> None)
(fun ((), expected, found) -> Invalid_level { expected ; found }) ;
case (Tag 5)
~title:"Invalid_proto_level"
(obj3
(req "error" (constant "invalid_proto_level"))
(req "expected" uint8)
@ -87,6 +93,7 @@ let block_error_encoding =
(fun ((), expected, found) ->
Invalid_proto_level { expected ; found }) ;
case (Tag 6)
~title:"Replayed_operation"
(obj2
(req "error" (constant "replayed_operation"))
(req "operation" Operation_hash.encoding))
@ -94,6 +101,7 @@ let block_error_encoding =
| _ -> None)
(fun ((), operation) -> Replayed_operation operation) ;
case (Tag 7)
~title:"Outdated_operation"
(obj3
(req "error" (constant "outdated_operation"))
(req "operation" Operation_hash.encoding)
@ -105,6 +113,7 @@ let block_error_encoding =
(fun ((), operation, originating_block) ->
Outdated_operation { operation ; originating_block }) ;
case (Tag 8)
~title:"Unexpected_number_of_validation_passes"
(obj2
(req "error" (constant "unexpected_number_of_passes"))
(req "found" uint8))
@ -113,6 +122,7 @@ let block_error_encoding =
| _ -> None)
(fun ((), n) -> Unexpected_number_of_validation_passes n) ;
case (Tag 9)
~title:"Too_many_operations"
(obj4
(req "error" (constant "too_many_operations"))
(req "validation_pass" uint8)
@ -125,6 +135,7 @@ let block_error_encoding =
(fun ((), pass, found, max) ->
Too_many_operations { pass ; found ; max }) ;
case (Tag 10)
~title:"Oversized_operation"
(obj4
(req "error" (constant "oversized_operation"))
(req "operation" Operation_hash.encoding)
@ -137,6 +148,7 @@ let block_error_encoding =
(fun ((), operation, size, max) ->
Oversized_operation { operation ; size ; max }) ;
case (Tag 11)
~title:"Unallowed_pass"
(obj4
(req "error" (constant "invalid_pass"))
(req "operation" Operation_hash.encoding)

6
src/lib_shell_services/block_validator_worker_state.ml
View File

@ -49,17 +49,17 @@ module Event = struct
let encoding =
let open Data_encoding in
union
[ case (Tag 0) ~name:"Debug"
[ case (Tag 0) ~title:"Debug"
(obj1 (req "message" string))
(function Debug msg -> Some msg | _ -> None)
(fun msg -> Debug msg) ;
case (Tag 1) ~name:"Validation_success"
case (Tag 1) ~title:"Validation_success"
(obj2
(req "successful_validation" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function Validation_success (r, s) -> Some (r, s) | _ -> None)
(fun (r, s) -> Validation_success (r, s)) ;
case (Tag 2) ~name:"Validation_failure"
case (Tag 2) ~title:"Validation_failure"
(obj3
(req "failed_validation" Request.encoding)
(req "status" Worker_types.request_status_encoding)

2
src/lib_shell_services/chain_validator_worker_state.ml
View File

@ -39,6 +39,7 @@ module Event = struct
let open Data_encoding in
union
[ case (Tag 0)
~title:"Processed_block"
(obj4
(req "request" Request.encoding)
(req "status" Worker_types.request_status_encoding)
@ -54,6 +55,7 @@ module Event = struct
(fun (request, request_status, update, fitness) ->
Processed_block { request ; request_status ; update ; fitness }) ;
case (Tag 1)
~title:"Could_not_switch_testchain"
RPC_error.encoding
(function
| Could_not_switch_testchain err -> Some err

7
src/lib_shell_services/peer_validator_worker_state.ml
View File

@ -15,13 +15,13 @@ module Request = struct
let encoding =
let open Data_encoding in
union
[ case (Tag 0) ~name:"New_head"
[ case (Tag 0) ~title:"New_head"
(obj2
(req "request" (constant "new_head"))
(req "block" Block_hash.encoding))
(function New_head h -> Some ((), h) | _ -> None)
(fun ((), h) -> New_head h) ;
case (Tag 1) ~name:"New_branch"
case (Tag 1) ~title:"New_branch"
(obj3
(req "request" (constant "new_branch"))
(req "block" Block_hash.encoding)
@ -51,16 +51,19 @@ module Event = struct
let open Data_encoding in
union
[ case (Tag 0)
~title:"Debug"
(obj1 (req "message" string))
(function Debug msg -> Some msg | _ -> None)
(fun msg -> Debug msg) ;
case (Tag 1)
~title:"Request"
(obj2
(req "request" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function Request (req, t, None) -> Some (req, t) | _ -> None)
(fun (req, t) -> Request (req, t, None)) ;
case (Tag 2)
~title:"Failed request"
(obj3
(req "error" RPC_error.encoding)
(req "failed_request" Request.encoding)

8
src/lib_shell_services/prevalidator_worker_state.ml
View File

@ -22,12 +22,14 @@ module Request = struct
let open Data_encoding in
union
[ case (Tag 0)
~title:"Flush"
(obj2
(req "request" (constant "flush"))
(req "block" Block_hash.encoding))
(function View (Flush hash) -> Some ((), hash) | _ -> None)
(fun ((), hash) -> View (Flush hash)) ;
case (Tag 1)
~title:"Notify"
(obj3
(req "request" (constant "notify"))
(req "peer" P2p_peer.Id.encoding)
@ -35,12 +37,14 @@ module Request = struct
(function View (Notify (peer, mempool)) -> Some ((), peer, mempool) | _ -> None)
(fun ((), peer, mempool) -> View (Notify (peer, mempool))) ;
case (Tag 2)
~title:"Inject"
(obj2
(req "request" (constant "inject"))
(req "operation" Operation.encoding))
(function View (Inject op) -> Some ((), op) | _ -> None)
(fun ((), op) -> View (Inject op)) ;
case (Tag 3)
~title:"Arrived"
(obj3
(req "request" (constant "arrived"))
(req "operation_hash" Operation_hash.encoding)
@ -48,6 +52,7 @@ module Request = struct
(function View (Arrived (oph, op)) -> Some ((), oph, op) | _ -> None)
(fun ((), oph, op) -> View (Arrived (oph, op))) ;
case (Tag 4)
~title:"Advertise"
(obj1 (req "request" (constant "advertise")))
(function View Advertise -> Some () | _ -> None)
(fun () -> View Advertise) ]
@ -99,16 +104,19 @@ module Event = struct
let open Data_encoding in
union
[ case (Tag 0)
~title:"Debug"
(obj1 (req "message" string))
(function Debug msg -> Some msg | _ -> None)
(fun msg -> Debug msg) ;
case (Tag 1)
~title:"Request"
(obj2
(req "request" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function Request (req, t, None) -> Some (req, t) | _ -> None)
(fun (req, t) -> Request (req, t, None)) ;
case (Tag 2)
~title:"Failed request"
(obj3
(req "error" RPC_error.encoding)
(req "failed_request" Request.encoding)

2
src/lib_shell_services/validation_errors.ml
View File

@ -158,12 +158,14 @@ let protocol_error_encoding =
union
[
case (Tag 0)
~title:"Compilation failed"
(obj1
(req "error" (constant "compilation_failed")))
(function Compilation_failed -> Some ()
| _ -> None)
(fun () -> Compilation_failed) ;
case (Tag 1)
~title:"Dynlinking failed"
(obj1
(req "error" (constant "dynlinking_failed")))
(function Dynlinking_failed -> Some ()

5
src/lib_shell_services/worker_types.ml
View File

@ -44,18 +44,21 @@ let worker_status_encoding error_encoding =
let open Data_encoding in
union
[ case (Tag 0)
~title:"Launching"
(obj2
(req "phase" (constant "launching"))
(req "since" Time.encoding))
(function Launching t -> Some ((), t) | _ -> None)
(fun ((), t) -> Launching t) ;
case (Tag 1)
~title:"Running"
(obj2
(req "phase" (constant "running"))
(req "since" Time.encoding))
(function Running t -> Some ((), t) | _ -> None)
(fun ((), t) -> Running t) ;
case (Tag 2)
~title:"Closing"
(obj3
(req "phase" (constant "closing"))
(req "birth" Time.encoding)
@ -63,6 +66,7 @@ let worker_status_encoding error_encoding =
(function Closing (t0, t) -> Some ((), t0, t) | _ -> None)
(fun ((), t0, t) -> Closing (t0, t)) ;
case (Tag 3)
~title:"Closed"
(obj3
(req "phase" (constant "closed"))
(req "birth" Time.encoding)
@ -70,6 +74,7 @@ let worker_status_encoding error_encoding =
(function Closed (t0, t, None) -> Some ((), t0, t) | _ -> None)
(fun ((), t0, t) -> Closed (t0, t, None)) ;
case (Tag 4)
~title:"Crashed"
(obj4
(req "phase" (constant "crashed"))
(req "birth" Time.encoding)

2
src/lib_signer_services/signer_messages.ml
View File

@ -72,12 +72,14 @@ module Request = struct
let open Data_encoding in
union [
case (Tag 0)
~title:"Sign"
(merge_objs
(obj1 (req "kind" (constant "sign")))
Sign.Request.encoding)
(function Sign req -> Some ((), req) | _ -> None)
(fun ((), req) -> Sign req) ;
case (Tag 1)
~title:"Public_key"
(merge_objs
(obj1 (req "kind" (constant "public_key")))
Public_key.Request.encoding)

8
src/proto_alpha/lib_client/client_proto_context.ml
View File

@ -241,11 +241,15 @@ let activation_key_encoding =
~binary:raw_activation_key_encoding
~json:
(union [
case Json_only
case
~title:"Activation"
Json_only
raw_activation_key_encoding
(fun x -> Some x)
(fun x -> x) ;
case Json_only
case
~title:"Deprecated_activation"
Json_only
(obj6
(req "pkh" Ed25519.Public_key_hash.encoding)
(req "amount" Tez.encoding)

2
src/proto_alpha/lib_client_commands/client_proto_context_commands.ml
View File

@ -380,7 +380,6 @@ let commands () =
cctxt#message "%a"
Data_encoding.Binary_schema.pp
(Data_encoding.Binary.describe
~toplevel_name:"Unsigned block header"
(Alpha_context.Block_header.unsigned_encoding)) >>= fun () ->
return ()
end ;
@ -392,7 +391,6 @@ let commands () =
cctxt#message "%a"
Data_encoding.Binary_schema.pp
(Data_encoding.Binary.describe
~toplevel_name:"Unsigned operation"
Alpha_context.Operation.unsigned_encoding) >>= fun () ->
return ()
end

3
src/proto_alpha/lib_protocol/src/alpha_services.ml
View File

@ -22,14 +22,17 @@ module Nonce = struct
let open Data_encoding in
union [
case (Tag 0)
~title:"Revealed"
(obj1 (req "nonce" Nonce.encoding))
(function Revealed nonce -> Some nonce | _ -> None)
(fun nonce -> Revealed nonce) ;
case (Tag 1)
~title:"Missing"
(obj1 (req "hash" Nonce_hash.encoding))
(function Missing nonce -> Some nonce | _ -> None)
(fun nonce -> Missing nonce) ;
case (Tag 2)
~title:"Forgotten"
empty
(function Forgotten -> Some () | _ -> None)
(fun () -> Forgotten) ;

9
src/proto_alpha/lib_protocol/src/apply_operation_result.ml
View File

@ -33,12 +33,14 @@ let balance_encoding =
def "operation_metadata.alpha.balance" @@
union
[ case (Tag 0)
~title:"Contract"
(obj2
(req "kind" (constant "contract"))
(req "contract" Contract.encoding))
(function Contract c -> Some ((), c) | _ -> None )
(fun ((), c) -> (Contract c)) ;
case (Tag 1)
~title:"Rewards"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "rewards"))
@ -47,6 +49,7 @@ let balance_encoding =
(function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Rewards (d, l)) ;
case (Tag 2)
~title:"Fees"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "fees"))
@ -55,6 +58,7 @@ let balance_encoding =
(function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Fees (d, l)) ;
case (Tag 3)
~title:"Deposits"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "deposits"))
@ -147,6 +151,7 @@ module Manager_result = struct
def (Format.asprintf "operation.alpha.operation_result.%s" name) @@
union ~tag_size:`Uint8 [
case (Tag 0)
~title:"Applied"
(merge_objs
(obj1
(req "status" (constant "applied")))
@ -160,12 +165,14 @@ module Manager_result = struct
| Some o -> Some ((), proj o))
(fun ((), x) -> (Applied (inj x))) ;
case (Tag 1)
~title:"Failed"
(obj2
(req "status" (constant "failed"))
(req "errors" (list error_encoding)))
(function (Failed (_, errs)) -> Some ((), errs) | _ -> None)
(fun ((), errs) -> Failed (kind, errs)) ;
case (Tag 2)
~title:"Skipped"
(obj1 (req "status" (constant "skipped")))
(function Skipped _ -> Some () | _ -> None)
(fun () -> Skipped kind)
@ -292,6 +299,7 @@ let internal_operation_result_encoding :
(Manager_result.MCase res_case : kind Manager_result.case) =
let Operation.Encoding.Manager_operations.MCase op_case = res_case.op_case in
case (Tag op_case.tag)
~title:op_case.name
(merge_objs
(obj3
(req "kind" (constant op_case.name))
@ -357,6 +365,7 @@ module Encoding = struct
let tagged_case tag name args proj inj =
let open Data_encoding in
case tag
~title:(String.capitalize_ascii name)
(merge_objs
(obj1 (req "kind" (constant name)))
args)

4
src/proto_alpha/lib_protocol/src/contract_repr.ml
View File

@ -59,12 +59,12 @@ let encoding =
~binary:
(union ~tag_size:`Uint8 [
case (Tag 0)
~name:"Implicit"
~title:"Implicit"
Signature.Public_key_hash.encoding
(function Implicit k -> Some k | _ -> None)
(fun k -> Implicit k) ;
case (Tag 1) Contract_hash.encoding
~name:"Originated"
~title:"Originated"
(function Originated k -> Some k | _ -> None)
(fun k -> Originated k) ;
])

8
src/proto_alpha/lib_protocol/src/gas_limit_repr.ml
View File

@ -22,10 +22,14 @@ type cost =
let encoding =
let open Data_encoding in
union
[ case (Tag 0) z
[ case (Tag 0)
~title:"Limited"
z
(function Limited { remaining } -> Some remaining | _ -> None)
(fun remaining -> Limited { remaining }) ;
case (Tag 1) (constant "unaccounted")
case (Tag 1)
~title:"Unaccounted"
(constant "unaccounted")
(function Unaccounted -> Some () | _ -> None)
(fun () -> Unaccounted) ]

8
src/proto_alpha/lib_protocol/src/manager_repr.ml
View File

@ -18,14 +18,18 @@ type t = manager_key
open Data_encoding
let hash_case tag =
case tag Signature.Public_key_hash.encoding
case tag
~title:"Public_key_hash"
Signature.Public_key_hash.encoding
(function
| Hash hash -> Some hash
| _ -> None)
(fun hash -> Hash hash)
let pubkey_case tag =
case tag Signature.Public_key.encoding
case tag
~title:"Public_key"
Signature.Public_key.encoding
(function
| Public_key hash -> Some hash
| _ -> None)

1
src/proto_alpha/lib_protocol/src/operation_repr.ml
View File

@ -177,6 +177,7 @@ module Encoding = struct
let case tag name args proj inj =
let open Data_encoding in
case tag
~title:(String.capitalize_ascii name)
(merge_objs
(obj1 (req "kind" (constant name)))
args)

4
src/proto_alpha/lib_protocol/src/raw_context.ml
View File

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

2
src/proto_alpha/lib_protocol/src/storage.ml
View File

@ -253,6 +253,7 @@ module Cycle = struct
let open Data_encoding in
union [
case (Tag 0)
~title:"Unrevealed"
(tup4
Nonce_hash.encoding
Signature.Public_key_hash.encoding
@ -265,6 +266,7 @@ module Cycle = struct
(fun (nonce_hash, delegate, rewards, fees) ->
Unrevealed { nonce_hash ; delegate ; rewards ; fees }) ;
case (Tag 1)
~title:"Revealed"
Seed_repr.nonce_encoding
(function
| Revealed nonce -> Some nonce

5
src/proto_alpha/lib_protocol/src/storage_description.ml
View File

@ -252,16 +252,15 @@ let build_directory : type key. key t -> key RPC_directory.t =
let open Data_encoding in
union [
case (Tag 0)
~title:"Leaf"
(dynamic_size arg_encoding)
(function (key, None) -> Some key | _ -> None)
(fun key -> (key, None)) ;
case (Tag 1)
~title:"Dir"
(tup2
(dynamic_size arg_encoding)
(dynamic_size handler.encoding))
(* (obj2 *)
(* (req "key" (dynamic_size arg_encoding)) *)
(* (req "value" (dynamic_size handler.encoding))) *)
(function (key, Some value) -> Some (key, value) | _ -> None)
(fun (key, value) -> (key, Some value)) ;
] in

4
src/proto_alpha/lib_protocol/src/voting_period_repr.ml
View File

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

4
src/proto_genesis/lib_protocol/src/data.ml
View File

@ -36,7 +36,7 @@ module Command = struct
let open Data_encoding in
union ~tag_size:`Uint8 [
case (Tag 0)
~name:"activate"
~title:"Activate"
(mk_case "activate"
(obj3
(req "hash" Protocol_hash.encoding)
@ -50,7 +50,7 @@ module Command = struct
(fun (protocol, fitness, protocol_parameters) ->
Activate { protocol ; fitness ; protocol_parameters }) ;
case (Tag 1)
~name:"activate_testchain"
~title:"Activate_testchain"
(mk_case "activate_testchain"
(obj2
(req "hash" Protocol_hash.encoding)