From fb217b9073ae78920c50df12a3016d8bf194da9c Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Mon, 21 Oct 2024 18:19:12 +0200 Subject: [PATCH 1/8] Move Json module to Odoc_utils --- src/html/html_fragment_json.ml | 10 ++-- src/html/odoc_html.ml | 2 +- src/html/utils.ml | 84 ---------------------------------- src/utils/json.ml | 78 +++++++++++++++++++++++++++++++ src/utils/odoc_utils.ml | 1 + 5 files changed, 85 insertions(+), 90 deletions(-) create mode 100644 src/utils/json.ml diff --git a/src/html/html_fragment_json.ml b/src/html/html_fragment_json.ml index 54dac13473..3fe6a9bdbb 100644 --- a/src/html/html_fragment_json.ml +++ b/src/html/html_fragment_json.ml @@ -1,12 +1,12 @@ (* Rendering of HTML fragments together with metadata. For embedding the generated documentation in existing websites. *) +open Odoc_utils module Html = Tyxml.Html module Url = Odoc_document.Url -let json_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) : Utils.Json.json - = +let json_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) : Json.json = let breadcrumb (b : Types.breadcrumb) = `Object [ @@ -18,7 +18,7 @@ let json_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) : Utils.Json.json let json_breadcrumbs = breadcrumbs |> List.map breadcrumb in `Array json_breadcrumbs -let json_of_toc (toc : Types.toc list) : Utils.Json.json = +let json_of_toc (toc : Types.toc list) : Json.json = let rec section (s : Types.toc) = `Object [ @@ -34,7 +34,7 @@ let make ~config ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex ~source_anchor content children = let filename = Link.Path.as_filename ~config url in let filename = Fpath.add_ext ".json" filename in - let json_to_string json = Utils.Json.to_string json in + let json_to_string json = Json.to_string json in let source_anchor = match source_anchor with Some url -> `String url | None -> `Null in @@ -68,7 +68,7 @@ let make_src ~config ~url ~breadcrumbs content = let filename = Link.Path.as_filename ~config url in let filename = Fpath.add_ext ".json" filename in let htmlpp = Html.pp_elt ~indent:(Config.indent config) () in - let json_to_string json = Utils.Json.to_string json in + let json_to_string json = Json.to_string json in let content ppf = Format.pp_print_string ppf (json_to_string diff --git a/src/html/odoc_html.ml b/src/html/odoc_html.ml index e7150f71e5..c05911dcb2 100644 --- a/src/html/odoc_html.ml +++ b/src/html/odoc_html.ml @@ -9,4 +9,4 @@ module Html_page = Html_page module Generator = Generator module Link = Link -module Json = Utils.Json +module Json = Odoc_utils.Json diff --git a/src/html/utils.ml b/src/html/utils.ml index 99281c0cb6..c575214450 100644 --- a/src/html/utils.ml +++ b/src/html/utils.ml @@ -1,87 +1,3 @@ (* Shared utility functions *) let optional_elt f ?a = function [] -> [] | l -> [ f ?a l ] - -module Json = struct - type json = - [ `Null - | `Bool of bool - | `Float of float - | `String of string - | `Array of json list - | `Object of (string * json) list ] - - let rec buffer_add_json b = function - | `Null -> Buffer.add_string b "null" - | `Bool bool -> Buffer.add_string b (if bool then "true" else "false") - | `Float f -> Buffer.add_string b (Printf.sprintf "%.16g" f) - | `String s -> buffer_add_json_string b s - | `Array els -> ( - match els with - | [] -> Buffer.add_string b "[]" - | el :: els -> - let add_sep_el b e = - Buffer.add_char b ','; - buffer_add_json b e - in - Buffer.add_char b '['; - buffer_add_json b el; - List.iter (add_sep_el b) els; - Buffer.add_char b ']') - | `Object mems -> ( - match mems with - | [] -> Buffer.add_string b "{}" - | mem :: mems -> - let add_mem b (k, v) = - buffer_add_json_string b k; - Buffer.add_char b ':'; - buffer_add_json b v - in - let add_sep_mem b mem = - Buffer.add_char b ','; - add_mem b mem - in - Buffer.add_char b '{'; - add_mem b mem; - List.iter (add_sep_mem b) mems; - Buffer.add_char b '}') - - and buffer_add_json_string b s = - let is_control = function - | '\x00' .. '\x1F' | '\x7F' -> true - | _ -> false - in - let len = String.length s in - let max_idx = len - 1 in - let flush b start i = - if start < len then Buffer.add_substring b s start (i - start) - in - let rec loop start i = - match i > max_idx with - | true -> flush b start i - | false -> ( - let next = i + 1 in - match String.get s i with - | '"' -> - flush b start i; - Buffer.add_string b "\\\""; - loop next next - | '\\' -> - flush b start i; - Buffer.add_string b "\\\\"; - loop next next - | c when is_control c -> - flush b start i; - Buffer.add_string b (Printf.sprintf "\\u%04X" (Char.code c)); - loop next next - | _c -> loop start next) - in - Buffer.add_char b '"'; - loop 0 0; - Buffer.add_char b '"' - - let to_string json = - let b = Buffer.create 1024 in - buffer_add_json b json; - Buffer.contents b -end diff --git a/src/utils/json.ml b/src/utils/json.ml new file mode 100644 index 0000000000..33b7d37093 --- /dev/null +++ b/src/utils/json.ml @@ -0,0 +1,78 @@ +type json = + [ `Null + | `Bool of bool + | `Float of float + | `String of string + | `Array of json list + | `Object of (string * json) list ] + +let rec buffer_add_json b = function + | `Null -> Buffer.add_string b "null" + | `Bool bool -> Buffer.add_string b (if bool then "true" else "false") + | `Float f -> Buffer.add_string b (Printf.sprintf "%.16g" f) + | `String s -> buffer_add_json_string b s + | `Array els -> ( + match els with + | [] -> Buffer.add_string b "[]" + | el :: els -> + let add_sep_el b e = + Buffer.add_char b ','; + buffer_add_json b e + in + Buffer.add_char b '['; + buffer_add_json b el; + List.iter (add_sep_el b) els; + Buffer.add_char b ']') + | `Object mems -> ( + match mems with + | [] -> Buffer.add_string b "{}" + | mem :: mems -> + let add_mem b (k, v) = + buffer_add_json_string b k; + Buffer.add_char b ':'; + buffer_add_json b v + in + let add_sep_mem b mem = + Buffer.add_char b ','; + add_mem b mem + in + Buffer.add_char b '{'; + add_mem b mem; + List.iter (add_sep_mem b) mems; + Buffer.add_char b '}') + +and buffer_add_json_string b s = + let is_control = function '\x00' .. '\x1F' | '\x7F' -> true | _ -> false in + let len = String.length s in + let max_idx = len - 1 in + let flush b start i = + if start < len then Buffer.add_substring b s start (i - start) + in + let rec loop start i = + match i > max_idx with + | true -> flush b start i + | false -> ( + let next = i + 1 in + match String.get s i with + | '"' -> + flush b start i; + Buffer.add_string b "\\\""; + loop next next + | '\\' -> + flush b start i; + Buffer.add_string b "\\\\"; + loop next next + | c when is_control c -> + flush b start i; + Buffer.add_string b (Printf.sprintf "\\u%04X" (Char.code c)); + loop next next + | _c -> loop start next) + in + Buffer.add_char b '"'; + loop 0 0; + Buffer.add_char b '"' + +let to_string json = + let b = Buffer.create 1024 in + buffer_add_json b json; + Buffer.contents b diff --git a/src/utils/odoc_utils.ml b/src/utils/odoc_utils.ml index 41294e1785..dab50a7f3e 100644 --- a/src/utils/odoc_utils.ml +++ b/src/utils/odoc_utils.ml @@ -77,3 +77,4 @@ end module Tree = Tree module Forest = Tree.Forest +module Json = Json From 882f2cf527f7fc3a69342689a2ed15ec4e96565d Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Mon, 21 Oct 2024 18:20:05 +0200 Subject: [PATCH 2/8] Sidebar generation: Add a command to generate the sidebar --- src/document/sidebar.ml | 6 +- src/document/sidebar.mli | 10 ++- src/html/generator.ml | 4 ++ src/html/generator.mli | 6 ++ src/odoc/bin/main.ml | 55 +++++++++++++++++ src/odoc/odoc_file.ml | 4 ++ src/odoc/odoc_file.mli | 5 ++ src/odoc/sidebar.ml | 60 ++++++++++++++++++ src/utils/tree.ml | 7 +++ src/utils/tree.mli | 1 + test/roots_and_hierarchy/sidebar.t/run.t | 79 ++++++++++++++++++++++++ 11 files changed, 234 insertions(+), 3 deletions(-) create mode 100644 src/odoc/sidebar.ml diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index f1d69e1429..38895dceff 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -2,8 +2,10 @@ open Odoc_utils open Types module Id = Odoc_model.Paths.Identifier +type entry = Url.t option * Inline.one + module Toc : sig - type t + type t = entry Tree.t val of_page_hierarchy : Odoc_index.Page_hierarchy.t -> t @@ -11,7 +13,7 @@ module Toc : sig val to_block : prune:bool -> Url.Path.t -> t -> Block.t end = struct - type t = (Url.t option * Inline.one) Tree.t + type t = entry Tree.t let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) : t = let f index = diff --git a/src/document/sidebar.mli b/src/document/sidebar.mli index eecb0c8c15..c42e32ec5b 100644 --- a/src/document/sidebar.mli +++ b/src/document/sidebar.mli @@ -1,4 +1,12 @@ -type t +open Odoc_utils +open Types + +type entry = Url.t option * Inline.one + +type pages = { name : string; pages : entry Tree.t } +type library = { name : string; units : entry Tree.t list } + +type t = { pages : pages list; libraries : library list } val of_lang : Odoc_index.t -> t diff --git a/src/html/generator.ml b/src/html/generator.ml index ab1c5da09e..2eaf198a65 100644 --- a/src/html/generator.ml +++ b/src/html/generator.ml @@ -590,3 +590,7 @@ let filepath ~config url = Link.Path.as_filename ~config url let doc ~config ~xref_base_uri b = let resolve = Link.Base xref_base_uri in block ~config ~resolve b + +let inline ~config ~xref_base_uri b = + let resolve = Link.Base xref_base_uri in + inline ~config ~resolve b diff --git a/src/html/generator.mli b/src/html/generator.mli index fa95d3249b..1474390ce8 100644 --- a/src/html/generator.mli +++ b/src/html/generator.mli @@ -11,3 +11,9 @@ val doc : xref_base_uri:string -> Odoc_document.Types.Block.t -> Html_types.flow5_without_sectioning_heading_header_footer Tyxml.Html.elt list + +val inline : + config:Config.t -> + xref_base_uri:string -> + Odoc_document.Types.Inline.t -> + Html_types.phrasing Tyxml.Html.elt list diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 21c3ef234a..03430b9ab3 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -476,6 +476,7 @@ module Indexing = struct Antichain.check (lib_roots |> List.map ~f:snd) ~opt:"-L" >>= fun () -> Indexing.compile marshall ~output ~warnings_options ~occurrences ~lib_roots ~page_roots ~inputs_in_file ~odocls:inputs + let cmd = let dst = let doc = @@ -544,6 +545,59 @@ module Indexing = struct Term.info "compile-index" ~docs ~doc end +module Sidebar = struct + open Or_error + + let output_file ~dst marshall = + match (dst, marshall) with + | Some file, `JSON when not (Fpath.has_ext "json" (Fpath.v file)) -> + Error + (`Msg + "When generating a json index, the output must have a .json file \ + extension") + | Some file, `Marshall when not (Fpath.has_ext "odoc-index" (Fpath.v file)) + -> + Error + (`Msg + "When generating a binary index, the output must have a \ + .odoc-sidebar file extension") + | Some file, _ -> Ok (Fs.File.of_string file) + | None, `JSON -> Ok (Fs.File.of_string "sidebar.json") + | None, `Marshall -> Ok (Fs.File.of_string "sidebar.odoc-sidebar") + + let generate dst json warnings_options input = + let marshall = if json then `JSON else `Marshall in + output_file ~dst marshall >>= fun output -> + Sidebar.generate ~marshall ~output ~warnings_options ~index:input + + let cmd = + let dst = + let doc = + "Output file path. Non-existing intermediate directories are created. \ + Defaults to sidebar.odoc-sidebar, or sidebar.json if --json is \ + passed." + in + Arg.( + value & opt (some string) None & info ~docs ~docv:"PATH" ~doc [ "o" ]) + in + let json = + let doc = "whether to output a json file, or a binary .odoc-index file" in + Arg.(value & flag & info ~doc [ "json" ]) + in + let inputs = + let doc = ".odoc-index file to generate a value from" in + Arg.( + required & pos 0 (some convert_fpath) None & info ~doc ~docv:"FILE" []) + in + Term.( + const handle_error + $ (const generate $ dst $ json $ warnings_options $ inputs)) + + let info ~docs = + let doc = "Generate a sidebar from an index file." in + Term.info "sidebar-generate" ~docs ~doc +end + module Support_files_command = struct let support_files without_theme output_dir = Support_files.write ~without_theme output_dir @@ -1575,6 +1629,7 @@ let () = Support_files_command.(cmd, info ~docs:section_pipeline); Compile_impl.(cmd, info ~docs:section_pipeline); Indexing.(cmd, info ~docs:section_pipeline); + Sidebar.(cmd, info ~docs:section_pipeline); Odoc_manpage.generate ~docs:section_generators; Odoc_latex.generate ~docs:section_generators; Odoc_html_url.(cmd, info ~docs:section_support); diff --git a/src/odoc/odoc_file.ml b/src/odoc/odoc_file.ml index 8a531eaa3c..732994f9a6 100644 --- a/src/odoc/odoc_file.ml +++ b/src/odoc/odoc_file.ml @@ -116,3 +116,7 @@ let load_root file = let save_index dst idx = save_ dst (fun oc -> Marshal.to_channel oc idx []) let load_index file = load_ file (fun ic -> Ok (Marshal.from_channel ic)) + +let save_sidebar dst idx = save_ dst (fun oc -> Marshal.to_channel oc idx []) + +let load_sidebar file = load_ file (fun ic -> Ok (Marshal.from_channel ic)) diff --git a/src/odoc/odoc_file.mli b/src/odoc/odoc_file.mli index 0f6c076efe..79e6c14dbf 100644 --- a/src/odoc/odoc_file.mli +++ b/src/odoc/odoc_file.mli @@ -56,4 +56,9 @@ val save_index : Fs.File.t -> Odoc_index.t -> unit val load_index : Fs.File.t -> (Odoc_index.t, [> msg ]) result (** Load a [.odoc-index] file. *) +val save_sidebar : Fs.File.t -> Odoc_document.Sidebar.t -> unit + +val load_sidebar : Fs.File.t -> (Odoc_document.Sidebar.t, [> msg ]) result +(** Load a [.odoc-index] file. *) + val save_asset : Fpath.t -> warnings:Error.t list -> Lang.Asset.t -> unit diff --git a/src/odoc/sidebar.ml b/src/odoc/sidebar.ml new file mode 100644 index 0000000000..9dbb2dc993 --- /dev/null +++ b/src/odoc/sidebar.ml @@ -0,0 +1,60 @@ +open Or_error +open Odoc_utils + +let toc_to_json ((url, inline) : Odoc_document.Sidebar.entry) : Json.json = + let config = + Odoc_html.Config.v ~semantic_uris:true ~indent:true ~flat:false + ~open_details:false ~as_json:true ~remap:[] () + in + let url = + match url with + | None -> `Null + | Some url -> + let href = + Odoc_html.Link.href ~config ~resolve:(Odoc_html.Link.Base "") url + in + `String href + in + let inline = + let inline = + Odoc_html.Generator.inline ~config ~xref_base_uri:"" [ inline ] + in + let inline = + String.concat "" + @@ List.map (Format.asprintf "%a" (Tyxml.Html.pp_elt ())) inline + in + `String inline + in + `Object [ ("url", url); ("content", inline) ] + +let pages_to_json ({ name; pages } : Odoc_document.Sidebar.pages) = + `Object [ ("name", `String name); ("pages", Tree.to_json toc_to_json pages) ] + +let libs_to_json ({ name; units } : Odoc_document.Sidebar.library) = + `Object + [ + ("name", `String name); + ("modules", `Array (List.map (Tree.to_json toc_to_json) units)); + ] + +let sidebar_to_json ({ pages; libraries } : Odoc_document.Sidebar.t) = + let pages = List.map pages_to_json pages in + let libraries = List.map libs_to_json libraries in + `Object [ ("pages", `Array pages); ("libraries", `Array libraries) ] + +let compile_to_json ~output sidebar = + let json = sidebar_to_json sidebar in + let text = Json.to_string json in + let output_channel = + Fs.Directory.mkdir_p (Fs.File.dirname output); + open_out_bin (Fs.File.to_string output) + in + let output = Format.formatter_of_out_channel output_channel in + Format.fprintf output "%s" text + +let generate ~marshall ~output ~warnings_options:_ ~index = + Odoc_file.load_index index >>= fun index -> + let sidebar = Odoc_document.Sidebar.of_lang index in + match marshall with + | `JSON -> Ok (compile_to_json ~output sidebar) + | `Marshall -> Ok (Odoc_file.save_sidebar output sidebar) diff --git a/src/utils/tree.ml b/src/utils/tree.ml index 2bbc78a141..da9bb9c3bf 100644 --- a/src/utils/tree.ml +++ b/src/utils/tree.ml @@ -9,10 +9,16 @@ module type S = sig val fold_left : f:('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val iter : f:('a -> unit) -> 'a t -> unit val map : f:('a -> 'b) -> 'a t -> 'b t + val to_json : ('a -> Json.json) -> 'a t -> Json.json end type 'a t = 'a tree +let rec to_json json_of { node; children } : Json.json = + `Object [ ("node", json_of node); ("children", to_json_f json_of children) ] + +and to_json_f json_of f = `Array (List.map (to_json json_of) f) + let leaf node = { node; children = [] } let rec fold_left ~f acc { node; children } = @@ -50,4 +56,5 @@ module Forest = struct let iter = iter_forest let map = map_forest let filter_map = filter_map_forest + let to_json = to_json_f end diff --git a/src/utils/tree.mli b/src/utils/tree.mli index 8f3e558dd1..7dc5c68628 100644 --- a/src/utils/tree.mli +++ b/src/utils/tree.mli @@ -9,6 +9,7 @@ module type S = sig val fold_left : f:('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val iter : f:('a -> unit) -> 'a t -> unit val map : f:('a -> 'b) -> 'a t -> 'b t + val to_json : ('a -> Json.json) -> 'a t -> Json.json end include S with type 'a t = 'a tree diff --git a/test/roots_and_hierarchy/sidebar.t/run.t b/test/roots_and_hierarchy/sidebar.t/run.t index 8c0ec9d6b2..4ba5bc5026 100644 --- a/test/roots_and_hierarchy/sidebar.t/run.t +++ b/test/roots_and_hierarchy/sidebar.t/run.t @@ -19,6 +19,85 @@ $ odoc html-generate --indent --index sidebar.odoc-index -o html _odoc/pkg/page-index.odocl $ odoc html-generate --indent --index sidebar.odoc-index -o html _odoc/pkg/libname/unit.odocl +A json version of a sidebar can be obtained using the sidebar-generate command: + + $ odoc sidebar-generate --json sidebar.odoc-index + $ cat sidebar.json | jq + { + "pages": [ + { + "name": "pkg", + "pages": { + "node": { + "url": "pkg/index.html", + "content": "Package pkg" + }, + "children": [ + { + "node": { + "url": "pkg/dir1/index.html", + "content": "A directory" + }, + "children": [ + { + "node": { + "url": "pkg/dir1/my_page.html", + "content": "My page" + }, + "children": [] + } + ] + }, + { + "node": { + "url": "pkg/file.html", + "content": "File" + }, + "children": [] + } + ] + } + } + ], + "libraries": [ + { + "name": "libname", + "modules": [ + { + "node": { + "url": "pkg/libname/Unit/index.html", + "content": "Unit" + }, + "children": [ + { + "node": { + "url": "pkg/libname/Unit/X/index.html", + "content": "X" + }, + "children": [ + { + "node": { + "url": "pkg/libname/Unit/X/Y/index.html", + "content": "Y" + }, + "children": [] + }, + { + "node": { + "url": "pkg/libname/Unit/X/index.html#module-Z", + "content": "Z" + }, + "children": [] + } + ] + } + ] + } + ] + } + ] + } + $ cat html/pkg/index.html | grep odoc-global-toc -A 15