Data_encoding: generate RST for binary description

docs/doc_gen/p2p_doc.ml

@@ -11,10 +11,6 @@ let protocols = [
   "Alpha", "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK" ;
 ]
 
-let pp_pre f ppf x =
-  Rst.pp_raw_html ppf
-    (Format.asprintf "<pre>@\n%a@\n</pre>" (fun ppf () -> f ppf x) ())
-
 let main _node =
   (* Style : hack *)
   Format.printf "%a@." Rst.pp_raw_html Rst.style ;
@@ -31,24 +27,24 @@ let main _node =
   Format.printf "@\n" ;
   (* Data *)
   Format.printf "%a@\n@\n%a@\n@."
-    Rst.pp_h2 "Block header (shell)"
+    Rst.pp_h1 "Block header (shell)"
-    (pp_pre Data_encoding.Binary_schema.pp)
+    Data_encoding.Binary_schema.pp
     (Data_encoding.Binary.describe Block_header.encoding) ;
   Format.printf "%a@\n@\n%a@\n@."
-    Rst.pp_h2 "Operation (shell)"
+    Rst.pp_h1 "Operation (shell)"
-    (pp_pre Data_encoding.Binary_schema.pp)
+    Data_encoding.Binary_schema.pp
     (Data_encoding.Binary.describe Operation.encoding) ;
   List.iter
     (fun (_name, hash) ->
        let hash = Protocol_hash.of_b58check_exn hash in
        let (module Proto) = Registered_protocol.get_exn hash in
        Format.printf "%a@\n@\n%a@\n@."
-         Rst.pp_h2 "Operation (alpha-specific)"
+         Rst.pp_h1 "Block_header (alpha-specific)"
-         (pp_pre Data_encoding.Binary_schema.pp)
+         Data_encoding.Binary_schema.pp
          (Data_encoding.Binary.describe Proto.block_header_data_encoding) ;
        Format.printf "%a@\n@\n%a@\n@."
-         Rst.pp_h2 "Operation (alpha-specific)"
+         Rst.pp_h1 "Operation (alpha-specific)"
-         (pp_pre Data_encoding.Binary_schema.pp)
+         Data_encoding.Binary_schema.pp
          (Data_encoding.Binary.describe Proto.operation_data_encoding) ;
     )
     protocols ;

docs/doc_gen/rst.ml

@@ -31,6 +31,9 @@ let pp_ref ppf name = Format.fprintf ppf ".. _%s :@\n@\n" name
 
 let style = {css|
 <style>
+   .wy-nav-content {
+      max-width: 100%;
+   }
   .tab {
     overflow: hidden;
     border: 1px solid #ccc;

src/lib_data_encoding/binary_description.ml

@@ -492,4 +492,9 @@ let describe (type x) ?toplevel_name (encoding : x Encoding.t) =
              false
          | _ -> true)
       rev_references in
-  dedup_canonicalize filtered
+  let filtered = dedup_canonicalize filtered in
+  let is_top = (fun (Binary_schema.{ name }, _) -> name = toplevel_name) in
+  let description, toplevel  = List.find is_top filtered in
+  let fields = List.filter (fun d -> not (is_top d)) filtered in
+  { Binary_schema.description ; toplevel ; fields }
+

src/lib_data_encoding/binary_schema.ml

@@ -44,7 +44,12 @@ and description =
   { name : string ;
     description : string option }
 
-type t = (description * toplevel_encoding) list
+
+type t = {
+  description: description ;
+  toplevel: toplevel_encoding ;
+  fields: (description * toplevel_encoding) list ;
+}
 
 module Printer = struct
 
@@ -188,6 +193,14 @@ module Printer = struct
         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))
@@ -199,25 +212,33 @@ module Printer = struct
            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
+      Option.iter ~f:(Format.fprintf ppf "%s@,@,") in
-    Format.fprintf ppf "@[<v 0>%a %s%a@,@,%a@,%a@,%a@,@]"
+    Format.fprintf ppf "@[<v 0>%a@,@,%a%a@,%a@,%a@,%a@,@]"
-      (pad '#') level
+      (pp_title level) title
-      title
       pp_option_nl description
+      (pp_line '-') headers
       (pp_row ' ') headers
-      (pp_row '-') (List.map (fun _ -> "-") headers)
+      (pp_line '=') headers
       (Format.pp_print_list
          ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,")
-         (pp_row ' '))
+         (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 %s:%a@,%a@]"
+        Format.fprintf ppf "@[<v 0>%a@,@,%a@,%a@]"
-          (pad '#') (initial_level + 1)
+          (pp_title (initial_level + 1)) name
-          name
           (fun ppf -> function
              | None -> ()
              | Some description ->
@@ -229,12 +250,14 @@ module Printer = struct
               ppf)
           (List.map (fun x -> (initial_level + 2, x)) tables)
 
-  let pp ppf descrs =
+  let pp ppf { description ; toplevel = t; fields } =
-    Format.pp_print_list
+    let s = toplevel (description, t) in
-      ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,")
+    Format.fprintf ppf "%a@,%a"
-      (pp_print_structure ~initial_level:0)
+      (pp_print_structure ~initial_level:0) s
-      ppf
+      (Format.pp_print_list
-      (to_print_ast descrs)
+         ~pp_sep:(fun ppf () -> Format.fprintf ppf "@,")
+         (pp_print_structure ~initial_level:0))
+      (to_print_ast fields)
 
 end
 
@@ -490,10 +513,19 @@ module Encoding = struct
     ]
 
   let encoding =
-    list
+    conv
-      (obj2
+      (fun { description ; toplevel ; fields } ->
-         (req "description" description_encoding)
+         (description, toplevel, fields))
-         (req "encoding" binary_description_encoding))
+      (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
 

src/lib_data_encoding/binary_schema.mli

@@ -44,7 +44,11 @@ and description =
   { name : string ;
     description : string option }
 
-type t = (description * toplevel_encoding) list
+type t = {
+  description: description ;
+  toplevel: toplevel_encoding ;
+  fields: (description * toplevel_encoding) list ;
+}
 
 module Printer : sig
   val pp_layout : Format.formatter -> layout -> unit