534 lines
18 KiB
OCaml
534 lines
18 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* Copyright (c) 2014 - 2018. *)
|
|
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
(* *)
|
|
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
open Encoding
|
|
|
|
type integer_extended = [ Binary_size.integer | `Int32 | `Int64 ]
|
|
|
|
type field_descr =
|
|
| Named_field of string * Kind.t * layout
|
|
| Anonymous_field of Kind.t * layout
|
|
| Dynamic_size_field of string option * int * Binary_size.unsigned_integer
|
|
| Optional_field of string
|
|
|
|
and layout =
|
|
| Zero_width
|
|
| Int of integer_extended
|
|
| Bool
|
|
| RangedInt of int * int
|
|
| RangedFloat of float * float
|
|
| Float
|
|
| Bytes
|
|
| String
|
|
| Enum of Binary_size.integer * string
|
|
| Seq of layout (* For arrays and lists *)
|
|
| Ref of string
|
|
|
|
and fields = field_descr list
|
|
|
|
and toplevel_encoding =
|
|
| Obj of { fields : fields }
|
|
| Cases of { kind : Kind.t ;
|
|
tag_size : Binary_size.tag_size ;
|
|
cases : (int * string option * fields) list }
|
|
| Int_enum of { size : Binary_size.integer ;
|
|
cases : (int * string) list }
|
|
|
|
and description =
|
|
{ name : string ;
|
|
description : string option }
|
|
|
|
|
|
type t = {
|
|
description: description ;
|
|
toplevel: toplevel_encoding ;
|
|
fields: (description * toplevel_encoding) list ;
|
|
}
|
|
|
|
module Printer = struct
|
|
|
|
type table =
|
|
{ title : string ;
|
|
description : string option ;
|
|
headers : string list ;
|
|
body : string list list }
|
|
|
|
type print_structure =
|
|
| Table of table
|
|
| Union of string * string option * Binary_size.tag_size * table list
|
|
|
|
let pp_kind ppf = function
|
|
| `Fixed size -> Format.fprintf ppf "%d byte%s" size (if size = 1 then "" else "s")
|
|
| `Variable -> Format.fprintf ppf "Variable size"
|
|
| `Dynamic -> Format.fprintf ppf "Determined from data"
|
|
|
|
let pp_int ppf (int : integer_extended) =
|
|
Format.fprintf ppf "%s"
|
|
begin
|
|
match int with
|
|
| `Int16 -> "16 bit Signed Integer"
|
|
| `Int31 -> "32 bit Signed Integer in the range [2^30, 2^30-1]"
|
|
| `Uint30 -> "32 bit Signed Integer in the range [0, 2^30-1]"
|
|
| `Int32 -> "32 bit Signed Integer"
|
|
| `Int64 -> "64 bit Signed Integer"
|
|
| `Int8 -> "8 bit Signed Integer"
|
|
| `Uint16 -> "16 bit Unsigned Integer"
|
|
| `Uint8 -> "8 bit Unsigned Integer"
|
|
end
|
|
|
|
let rec pp_layout ppf = function
|
|
| Zero_width ->
|
|
Format.fprintf ppf "Zero width data, not actually present in the encoding"
|
|
| Int integer ->
|
|
Format.fprintf ppf "%a" pp_int integer
|
|
| Bool ->
|
|
Format.fprintf ppf "8 bit unsigned integer: 0 for false and 255 for true"
|
|
| RangedInt (minimum, maximum) ->
|
|
Format.fprintf ppf "%a in the range %d to %d"
|
|
pp_int ((Binary_size.range_to_size ~minimum ~maximum) :> integer_extended) minimum maximum
|
|
| RangedFloat (minimum, maximum) ->
|
|
Format.fprintf ppf
|
|
"Double precision (8 bytes) floating point number in the range %f to %f"
|
|
minimum maximum
|
|
| Float ->
|
|
Format.fprintf ppf "Double precision (8 bytes) floating point number"
|
|
| Bytes ->
|
|
Format.fprintf ppf "Bytes"
|
|
| String ->
|
|
Format.fprintf ppf "String"
|
|
| Ref reference ->
|
|
Format.fprintf ppf "$%s" reference
|
|
| Enum (size, reference) ->
|
|
Format.fprintf ppf "%a encoding an enumeration (see %s)"
|
|
pp_int (size :> integer_extended)
|
|
reference
|
|
| Seq (Ref reference) -> Format.fprintf ppf "Sequence of %s" reference
|
|
| Seq data -> Format.fprintf ppf "Sequence of %a" pp_layout data
|
|
|
|
|
|
let binary_table_headers = [ "Name" ; "Size" ; "Contents" ]
|
|
let enum_headers = [ "Case number" ; "Encoded string" ]
|
|
|
|
let pp_tag_size ppf tag =
|
|
Format.fprintf ppf "%s" @@
|
|
match tag with
|
|
| `Uint8 -> "8 bit"
|
|
| `Uint16 -> "16 bit"
|
|
|
|
let field_descr () =
|
|
let reference = ref 0 in
|
|
let string_of_layout = Format.asprintf "%a" pp_layout in
|
|
let anon_num () =
|
|
let value = !reference in
|
|
reference := value + 1;
|
|
string_of_int value in
|
|
function
|
|
| Named_field (name, kind, desc) ->
|
|
[ name ; Format.asprintf "%a" pp_kind kind ; string_of_layout desc ]
|
|
| Dynamic_size_field (Some name, 1, size) ->
|
|
[ Format.asprintf "# bytes in field \"%s\"" name ;
|
|
Format.asprintf "%a"
|
|
pp_kind (`Fixed (Binary_size.integer_to_size size)) ;
|
|
string_of_layout (Int (size :> integer_extended)) ]
|
|
| Dynamic_size_field (None, 1, size) ->
|
|
[ Format.asprintf "# bytes in next field" ;
|
|
Format.asprintf "%a"
|
|
pp_kind (`Fixed (Binary_size.integer_to_size size)) ;
|
|
string_of_layout (Int (size :> integer_extended)) ]
|
|
| Dynamic_size_field (_, i, size) ->
|
|
[ Format.asprintf "# bytes in next %d fields" i ;
|
|
Format.asprintf "%a"
|
|
pp_kind (`Fixed (Binary_size.integer_to_size size)) ;
|
|
string_of_layout (Int (size :> integer_extended)) ]
|
|
| Anonymous_field (kind, desc) ->
|
|
[ "Unnamed field " ^ anon_num () ;
|
|
Format.asprintf "%a" pp_kind kind ;
|
|
string_of_layout desc ]
|
|
| Optional_field name ->
|
|
[ Format.asprintf "? presence of field \"%s\"" name ;
|
|
Format.asprintf "%a" pp_kind (`Fixed 1) ;
|
|
string_of_layout Bool ]
|
|
|
|
let toplevel ({ name ; description }, encoding) =
|
|
match encoding with
|
|
| Obj { fields } ->
|
|
Table { title = Format.asprintf "%s" name ;
|
|
description ;
|
|
headers = binary_table_headers ;
|
|
body = List.map (field_descr ()) fields }
|
|
| Cases { kind ; tag_size ; cases } ->
|
|
Union (Format.asprintf "%s (%a, %a tag)" name pp_kind kind pp_tag_size tag_size,
|
|
description, tag_size,
|
|
List.map
|
|
(fun (tag, name, fields) ->
|
|
{ title =
|
|
begin
|
|
match name with
|
|
| Some name -> Format.asprintf "%s (tag %d)" name tag
|
|
| None -> Format.asprintf "Tag %d" tag
|
|
end;
|
|
description = None ;
|
|
headers = binary_table_headers ;
|
|
body = List.map (field_descr ()) fields })
|
|
cases)
|
|
| Int_enum { size ; cases } ->
|
|
Table
|
|
{ title = Format.asprintf "Enum %s (%a):" name pp_int (size :> integer_extended) ;
|
|
description = None;
|
|
headers = enum_headers ;
|
|
body = List.map (fun (num, str) -> [ string_of_int num ; str ]) cases }
|
|
|
|
let to_print_ast encodings =
|
|
List.map toplevel encodings
|
|
|
|
let rec pad char ppf = function
|
|
| 0 -> ()
|
|
| n ->
|
|
Format.pp_print_char ppf char ;
|
|
pad char ppf (n - 1)
|
|
|
|
let pp_title level ppf title =
|
|
let char =
|
|
if level = 1 then '*' else
|
|
if level = 2 then '=' else
|
|
'`' in
|
|
let sub = String.map (fun _ -> char) title in
|
|
Format.fprintf ppf "@[<v 0>%s@ %s@ @ @]" title sub
|
|
|
|
let pp_table ppf (level, { title ; description ; headers ; body }) =
|
|
let max_widths =
|
|
List.fold_left (List.map2 (fun len str -> max (String.length str) len))
|
|
(List.map String.length headers)
|
|
body in
|
|
let pp_row pad_char ppf =
|
|
Format.fprintf ppf "|%a"
|
|
(fun ppf ->
|
|
List.iter2
|
|
(fun width str -> Format.fprintf ppf " %s%a |" str (pad pad_char) (width - (String.length str)))
|
|
max_widths) in
|
|
let pp_line c ppf =
|
|
Format.fprintf ppf "+%a"
|
|
(fun ppf ->
|
|
List.iter2
|
|
(fun width _str -> Format.fprintf ppf "%a+" (pad c) (width + 2))
|
|
max_widths) in
|
|
let pp_option_nl ppf =
|
|
Option.iter ~f:(Format.fprintf ppf "%s@,@,") in
|
|
Format.fprintf ppf "@[<v 0>%a@,@,%a%a@,%a@,%a@,%a@,@]"
|
|
(pp_title level) title
|
|
pp_option_nl description
|
|
(pp_line '-') headers
|
|
(pp_row ' ') headers
|
|
(pp_line '=') headers
|
|
(Format.pp_print_list
|
|
~pp_sep:(fun ppf () -> Format.fprintf ppf "@,")
|
|
(fun ppf s ->
|
|
Format.fprintf ppf "%a@,%a"
|
|
(pp_row ' ') s
|
|
(pp_line '-') s))
|
|
body
|
|
|
|
let pp_print_structure ?(initial_level=0) ppf = function
|
|
| Table table -> pp_table ppf (1 + initial_level, table)
|
|
| Union (name, description, _tag_size, tables) ->
|
|
Format.fprintf ppf "@[<v 0>%a@,@,%a@,%a@]"
|
|
(pp_title (initial_level + 1)) name
|
|
(fun ppf -> function
|
|
| None -> ()
|
|
| Some description ->
|
|
Format.fprintf ppf "@,%s" description)
|
|
description
|
|
(fun ppf -> Format.pp_print_list
|
|
~pp_sep:(fun ppf () -> Format.fprintf ppf "@,")
|
|
pp_table
|
|
ppf)
|
|
(List.map (fun x -> (initial_level + 2, x)) tables)
|
|
|
|
let pp ppf { description ; toplevel = t; fields } =
|
|
let s = toplevel (description, t) in
|
|
Format.fprintf ppf "%a@,%a"
|
|
(pp_print_structure ~initial_level:0) s
|
|
(Format.pp_print_list
|
|
~pp_sep:(fun ppf () -> Format.fprintf ppf "@,")
|
|
(pp_print_structure ~initial_level:0))
|
|
(to_print_ast fields)
|
|
|
|
end
|
|
|
|
module Encoding = struct
|
|
|
|
let description_encoding =
|
|
conv
|
|
(fun { name ; description } -> (name, description))
|
|
(fun (name, description) -> { name ; description })
|
|
(obj2
|
|
(req "name" string)
|
|
(opt "description" string))
|
|
|
|
|
|
let integer_cases =
|
|
[ ("Int16", `Int16) ;
|
|
("Int8", `Int8) ;
|
|
("Uint16", `Uint16) ;
|
|
("Uint8", `Uint8) ]
|
|
|
|
let integer_encoding : Binary_size.integer encoding =
|
|
string_enum integer_cases
|
|
|
|
let integer_extended_encoding =
|
|
string_enum
|
|
(("Int64", `Int64) ::
|
|
("Int32", `Int32) ::
|
|
integer_cases)
|
|
|
|
let layout_encoding =
|
|
mu "layout"
|
|
(fun layout ->
|
|
union [
|
|
case
|
|
~title:"Zero_width"
|
|
(Tag 0)
|
|
(obj1
|
|
(req "kind" (constant "Zero_width")))
|
|
(function
|
|
| Zero_width -> Some ()
|
|
| _ -> None)
|
|
(fun () -> Zero_width) ;
|
|
case ~title:"Int"
|
|
(Tag 1)
|
|
(obj2
|
|
(req "size" integer_extended_encoding)
|
|
(req "kind" (constant "Int")))
|
|
(function
|
|
| Int integer -> Some (integer, ())
|
|
| _ -> None)
|
|
(fun (integer, _)-> Int integer) ;
|
|
case ~title:"Bool"
|
|
(Tag 2)
|
|
(obj1 (req "kind" (constant "Bool")))
|
|
(function
|
|
| Bool -> Some ()
|
|
| _ -> None)
|
|
(fun () -> Bool) ;
|
|
case ~title:"RangedInt"
|
|
(Tag 3)
|
|
(obj3
|
|
(req "min" int31)
|
|
(req "max" int31)
|
|
(req "kind" (constant "RangedInt")))
|
|
(function
|
|
| RangedInt (min, max) -> Some (min, max, ())
|
|
| _ -> None)
|
|
(fun (min, max, _) -> RangedInt (min, max)) ;
|
|
case ~title:"RangedFloat"
|
|
(Tag 4)
|
|
(obj3
|
|
(req "min" float)
|
|
(req "max" float)
|
|
(req "kind" (constant "RangedFloat")))
|
|
(function
|
|
| RangedFloat (min, max) -> Some (min, max, ())
|
|
| _ -> None)
|
|
(fun (min, max, ()) -> RangedFloat (min, max)) ;
|
|
case ~title:"Float"
|
|
(Tag 5)
|
|
(obj1 (req "kind" (constant "Float")))
|
|
(function
|
|
| Float -> Some ()
|
|
| _ -> None)
|
|
(fun () -> Float) ;
|
|
case ~title:"Bytes"
|
|
(Tag 6)
|
|
(obj1 (req "kind" (constant "Bytes")))
|
|
(function
|
|
| Bytes -> Some ()
|
|
| _ -> None)
|
|
(fun () -> Bytes) ;
|
|
case ~title:"String"
|
|
(Tag 7)
|
|
(obj1 (req "kind" (constant "String")))
|
|
(function
|
|
| String -> Some ()
|
|
| _ -> None)
|
|
(fun () -> String) ;
|
|
case ~title:"Enum"
|
|
(Tag 8)
|
|
(obj3
|
|
(req "size" integer_encoding)
|
|
(req "reference" string)
|
|
(req "kind" (constant "Enum")))
|
|
(function
|
|
| Enum (size, cases) -> Some (size, cases, ())
|
|
| _ -> None)
|
|
(fun (size, cases, _) -> Enum (size, cases)) ;
|
|
case ~title:"Seq"
|
|
(Tag 9)
|
|
(obj2
|
|
(req "layout" layout)
|
|
(req "kind" (constant "Seq")))
|
|
(function
|
|
| Seq layout -> Some (layout, ())
|
|
| _ -> None)
|
|
(fun (layout, ()) -> Seq layout) ;
|
|
case ~title:"Ref"
|
|
(Tag 10)
|
|
(obj2
|
|
(req "name" string)
|
|
(req "kind" (constant "Float")))
|
|
(function
|
|
| Ref layout -> Some (layout, ())
|
|
| _ -> None)
|
|
(fun (name, ()) -> Ref name)
|
|
])
|
|
|
|
let kind_enum_cases =
|
|
(fun () ->
|
|
[ case ~title:"Dynamic"
|
|
(Tag 0)
|
|
(obj1 (req "kind" (constant "Dynamic")))
|
|
(function `Dynamic -> Some ()
|
|
| _ -> None)
|
|
(fun () -> `Dynamic) ;
|
|
case ~title:"Variable"
|
|
(Tag 1)
|
|
(obj1 (req "kind" (constant "Variable")))
|
|
(function `Variable -> Some ()
|
|
| _ -> None)
|
|
(fun () -> `Variable) ])
|
|
|
|
let kind_enum_encoding =
|
|
def "schema.kind.enum" @@ union (kind_enum_cases ())
|
|
|
|
let kind_t_encoding =
|
|
def "schema.kind" @@
|
|
union
|
|
((case ~title:"Fixed"
|
|
(Tag 2)
|
|
(obj2
|
|
(req "size" int31)
|
|
(req "kind" (constant "Float")))
|
|
(function `Fixed n -> Some (n, ())
|
|
| _ -> None)
|
|
(fun (n, _) -> `Fixed n)) :: (kind_enum_cases ()))
|
|
|
|
let unsigned_integer_encoding =
|
|
string_enum
|
|
[("Uint30", `Uint30) ;
|
|
("Uint16", `Uint16) ;
|
|
("Uint8", `Uint8) ]
|
|
|
|
let field_descr_encoding =
|
|
let dynamic_layout_encoding = dynamic_size layout_encoding in
|
|
def "schema.field" @@
|
|
union [
|
|
case ~title:"Named_field"
|
|
(Tag 0)
|
|
(obj4
|
|
(req "name" string)
|
|
(req "layout" dynamic_layout_encoding)
|
|
(req "data_kind" kind_t_encoding)
|
|
(req "kind" (constant "named")))
|
|
(function Named_field (name, kind, layout) -> Some (name, layout, kind, ())
|
|
| _ -> None)
|
|
(fun (name, kind, layout, _) -> Named_field (name, layout, kind)) ;
|
|
case ~title:"Anonymous_field"
|
|
(Tag 1)
|
|
(obj3
|
|
(req "layout" dynamic_layout_encoding)
|
|
(req "kind" (constant "anon"))
|
|
(req "data_kind" kind_t_encoding))
|
|
(function Anonymous_field (kind, layout) -> Some (layout, (), kind)
|
|
| _ -> None)
|
|
(fun (kind, _, layout) -> Anonymous_field (layout, kind)) ;
|
|
case ~title:"Dynamic_field"
|
|
(Tag 2)
|
|
(obj4
|
|
(req "kind" (constant "dyn"))
|
|
(opt "name" string)
|
|
(req "num_fields" int31)
|
|
(req "size" unsigned_integer_encoding))
|
|
(function Dynamic_size_field (name, i, size) -> Some ((), name, i, size)
|
|
| _ -> None)
|
|
(fun ((), name, i, size) -> Dynamic_size_field (name, i, size)) ;
|
|
case ~title:"Optional_field"
|
|
(Tag 3)
|
|
(obj2
|
|
(req "kind" (constant "option_indicator"))
|
|
(req "name" string))
|
|
(function Optional_field s -> Some ((), s)
|
|
| _ -> None)
|
|
(fun ((), s) -> Optional_field s)
|
|
]
|
|
|
|
let tag_size_encoding =
|
|
string_enum
|
|
[("Uint16", `Uint16) ;
|
|
("Uint8", `Uint8) ]
|
|
|
|
let binary_description_encoding =
|
|
union [
|
|
case ~title:"Obj"
|
|
(Tag 0)
|
|
(obj1
|
|
(req "fields" (list (dynamic_size field_descr_encoding))))
|
|
(function
|
|
| Obj { fields } -> Some (fields)
|
|
| _ -> None)
|
|
(fun (fields) -> Obj { fields }) ;
|
|
case ~title:"Cases"
|
|
(Tag 1)
|
|
(obj3
|
|
(req "tag_size" tag_size_encoding)
|
|
(req "kind" (dynamic_size kind_t_encoding))
|
|
(req "cases"
|
|
(list
|
|
(def "union case" @@
|
|
conv
|
|
(fun (tag, name, fields) -> (tag, fields, name))
|
|
(fun (tag, fields, name) -> (tag, name, fields)) @@
|
|
obj3
|
|
(req "tag" int31)
|
|
(req "fields" (list (dynamic_size field_descr_encoding)))
|
|
(opt "name" string)))))
|
|
(function
|
|
| Cases { kind ; tag_size ; cases } ->
|
|
Some (tag_size, kind, cases)
|
|
| _ -> None)
|
|
(fun (tag_size, kind, cases) ->
|
|
Cases { kind ; tag_size ; cases }) ;
|
|
case ~title:"Int_enum"
|
|
(Tag 2)
|
|
(obj2
|
|
(req "size" integer_encoding)
|
|
(req "cases" (list (tup2 int31 string))))
|
|
(function Int_enum { size ; cases } -> Some (size, cases)
|
|
| _ -> None)
|
|
(fun (size, cases) -> Int_enum { size ; cases })
|
|
]
|
|
|
|
let encoding =
|
|
conv
|
|
(fun { description ; toplevel ; fields } ->
|
|
(description, toplevel, fields))
|
|
(fun (description, toplevel, fields) ->
|
|
{ description ; toplevel ; fields }) @@
|
|
obj3
|
|
(req "description" description_encoding)
|
|
(req "toplevel" binary_description_encoding)
|
|
(req "fields"
|
|
(list
|
|
(obj2
|
|
(req "description" description_encoding)
|
|
(req "encoding" binary_description_encoding))))
|
|
|
|
end
|
|
|
|
let encoding = Encoding.encoding
|
|
let pp = Printer.pp
|