ligo/docs/doc_gen/errors/error_doc.ml

(**************************************************************************)
(*                                                                        *)
(*    Copyright (c) 2014 - 2018.                                          *)
(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
(*                                                                        *)
(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
(*                                                                        *)
(**************************************************************************)

open Format

(* TODO: add section descriptions *)

let default_section_id = "default"
let default_section_title = "Miscellaneous"

(* Association list where keys are set of identifier's prefixes that
   maps to a section title. The ordering of sections in the rst output
   depends on their position in this list.

   e.g. : an error which id is 'utils.Timeout' will be documented
   under the `Miscellaneous` section which will be displayed at the
   bottom of the document. Unprefixed ids or unreferenced prefixes
   will default to `Miscellaneous` *)
let section_titles =
  [ [ "proto.alpha" ], "Protocol Alpha";
    [ "distributed_db" ; "node" ; "raw_store" ; "validator" ; "worker" ], "Shell" ;
    [ "micheline" ; "michelson" ], "Michelson parsing/macros" ;
    [ "rpc_client" ], "Client" ;
    [ "cli"; "utils"; default_section_id ], default_section_title ;
  ]
let pp_rst_title ~char ppf title =
  let sub = String.map (fun _ -> char) title in
  fprintf ppf "@[<v 0>%s@\n@]@[<v 0>%s@\n@\n@]" title sub

let pp_rst_h1 = pp_rst_title ~char:'#'
let pp_rst_h2 = pp_rst_title ~char:'*'
(* let pp_rst_h3 = pp_rst_title ~char:'='
 * let pp_rst_h4 = pp_rst_title ~char:'`' *)

let string_of_err_category =
  let open Error_monad in function
    | `Branch -> "branch"
    | `Temporary -> "temporary"
    | `Permanent -> "permanent"

let make_counter () =
  let i = ref 1 in
  fun () -> incr i; !i

let count = make_counter ()

let unique_label () =
  let label = sprintf "ref%d" (count ()) in
  label

let pp_print_html_tab_button fmt ?(default=false) ~shortlabel ~content idref =
  fprintf fmt "<button class=\"tablinks%s\" onclick=\"showTab(this, '%s', '%s')\">%s</button>@ "
    (if default then " defaultOpen" else "")
    (idref ^ shortlabel) idref content

let pp_print_html_tabs fmt { Error_monad.id ; category ; description ; schema ; _  } =
  let idref = unique_label () in
  let descr_label = "descr" in
  let schema_label = "schema" in

  fprintf fmt "@[<v 2>.. raw:: html@ @ ";
  fprintf fmt "@[<v 2><div class=\"tab\">@ ";

  fprintf fmt "%a" (pp_print_html_tab_button ~default:true ~shortlabel:descr_label ~content:"Description") idref;
  fprintf fmt "%a" (pp_print_html_tab_button ~default:false ~shortlabel:schema_label ~content:"JSON Schema") idref;
  fprintf fmt "@ </div>@ @]";

  let description_content =
    asprintf "<p>%s</p><p><i>Id</i> : %s<br/><i>Category</i> : %s</p>" description id (string_of_err_category category)
  in

  open_vbox 2;

  (* Print description *)
  begin
    fprintf fmt "<div id=\"%s\" class=\"%s tabcontent\" style=\"min-height:100px; max-height:200px; overflow:auto\" >@ "
      (idref ^ descr_label) idref;
    fprintf fmt "%s@ " description_content;
    fprintf fmt "</div>@]";
  end;

  (* Print schema *)
  begin
    (* Hack: negative offset in order to reduce the <pre>'s content left-margin *)
    (* TODO: pretty-(html)-print the schema *)
    open_vbox (-8);
    fprintf fmt "<div id=\"%s\" class=\"%s tabcontent\" style=\"min-height:100px; max-height:200px; overflow:auto\" >@ "
      (idref ^ schema_label) idref;
    fprintf fmt "<%s>@ %a</%s>@ " "pre" Json_schema.pp schema "pre";
    fprintf fmt "</div>";
    close_box ();
  end;

  close_box ()

let pp_info_to_rst
    ppf
    (Error_monad.{ title ; _ } as error_info) =
  let open Format in

  fprintf ppf "**%s**@\n@\n" (if title = "" then "<Untitled>" else title);
  fprintf ppf "@[<v>%a@ @ @]" pp_print_html_tabs error_info;

module ErrorSet = Set.Make(struct
    type t = Error_monad.error_info
    let compare { Error_monad.id ; _ } { Error_monad.id = id' ; _ } =
      String.compare id id'
  end)

module ErrorPartition = struct
  include Map.Make(struct
      include String
      let titles = List.map snd section_titles

      let compare s s' =
        let idx s =
          let rec loop acc = function
            | [] -> assert false
            | h::_ when h = s -> acc
            | _::t -> loop (acc + 1) t
          in loop 0 titles
        in
        Pervasives.compare (idx s) (idx s')
    end)

  let add_error (id : key) (error : Error_monad.error_info) (map : 'a t) =
    let title =
      try
        snd
          (List.find
             (fun (id_set, _) ->
                List.exists (fun pattern -> Stringext.find_from id ~pattern = Some 0) id_set)
             section_titles)
      with
      | Not_found -> default_section_title
    in
    let set =
      try find title map with Not_found -> ErrorSet.empty
    in
    add title (ErrorSet.add error set) map
end

let pp_error_map ppf (map : ErrorSet.t ErrorPartition.t) : unit =
  let open Format in
  ErrorPartition.iter (fun section_title set ->
      fprintf ppf "%a" pp_rst_h2 section_title ;

      ErrorSet.iter
        (fun error_repr ->
           fprintf ppf "@[%a@]@\n@\n" pp_info_to_rst error_repr
        ) set
    ) map

let script =
  "<script>\
   function showTab(elt, tab, ref) {\
   var i, tabcontent, tablinks;\
   \
   tabcontent = document.getElementsByClassName(ref);\
   for (i = 0; i < tabcontent.length; i++) {\
   tabcontent[i].style.display = 'none';\
   }\
   \
   tablinks = elt.parentNode.children;\
   for (i = 0; i < tablinks.length; i++) {\
   tablinks[i].className = tablinks[i].className.replace(' active', '');\
   }\
   \
   document.getElementById(tab).style.display = 'block';\
   elt.className += ' active';\
   }\
   \
   document.addEventListener('DOMContentLoaded', function(){\
   var a = document.getElementsByClassName('defaultOpen');\
   for (i = 0; i < a.length; i++) { a[i].click() }\
   })\
   </script>"

let style =
  "<style>\
   .tab {\
   overflow: hidden;\
   border: 1px solid #ccc;\
   background-color: #f1f1f1;\
   }\
   .tab button {\
   background-color: inherit;\
   float: left;\
   border: none;\
   outline: none;\
   cursor: pointer;\
   padding: 5px 10px;\
   }\
   .tab button:hover {\
   background-color: #ddd;\
   }\
   .tab button.active {\
   background-color: #ccc;\
   }\
   .tabcontent {\
   display: none;\
   padding: 6px 12px;\
   border: 1px solid #ccc;\
   border-top: none;\
   margin-bottom: 20px;\
   }\
   pre {\
   font-size: 12px\
   }</style>"

let print_script ppf =
  (* HACK : show/hide JSON schemas + style *)
  fprintf ppf "@[<v 2>.. raw:: html@\n@\n" ;
  fprintf ppf "@[<v 0>%s%s@]@\n@\n@]@]@." script style

(* Main *)
let () =
  let open Format in
  let ppf = std_formatter in

  (* Header *)
  let title = "RPC Errors" in
  fprintf ppf "%a" pp_rst_h1 title ;

  print_script ppf ;

  fprintf ppf
    "This document references possible errors that can come \
     from RPC calls. It is generated from the OCaml source \
     code (master branch).@\n@\n" ;

  (* Body *)
  let map =
    let all_errors =
      Error_monad.get_registered_errors () in
    List.fold_left
      (fun acc ( Error_monad.{ id ; _ } as error ) ->
         ErrorPartition.add_error id error acc
      ) ErrorPartition.empty all_errors
  in

  fprintf ppf "%a" pp_error_map map