Data_encoding: binary description printing

docs/doc_gen/rpcs/rpc_doc.ml

@@ -200,7 +200,7 @@ module Description = struct
           pp_button ppf
             ~default:true ~shortlabel:"descr" ~content:"Description"
             target_ref ;
-          Option.iter service.input ~f: begin fun __ ->
+          Option.iter service.input ~f: begin fun _ ->
             pp_button ppf
               ~default:false ~shortlabel:"input" ~content:"Input format"
               target_ref
@@ -212,14 +212,14 @@ module Description = struct
         pp_content ppf
           ~tag:"p" ~shortlabel:"descr" target_ref
           pp_description service ;
-        Option.iter service.input ~f: begin fun schema ->
+        Option.iter service.input ~f: begin fun (schema, _) ->
           pp_content ppf
             ~tag:"pre" ~shortlabel:"input" target_ref
             Json_schema.pp schema ;
         end ;
         pp_content ppf
           ~tag:"pre" ~shortlabel:"output" target_ref
-          Json_schema.pp service.output ;
+          Json_schema.pp (fst service.output) ;
       end
 
   end

src/bin_client/client_rpc_commands.ml

@@ -301,12 +301,12 @@ let schema meth url (cctxt : #Client_context.full) =
             "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
           return ()
       | { input = Some input ; output } ->
-          let json = `O [ "input", Json_schema.to_json input ;
+          let json = `O [ "input", Json_schema.to_json (fst input) ;
-                          "output", Json_schema.to_json output ] in
+                          "output", Json_schema.to_json (fst output) ] in
           cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
           return ()
       | { input = None ; output } ->
-          let json = `O [ "output", Json_schema.to_json output ] in
+          let json = `O [ "output", Json_schema.to_json (fst output) ] in
           cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json >>= fun () ->
           return ()
     end
@@ -315,9 +315,14 @@ let schema meth url (cctxt : #Client_context.full) =
         "No service found at this URL (but this is a valid prefix)\n%!" >>= fun () ->
       return ()
 
-let format meth url (cctxt : #Client_context.io_rpcs) =
+let format binary meth url (cctxt : #Client_context.io_rpcs) =
   let args = String.split '/' url in
   let open RPC_description in
+  let pp =
+    if binary then
+      (fun ppf (_, schema) -> Data_encoding.Binary_schema.pp ppf schema)
+    else
+      (fun ppf (schema, _) -> Json_schema.pp ppf schema) in
   RPC_description.describe cctxt ~recurse:false args >>=? function
   | Static { services } -> begin
       match RPC_service.MethMap.find meth services with
@@ -331,15 +336,15 @@ let format meth url (cctxt : #Client_context.io_rpcs) =
              @[<v 2>Input format:@,%a@]@,\
              @[<v 2>Output format:@,%a@]@,\
              @]"
-            Json_schema.pp input
+            pp input
-            Json_schema.pp output >>= fun () ->
+            pp output >>= fun () ->
           return ()
       | { input = None ; output } ->
           cctxt#message
             "@[<v 0>\
              @[<v 2>Output format:@,%a@]@,\
              @]"
-            Json_schema.pp output >>= fun () ->
+            pp output >>= fun () ->
           return ()
     end
   | _ ->
@@ -381,7 +386,7 @@ let call meth raw_url (cctxt : #Client_context.full) =
           cctxt#generic_json_call meth uri >>=?
           display_answer cctxt
       | { input = Some input } ->
-          fill_in ~show_optionals:false input >>= function
+          fill_in ~show_optionals:false (fst input) >>= function
           | Error msg ->
               cctxt#error "%s" msg >>= fun () ->
               return ()
@@ -470,12 +475,16 @@ let commands = [
 
   command ~group
     ~desc: "Get the humanoid readable input and output formats of an RPC."
-    no_options
+    (args1
+       (switch
+          ~doc:"Binary format"
+          ~short:'b'
+          ~long:"binary" ()))
     (prefixes [ "rpc" ; "format"] @@
      meth_params @@
      string ~name: "url" ~desc: "the RPC URL" @@
      stop)
-    (fun () -> format) ;
+    format ;
 
   command ~group
     ~desc: "Call an RPC with the GET method."

src/lib_data_encoding/binary_description.ml

@@ -0,0 +1,412 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+let unopt_lazy func = function
+  | None -> func ()
+  | Some x -> x
+
+type recursives = string list
+type references = { descriptions : (string * Binary_schema.toplevel_encoding) list } [@@unwrapped]
+
+(* Simple Union find implementation, there are several optimizations
+   that give UF it's usual time complexity that could be added.
+   If this is a bottleneck, they're easy to add. *)
+module UF : sig
+  type t
+  val add : t -> Binary_schema.description -> unit
+  val find : t -> string -> Binary_schema.description
+  val union : t -> new_cannonical:Binary_schema.description -> existing:string -> unit
+  val empty : unit -> t
+  val pp : Format.formatter -> t -> unit
+end = struct
+  open Binary_schema
+  type ele = Ref of string | Root of description
+  type t = (string, ele) Hashtbl.t
+  let add t x = Hashtbl.replace t x.name (Root x)
+  let rec find tbl key =
+    match Hashtbl.find tbl key with
+    | Ref s -> find tbl s
+    | Root desc -> desc
+
+  let union tbl ~new_cannonical ~existing =
+    add tbl new_cannonical ;
+    let root = find tbl existing in
+    if root.name = new_cannonical.name
+    then ()
+    else Hashtbl.replace tbl root.name (Ref new_cannonical.name)
+
+  let empty () = Hashtbl.create 128
+
+  let pp ppf tbl =
+    Format.fprintf ppf "@[<v 2>UF:@,%a@]"
+      (fun ppf ->
+         (Hashtbl.iter (fun k v ->
+              Format.fprintf ppf "'%s' ---> %a@,"
+                k (fun ppf -> function
+                    | Root { name } -> Format.fprintf ppf "Root '%s'" name
+                    | Ref s -> Format.fprintf ppf "Ref '%s'" s) v))) tbl
+end
+
+let fixup_references uf =
+  let open Binary_schema in
+  let rec fixup_layout = function
+    | Ref s -> Ref (UF.find uf s).name
+    | Enum (i, name) -> Enum (i, (UF.find uf name).name)
+    | Seq layout -> Seq (fixup_layout layout)
+    | (Zero_width
+      | Int _
+      | Bool
+      | RangedInt (_, _)
+      | RangedFloat (_, _)
+      | Float
+      | Bytes
+      | String) as enc -> enc in
+  let field = function
+    | Named_field (name, kind, layout) ->
+        Named_field (name, kind, fixup_layout layout)
+    | Anonymous_field (kind, layout) ->
+        Anonymous_field (kind, fixup_layout layout)
+    | Dynamic_field i ->
+        Dynamic_field i
+    | (Option_indicator_field _) as field -> field in
+  function
+  | Obj { fields } -> Obj { fields = List.map field fields }
+  | Cases ({ cases } as x) ->
+      Cases { x with
+              cases = List.map
+                  (fun (i, name, fields) ->
+                     (i, name, List.map field fields)) cases }
+  | (Int_enum _ as ie) -> ie
+
+let z_reference_name = "Z.t"
+
+let z_reference_description =
+  "A variable length sequence of bytes, encoding a Zarith number. \
+   Each byte has a running unary size bit: the most significant bit of \
+   each byte tells is this is the last byte in the sequence (0) or if \
+   there is more to read (1). The second most significant bit of the \
+   first byte is reserved for the sign (positive if zero). Size and \
+   sign bits ignored, data is then the binary representation of the \
+   absolute value of the number in little endian order."
+
+let z_encoding =
+  Binary_schema.Obj { fields = [ Named_field ("Z.t", `Dynamic, Bytes) ] }
+
+let add_z_reference uf { descriptions } =
+  UF.add uf { name = z_reference_name ;
+              description = Some z_reference_description } ;
+  { descriptions = (z_reference_name, z_encoding) :: descriptions }
+
+let n_reference_name = "N.t"
+
+let n_reference_description =
+  "A variable length sequence of bytes, encoding a Zarith number. \
+   Each byte has a running unary size bit: the most significant bit of \
+   each byte tells is this is the last byte in the sequence (0) or if \
+   there is more to read (1). Size bits ignored, data is then the binary \
+   representation of the absolute value of the number in little endian order."
+
+let n_encoding =
+  Binary_schema.Obj { fields = [ Named_field ("N.t", `Dynamic, Bytes) ] }
+
+let add_n_reference uf { descriptions } =
+  UF.add uf { name = n_reference_name ;
+              description = Some n_reference_description } ;
+  { descriptions = (n_reference_name, n_encoding) :: descriptions }
+
+let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
+  let open Encoding in
+  let uf = UF.empty () in
+  let uf_add_name name =
+    UF.add uf { name ; description = None } in
+  let add_reference name description { descriptions } =
+    { descriptions = (name, description) :: descriptions } in
+  let new_reference =
+    let x = ref ~-1 in
+    fun () ->
+      x := !x + 1 ;
+      let name = "X_" ^ string_of_int !x in
+      uf_add_name name ;
+      name in
+  let extract_dynamic :
+    type x. x Encoding.desc -> Binary_schema.field_descr list * x Encoding.desc =
+    function
+    | Dynamic_size { encoding } -> ([ Dynamic_field 1 ], encoding.encoding)
+    | enc -> ([], enc) in
+  let rec field_descr :
+    type a. recursives -> references ->
+    a Encoding.field -> Binary_schema.field_descr list * references =
+    fun recursives references -> function
+      | Req { name ; encoding = ({ encoding } as enc) }
+      | Dft { name ; encoding = ({ encoding } as enc) } ->
+          let (dynamics, field) = extract_dynamic encoding in
+          let (layout, references) = layout recursives references field in
+          (dynamics @ [ Named_field (name, classify enc, layout) ], references)
+      | Opt { kind = `Variable ; name ; encoding = { encoding } } ->
+          let (layout, references) = layout recursives references encoding in
+          ([ Named_field (name, `Variable, layout) ], references)
+      | Opt { kind = `Dynamic ; name ; encoding = { encoding } } ->
+          let (dynamics, field) = extract_dynamic encoding in
+          let (layout, references) = layout recursives references field in
+          (Binary_schema.Option_indicator_field name :: dynamics @ [ Named_field (name, `Dynamic, layout) ], references)
+  and obj fields =
+    Binary_schema.Obj { fields }
+  and union :
+    type a. recursives -> references -> Kind.t -> Binary_size.tag_size -> a case list -> string * references=
+    fun recursives references kind size cases ->
+      let cases =
+        List.sort (fun (t1, _) (t2, _) -> Compare.Int.compare t1 t2) @@
+        TzList.filter_map
+          (function
+            | Case { tag = Json_only } -> None
+            | (Case { tag = Tag tag } as case) -> Some (tag, case))
+          cases in
+      let tag_field =
+        Binary_schema.Named_field ("Tag", `Fixed (Binary_size.tag_size size), Int (size :> Binary_schema.integer_extended)) in
+      let (cases, references) =
+        List.fold_right
+          (fun (tag, Case case) (cases, references) ->
+             let fields, references = fields recursives references case.encoding.encoding in
+             ((tag, case.name, tag_field :: fields) :: cases, references))
+          cases
+          ([], references) in
+      let name = new_reference () in
+      let references =
+        add_reference
+          name
+          (Cases { kind ;
+                   tag_size = size ;
+                   cases }) references in
+      (name, references)
+  and describe  : type b. ?description:string -> name:string ->
+    recursives -> references -> b desc -> string * references =
+    fun ?description ~name recursives references encoding ->
+      let new_cannonical = { Binary_schema.name ; description } in
+      UF.add uf new_cannonical ;
+      let layout, references = layout recursives references encoding in
+      begin
+        match layout with
+        | Ref ref_name ->
+            UF.union uf ~existing:ref_name ~new_cannonical ;
+            (ref_name, references)
+        | layout ->
+            UF.add uf new_cannonical ;
+            (name,
+             add_reference name
+               (obj [ Anonymous_field (classify { encoding ; json_encoding = None }, layout) ])
+               references)
+      end
+  and enum : type a. (a, _) Hashtbl.t -> a array -> _ = fun tbl encoding_array ->
+    (Binary_size.range_to_size ~minimum:0 ~maximum:(Array.length encoding_array),
+     List.map
+       (fun i -> (i, fst @@ Hashtbl.find tbl encoding_array.(i)))
+       Utils.Infix.(0 -- ((Array.length encoding_array) - 1)))
+  and fields :
+    type b. recursives -> references ->
+    b Encoding.desc -> Binary_schema.fields * references =
+    fun recursives references -> function
+      | Obj field ->
+          field_descr recursives references field
+      | Objs { left ; right } ->
+          let (left_fields, references) =
+            fields recursives references left.encoding in
+          let (right_fields, references) = fields 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)
+      | Ignore -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references)
+      | Constant _ -> ([ Anonymous_field (`Fixed 0, Zero_width) ], references)
+      | Dynamic_size { encoding } ->
+          let (fields, refs) = fields recursives references encoding.encoding in
+          (Dynamic_field (List.length fields) :: fields, refs)
+      | Conv { encoding } ->
+          fields recursives references encoding.encoding
+      | Describe { id = name ; description ; encoding } ->
+          let (name, references) = describe ~name ?description recursives references encoding.encoding in
+          ([ Anonymous_field (classify encoding, Ref name) ], references)
+      | Splitted { encoding } ->
+          fields recursives references encoding.encoding
+      | Delayed func ->
+          fields recursives references (func ()).encoding
+      | List { encoding } ->
+          let (layout, references) = layout recursives references encoding in
+          ([ Anonymous_field (`Variable, Seq layout) ],
+           references)
+      | Array { encoding } ->
+          let (layout, references) = layout recursives references encoding in
+          ([ Anonymous_field (`Variable, Seq layout) ],
+           references)
+      | Bytes kind ->
+          ([ Anonymous_field ((kind :> Kind.t), Bytes) ], references)
+      | String kind ->
+          ([ Anonymous_field ((kind :> Kind.t), String) ], references)
+      | (String_enum (tbl, encoding_array) as encoding) ->
+          let size, cases = enum tbl encoding_array in
+          let name = new_reference () in
+          ([ Anonymous_field (classify { encoding ; json_encoding = None }, Ref name) ],
+           add_reference name (Int_enum { size ; cases }) references)
+      | Tup ({ encoding } as enc) ->
+          let (layout, references) = layout recursives references encoding in
+          ([ Anonymous_field (classify enc, layout) ], references)
+      | Tups { left ; right } ->
+          let (fields1, references) = fields recursives references left.encoding in
+          let (fields2, references) = fields recursives references right.encoding in
+          (fields1 @ fields2, references)
+      | 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) ->
+          let kind = (kind :> Kind.t) in
+          if List.mem name recursives
+          then ([ Anonymous_field (kind, Ref name) ], references)
+          else
+            let { encoding } = fix { encoding ; json_encoding = None } in
+            let (name, references) = describe ~name ?description (name :: recursives) references encoding in
+            ([ Anonymous_field (kind, Ref name) ], references)
+      | encoding ->
+          let layout, references = layout recursives references encoding in
+          ([ Anonymous_field (classify (make encoding), layout) ], references)
+  and layout :
+    type c. recursives -> references ->
+    c Encoding.desc -> Binary_schema.layout * references =
+    fun recursives references -> function
+      | Null -> (Zero_width, references)
+      | Empty -> (Zero_width, references)
+      | Ignore -> (Zero_width, references)
+      | Constant _ -> (Zero_width, references)
+      | Bool -> (Bool, references)
+      | Int8 -> (Int `Int8, references)
+      | Uint8 -> (Int `Uint8, references)
+      | Int16 -> (Int `Int16, references)
+      | Uint16 -> (Int `Uint16, references)
+      | Int31 -> (RangedInt (~-1073741824, 1073741823), references)
+      | Int32 -> (Int `Int32, references)
+      | Int64 -> (Int `Int64, references)
+      | N ->
+          (Ref n_reference_name,
+           add_n_reference uf references)
+      | Z ->
+          (Ref z_reference_name,
+           add_z_reference uf references)
+      | RangedInt { minimum ; maximum } ->
+          (RangedInt (minimum, maximum), references)
+      | RangedFloat { minimum ; maximum } ->
+          (RangedFloat (minimum, maximum), references)
+      | Float ->
+          (Float, references)
+      | Bytes _kind ->
+          (Bytes, references)
+      | String _kind ->
+          (String, references)
+      | String_enum (tbl, encoding_array) ->
+          let name = new_reference () in
+          let size, cases = enum tbl encoding_array in
+          let references = add_reference name (Int_enum { size ; cases }) references in
+          (Enum (size, name), references)
+      | Array data ->
+          let (descr, references) = layout recursives references data.encoding in
+          (Seq descr, references)
+      | List data ->
+          let layout, references =
+            layout recursives references data.encoding in
+          (Seq layout, references)
+      | (Obj _) as enc ->
+          let name = new_reference () in
+          let fields, references = fields recursives references enc in
+          let references = add_reference name (obj fields) references in
+          (Ref name, references)
+      | Objs { left ; right } ->
+          let name = new_reference () in
+          let fields1, references = fields recursives references left.encoding in
+          let fields2, references = fields recursives references right.encoding in
+          let references = add_reference name (obj (fields1 @ fields2)) references in
+          (Ref name, references)
+      | Tup { encoding } ->
+          layout recursives references encoding
+      | (Tups _ as descr) ->
+          let fields, references = fields recursives references descr in
+          let name = new_reference () in
+          let references = add_reference name (obj fields) references in
+          (Ref name, references)
+      | Union { kind ; tag_size ; cases } ->
+          let name, references = union recursives references kind tag_size cases in
+          (Ref name, references)
+      | Mu { name ; description ; fix } as encoding ->
+          if List.mem name recursives
+          then (Ref name, references)
+          else
+            let { encoding } = fix { encoding ; json_encoding = None } in
+            let (name, references) = describe ~name ?description (name :: recursives) references encoding in
+            (Ref name, references)
+      | Conv { encoding } ->
+          layout recursives references encoding.encoding
+      | Describe { id = name ; description ; encoding } ->
+          let name, references =
+            describe ~name ?description recursives references encoding.encoding in
+          (Ref name, references)
+      | Splitted { encoding } ->
+          layout recursives references encoding.encoding
+      | (Dynamic_size _) as encoding ->
+          let fields, references = fields recursives references encoding in
+          let name = new_reference () in
+          UF.add uf { name ; description = None } ;
+          (Ref name, add_reference name (obj fields) references)
+      | Check_size { encoding } ->
+          layout recursives references encoding.encoding
+      | Delayed func ->
+          layout recursives references (func ()).encoding in
+  let toplevel_name = Option.unopt ~default:"Toplevel encoding" toplevel_name in
+  uf_add_name toplevel_name ;
+  let fields, references = fields [] { descriptions = [] } encoding.encoding in
+  let rev_references = (toplevel_name, obj fields) :: references.descriptions in
+  let dedup_canonicalize =
+    let tbl : (Binary_schema.toplevel_encoding, Binary_schema.description) Hashtbl.t = Hashtbl.create 100 in
+    let rec help prev_len acc = function
+      | [] ->
+          let fixedup =
+            List.map
+              (fun (desc, layout) -> (desc, fixup_references uf layout))
+              acc in
+          if List.length fixedup = prev_len
+          then
+            List.map
+              (fun (name, layout) ->
+                 (UF.find uf name, layout))
+              fixedup
+          else
+            begin
+              Hashtbl.clear tbl ;
+              help (List.length fixedup) [] fixedup
+            end
+      | (name, layout) :: tl ->
+          match Hashtbl.find_opt tbl layout with
+          | None ->
+              let desc = UF.find uf name in
+              begin
+                Hashtbl.add tbl layout desc ;
+                help prev_len ((desc.name, layout) :: acc) tl
+              end
+          | Some original_desc ->
+              begin
+                UF.union uf
+                  ~new_cannonical:original_desc
+                  ~existing:name ;
+                help prev_len acc tl
+              end
+    in help 0 [] in
+  let filtered =
+    List.filter
+      (fun (name, encoding) ->
+         match encoding with
+         | Binary_schema.Obj { fields = [ Anonymous_field (_, Ref reference) ] } ->
+             UF.union uf ~new_cannonical:(UF.find uf name) ~existing:reference ;
+             false
+         | _ -> true)
+      rev_references in
+  dedup_canonicalize filtered

src/lib_data_encoding/binary_description.mli

@@ -0,0 +1,10 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val describe : ?toplevel_name:string -> 'a Encoding.t -> Binary_schema.t

src/lib_data_encoding/binary_schema.ml

@@ -0,0 +1,481 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    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_field of int
+  | Option_indicator_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 * 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 Signed Integer, with 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 byte) floating point number in the range %f to %f"
+          minimum maximum
+    | Float ->
+        Format.fprintf ppf "Double precision (8 byte) 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" ; "Kind" ; "Data" ]
+  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_field i ->
+        [ Format.asprintf "Size of next %d fields" i ;
+          Format.asprintf "%a" pp_kind (`Fixed 4) ; string_of_layout (Int `Int32) ]
+    | Anonymous_field (kind, desc) ->
+        [ "Unnamed field " ^ anon_num () ;
+          Format.asprintf "%a" pp_kind kind ;
+          string_of_layout desc ]
+    | Option_indicator_field name ->
+        [ "Presence of " ^ name ;
+          Format.asprintf "%a" pp_kind (`Fixed 1) ;
+          "0 if not present and 1 if present" ]
+
+  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_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_option_nl ppf =
+      Option.iter ~f:(Format.fprintf ppf "@,%s") in
+    Format.fprintf ppf "@[<v 0>%a %s%a@,@,%a@,%a@,%a@,@]"
+      (pad '#') level
+      title
+      pp_option_nl description
+      (pp_row ' ') headers
+      (pp_row '-') (List.map (fun _ -> "-") headers)
+      (Format.pp_print_list
+         ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,")
+         (pp_row ' '))
+      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 %s:%a@,%a@]"
+          (pad '#') (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 descrs =
+    Format.pp_print_list
+      ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,")
+      (pp_print_structure ~initial_level:0)
+      ppf
+      (to_print_ast descrs)
+
+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
+             ~name:"Zero_width"
+             (Tag 0)
+             (obj1
+                (req "kind" (constant "Zero_width")))
+             (function
+               | Zero_width -> Some ()
+               | _ -> None)
+             (fun () -> Zero_width) ;
+           case ~name:"Int"
+             (Tag 1)
+             (obj2
+                (req "size" integer_extended_encoding)
+                (req "kind" (constant "Int")))
+             (function
+               | Int integer -> Some (integer, ())
+               | _ -> None)
+             (fun (integer, _)-> Int integer) ;
+           case ~name:"Bool"
+             (Tag 2)
+             (obj1 (req "kind" (constant "Bool")))
+             (function
+               | Bool -> Some ()
+               | _ -> None)
+             (fun () -> Bool) ;
+           case ~name:"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 ~name:"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 ~name:"Float"
+             (Tag 5)
+             (obj1 (req "kind" (constant "Float")))
+             (function
+               | Float -> Some ()
+               | _ -> None)
+             (fun () -> Float) ;
+           case ~name:"Bytes"
+             (Tag 6)
+             (obj1 (req "kind" (constant "Bytes")))
+             (function
+               | Bytes -> Some ()
+               | _ -> None)
+             (fun () -> Bytes) ;
+           case ~name:"String"
+             (Tag 7)
+             (obj1 (req "kind" (constant "String")))
+             (function
+               | String -> Some ()
+               | _ -> None)
+             (fun () -> String) ;
+           case ~name:"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 ~name:"Seq"
+             (Tag 9)
+             (obj2
+                (req "layout" layout)
+                (req "kind" (constant "Seq")))
+             (function
+               | Seq layout -> Some (layout, ())
+               | _ -> None)
+             (fun (layout, ()) -> Seq layout) ;
+           case ~name:"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 ~name:"Dynamic"
+           (Tag 0)
+           (obj1 (req "kind" (constant "Dynamic")))
+           (function `Dynamic -> Some ()
+                   | _ -> None)
+           (fun () -> `Dynamic) ;
+         case ~name:"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 ~name:"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 field_descr_encoding =
+    let dynamic_layout_encoding = dynamic_size layout_encoding in
+    def "schema.field" @@
+    union [
+      case ~name:"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 ~name:"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 ~name:"Dynamic_field"
+        (Tag 2)
+        (obj2
+           (req "kind" (constant "dyn"))
+           (req "num_fields" int31))
+        (function Dynamic_field i -> Some ((), i)
+                | _ -> None)
+        (fun ((), i) -> Dynamic_field i) ;
+      case ~name:"Option_indicator_field"
+        (Tag 3)
+        (obj2
+           (req "kind" (constant "option_indicator"))
+           (req "name" string))
+        (function Option_indicator_field s -> Some ((), s)
+                | _ -> None)
+        (fun ((), s) -> Option_indicator_field s)
+    ]
+
+  let tag_size_encoding =
+    string_enum
+      [("Uint16", `Uint16) ;
+       ("Uint8", `Uint8) ]
+
+  let binary_description_encoding =
+    union [
+      case ~name:"Obj"
+        (Tag 0)
+        (obj1
+           (req "fields" (list (dynamic_size field_descr_encoding))))
+        (function
+          | Obj { fields } -> Some (fields)
+          | _ -> None)
+        (fun (fields) -> Obj { fields }) ;
+      case ~name:"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 ~name:"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 =
+    list
+      (obj2
+         (req "description" description_encoding)
+         (req "encoding" binary_description_encoding))
+
+end
+
+let encoding = Encoding.encoding
+let pp = Printer.pp

src/lib_data_encoding/binary_schema.mli

@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** This is for use *within* the data encoding library only. *)
+
+type integer_extended = [ Binary_size.integer | `Int32 | `Int64 ]
+
+type field_descr =
+  | Named_field of string * Encoding.Kind.t * layout
+  | Anonymous_field of Encoding.Kind.t * layout
+  | Dynamic_field of int
+  | Option_indicator_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 : Encoding.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 * toplevel_encoding) list
+
+module Printer : sig
+  val pp_layout : Format.formatter -> layout -> unit
+end
+
+val pp: Format.formatter -> t -> unit
+val encoding: t Encoding.t

src/lib_data_encoding/data_encoding.ml

@@ -109,12 +109,14 @@ include Encoding
 
 module Json = Json
 module Bson = Bson
+module Binary_schema = Binary_schema
 module Binary = struct
   include Binary_error
   include Binary_length
   include Binary_writer
   include Binary_reader
   include Binary_stream_reader
+  let describe = Binary_description.describe
 end
 
 type json = Json.t

src/lib_data_encoding/data_encoding.mli

@@ -591,6 +591,12 @@ module Bson: sig
 
 end
 
+module Binary_schema : sig
+  type t
+  val pp: Format.formatter -> t -> unit
+  val encoding: t Encoding.t
+end
+
 module Binary: sig
 
   (** All the errors that might be returned while reading a binary value *)
@@ -672,6 +678,8 @@ module Binary: sig
       it raises [Write_error] instead of return [None] in case of error. *)
   val to_bytes_exn : 'a Encoding.t -> 'a -> MBytes.t
 
+  val describe : ?toplevel_name:string -> 'a Encoding.t -> Binary_schema.t
+
 end
 
 type json = Json.t

src/lib_rpc/RPC_description.mli

@@ -15,5 +15,5 @@ val describe:
   #RPC_context.simple ->
   ?recurse:bool ->
   string list ->
-  Json_schema.schema directory tzresult Lwt.t
+  RPC_encoding.schema directory tzresult Lwt.t
 

src/lib_rpc/RPC_encoding.ml

@@ -8,11 +8,19 @@
 (**************************************************************************)
 
 type 'a t = 'a Data_encoding.t
-type schema = Data_encoding.json_schema
+type schema = Data_encoding.json_schema * Data_encoding.Binary_schema.t
 let unit = Data_encoding.empty
 let untyped = Data_encoding.(obj1 (req "untyped" string))
 let conv f g t = Data_encoding.conv ~schema:(Data_encoding.Json.schema t) f g t
-let schema = Data_encoding.Json.schema
+let schema t =
+  (Data_encoding.Json.schema t,
+   Data_encoding.Binary.describe t)
+
+let schema_encoding =
+  let open Data_encoding in
+  obj2
+    (req "json_schema" json_schema)
+    (req "binary_schema" Data_encoding.Binary_schema.encoding)
 
 module StringMap = Resto.StringMap
 
@@ -97,9 +105,9 @@ let service_descr_encoding =
        (req "path" (list path_item_encoding))
        (opt "description" string)
        (req "query" (list query_item_encoding))
-       (opt "input" json_schema)
+       (opt "input" schema_encoding)
-       (req "output" json_schema)
+       (req "output" schema_encoding)
-       (req "erro" json_schema))
+       (req "error" schema_encoding))
 
 let directory_descr_encoding =
   let open Data_encoding in

src/lib_rpc/RPC_encoding.mli

@@ -7,6 +7,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
-include Resto.ENCODING with type 'a t = 'a Data_encoding.t
+type schema = Data_encoding.json_schema * Data_encoding.Binary_schema.t
-                        and type schema = Data_encoding.json_schema
+
+include Resto.ENCODING with type 'a t = 'a Data_encoding.t
+                        and type schema := schema
 

src/lib_rpc/RPC_service.mli

@@ -76,7 +76,7 @@ val put_service:
 
 val description_service:
   ([ `GET ], unit, unit * string list, Resto.Description.request,
-   unit, Json_schema.schema Resto.Description.directory) service
+   unit, RPC_encoding.schema Resto.Description.directory) service
 
 val error_service:
   ([ `GET ], unit, unit, unit, unit, Json_schema.schema) service