ligo/docs/doc_gen/errors/error_doc.ml

264 lines
8.6 KiB
OCaml
Raw Normal View History

2018-06-29 16:08:08 +04:00
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
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:'`' *)
2018-05-01 00:40:47 +04:00
let string_of_err_category = 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